add files
|
1 |
#!/usr/bin/env perl |
2 |
# |
|
3 |
# You want to install cpanminus? Run the following command and it will |
|
4 |
# install itself for you. You might want to run it as a root with sudo |
|
5 |
# if you want to install to places like /usr/local/bin. |
|
6 |
# |
|
7 |
# % curl -L http://cpanmin.us | perl - --self-upgrade |
|
8 |
# |
|
9 |
# If you don't have curl but wget, replace `curl -L` with `wget -O -`. |
|
10 |
# |
|
11 |
# For more details about this program, visit http://search.cpan.org/dist/App-cpanminus |
|
12 |
# |
|
13 |
# DO NOT EDIT -- this is an auto generated file |
|
14 |
# This chunk of stuff was generated by App::FatPacker. To find the original |
|
15 |
# file's code, look for the end of this BEGIN block or the string 'FATPACK' |
|
16 |
BEGIN { |
|
17 |
my %fatpacked; |
|
18 | ||
19 |
$fatpacked{"App/cpanminus.pm"} = <<'APP_CPANMINUS'; |
|
20 |
package App::cpanminus; |
|
21 |
our $VERSION = "1.6005"; |
|
22 |
|
|
23 |
=head1 NAME |
|
24 |
|
|
25 |
App::cpanminus - get, unpack, build and install modules from CPAN |
|
26 |
|
|
27 |
=head1 SYNOPSIS |
|
28 |
|
|
29 |
cpanm Module |
|
30 |
|
|
31 |
Run C<cpanm -h> or C<perldoc cpanm> for more options. |
|
32 |
|
|
33 |
=head1 DESCRIPTION |
|
34 |
|
|
35 |
cpanminus is a script to get, unpack, build and install modules from |
|
36 |
CPAN and does nothing else. |
|
37 |
|
|
38 |
It's dependency free (can bootstrap itself), requires zero |
|
39 |
configuration, and stands alone. When running, it requires only 10MB |
|
40 |
of RAM. |
|
41 |
|
|
42 |
=head1 INSTALLATION |
|
43 |
|
|
44 |
There are several ways to install cpanminus to your system. |
|
45 |
|
|
46 |
=head2 Package management system |
|
47 |
|
|
48 |
There are Debian packages, RPMs, FreeBSD ports, and packages for other |
|
49 |
operation systems available. If you want to use the package management system, |
|
50 |
search for cpanminus and use the appropriate command to install. This makes it |
|
51 |
easy to install C<cpanm> to your system without thinking about where to |
|
52 |
install, and later upgrade. |
|
53 |
|
|
54 |
=head2 Installing to system perl |
|
55 |
|
|
56 |
You can also use the latest cpanminus to install cpanminus itself: |
|
57 |
|
|
58 |
curl -L http://cpanmin.us | perl - --sudo App::cpanminus |
|
59 |
|
|
60 |
This will install C<cpanm> to your bin directory like |
|
61 |
C</usr/local/bin> (unless you configured C<INSTALL_BASE> with |
|
62 |
L<local::lib>), so you probably need the C<--sudo> option. |
|
63 |
|
|
64 |
=head2 Installing to local perl (perlbrew) |
|
65 |
|
|
66 |
If you have perl in your home directory, which is the case if you use |
|
67 |
tools like L<perlbrew>, you don't need the C<--sudo> option, since |
|
68 |
you're most likely to have a write permission to the perl's library |
|
69 |
path. You can just do: |
|
70 |
|
|
71 |
curl -L http://cpanmin.us | perl - App::cpanminus |
|
72 |
|
|
73 |
to install the C<cpanm> executable to the perl's bin path, like |
|
74 |
C<~/perl5/perlbrew/bin/cpanm>. |
|
75 |
|
|
76 |
=head2 Downloading the standalone executable |
|
77 |
|
|
78 |
You can also copy the standalone executable to whatever location you'd like. |
|
79 |
|
|
80 |
cd ~/bin |
|
81 |
curl -LO http://xrl.us/cpanm |
|
82 |
chmod +x cpanm |
|
83 |
# edit shebang if you don't have /usr/bin/env |
|
84 |
|
|
85 |
This just works, but be sure to grab the new version manually when you |
|
86 |
upgrade because C<--self-upgrade> might not work for this. |
|
87 |
|
|
88 |
=head1 DEPENDENCIES |
|
89 |
|
|
90 |
perl 5.8 or later. |
|
91 |
|
|
92 |
=over 4 |
|
93 |
|
|
94 |
=item * |
|
95 |
|
|
96 |
'tar' executable (bsdtar or GNU tar version 1.22 are rcommended) or Archive::Tar to unpack files. |
|
97 |
|
|
98 |
=item * |
|
99 |
|
|
100 |
C compiler, if you want to build XS modules. |
|
101 |
|
|
102 |
=item * |
|
103 |
|
|
104 |
make |
|
105 |
|
|
106 |
=item * |
|
107 |
|
|
108 |
Module::Build (core in 5.10) |
|
109 |
|
|
110 |
=back |
|
111 |
|
|
112 |
=head1 QUESTIONS |
|
113 |
|
|
114 |
=head2 Another CPAN installer? |
|
115 |
|
|
116 |
OK, the first motivation was this: the CPAN shell runs out of memory (or swaps |
|
117 |
heavily and gets really slow) on Slicehost/linode's most affordable plan with |
|
118 |
only 256MB RAM. Should I pay more to install perl modules from CPAN? I don't |
|
119 |
think so. |
|
120 |
|
|
121 |
=head2 But why a new client? |
|
122 |
|
|
123 |
First of all, let me be clear that CPAN and CPANPLUS are great tools |
|
124 |
I've used for I<literally> years (you know how many modules I have on |
|
125 |
CPAN, right?). I really respect their efforts of maintaining the most |
|
126 |
important tools in the CPAN toolchain ecosystem. |
|
127 |
|
|
128 |
However, for less experienced users (mostly from outside the Perl community), |
|
129 |
or even really experienced Perl developers who know how to shoot themselves in |
|
130 |
their feet, setting up the CPAN toolchain often feels like yak shaving, |
|
131 |
especially when all they want to do is just install some modules and start |
|
132 |
writing code. |
|
133 |
|
|
134 |
=head2 Zero-conf? How does this module get/parse/update the CPAN index? |
|
135 |
|
|
136 |
It queries the CPAN Meta DB site at L<http://cpanmetadb.plackperl.org/>. |
|
137 |
The site is updated at least every hour to reflect the latest changes |
|
138 |
from fast syncing mirrors. The script then also falls back to query the |
|
139 |
module at L<http://metacpan.org/> using its wonderful API. |
|
140 |
|
|
141 |
Fetched files are unpacked in C<~/.cpanm> and automatically cleaned up |
|
142 |
periodically. You can configure the location of this with the |
|
143 |
C<PERL_CPANM_HOME> environment variable. |
|
144 |
|
|
145 |
=head2 Where does this install modules to? Do I need root access? |
|
146 |
|
|
147 |
It installs to wherever ExtUtils::MakeMaker and Module::Build are |
|
148 |
configured to (via C<PERL_MM_OPT> and C<PERL_MB_OPT>). So if you're |
|
149 |
using local::lib, then it installs to your local perl5 |
|
150 |
directory. Otherwise it installs to the site_perl directory that |
|
151 |
belongs to your perl. |
|
152 |
|
|
153 |
cpanminus at a boot time checks whether you have configured |
|
154 |
local::lib, or have the permission to install modules to the site_perl |
|
155 |
directory. If neither, it automatically sets up local::lib compatible |
|
156 |
installation path in a C<perl5> directory under your home |
|
157 |
directory. To avoid this, run the script as the root user, with |
|
158 |
C<--sudo> option or with C<--local-lib> option. |
|
159 |
|
|
160 |
=head2 cpanminus can't install the module XYZ. Is it a bug? |
|
161 |
|
|
162 |
It is more likely a problem with the distribution itself. cpanminus |
|
163 |
doesn't support or is known to have issues with distributions like as |
|
164 |
follows: |
|
165 |
|
|
166 |
=over 4 |
|
167 |
|
|
168 |
=item * |
|
169 |
|
|
170 |
Tests that require input from STDIN. |
|
171 |
|
|
172 |
=item * |
|
173 |
|
|
174 |
Tests that might fail when C<AUTOMATED_TESTING> is enabled. |
|
175 |
|
|
176 |
=item * |
|
177 |
|
|
178 |
Modules that have invalid numeric values as VERSION (such as C<1.1a>) |
|
179 |
|
|
180 |
=back |
|
181 |
|
|
182 |
These failures can be reported back to the author of the module so |
|
183 |
that they can fix it accordingly, rather than me. |
|
184 |
|
|
185 |
=head2 Does cpanm support the feature XYZ of L<CPAN> and L<CPANPLUS>? |
|
186 |
|
|
187 |
Most likely not. Here are the things that cpanm doesn't do by |
|
188 |
itself. And it's a feature - you got that from the name I<minus>, |
|
189 |
right? |
|
190 |
|
|
191 |
If you need these features, use L<CPAN>, L<CPANPLUS> or the standalone |
|
192 |
tools that are mentioned. |
|
193 |
|
|
194 |
=over 4 |
|
195 |
|
|
196 |
=item * |
|
197 |
|
|
198 |
Bundle:: module dependencies |
|
199 |
|
|
200 |
=item * |
|
201 |
|
|
202 |
CPAN testers reporting |
|
203 |
|
|
204 |
=item * |
|
205 |
|
|
206 |
Building RPM packages from CPAN modules |
|
207 |
|
|
208 |
=item * |
|
209 |
|
|
210 |
Listing the outdated modules that needs upgrading. See L<App::cpanoutdated> |
|
211 |
|
|
212 |
=item * |
|
213 |
|
|
214 |
Uninstalling modules. See L<pm-uninstall>. |
|
215 |
|
|
216 |
=item * |
|
217 |
|
|
218 |
Showing the changes of the modules you're about to upgrade. See L<cpan-listchanges> |
|
219 |
|
|
220 |
=item * |
|
221 |
|
|
222 |
Patching CPAN modules with distroprefs. |
|
223 |
|
|
224 |
=back |
|
225 |
|
|
226 |
See L<cpanm> or C<cpanm -h> to see what cpanminus I<can> do :) |
|
227 |
|
|
228 |
=head1 COPYRIGHT |
|
229 |
|
|
230 |
Copyright 2010- Tatsuhiko Miyagawa |
|
231 |
|
|
232 |
The standalone executable contains the following modules embedded. |
|
233 |
|
|
234 |
=over 4 |
|
235 |
|
|
236 |
=item L<CPAN::DistnameInfo> Copyright 2003 Graham Barr |
|
237 |
|
|
238 |
=item L<Parse::CPAN::Meta> Copyright 2006-2009 Adam Kennedy |
|
239 |
|
|
240 |
=item L<local::lib> Copyright 2007-2009 Matt S Trout |
|
241 |
|
|
242 |
=item L<HTTP::Tiny> Copyright 2011 Christian Hansen |
|
243 |
|
|
244 |
=item L<Module::Metadata> Copyright 2001-2006 Ken Williams. 2010 Matt S Trout |
|
245 |
|
|
246 |
=item L<version> Copyright 2004-2010 John Peacock |
|
247 |
|
|
248 |
=item L<JSON::PP> Copyright 2007−2011 by Makamaka Hannyaharamitu |
|
249 |
|
|
250 |
=item L<CPAN::Meta>, L<CPAN::Meta::Requirements> Copyright (c) 2010 by David Golden and Ricardo Signes |
|
251 |
|
|
252 |
=item L<CPAN::Meta::YAML> Copyright 2010 Adam Kennedy |
|
253 |
|
|
254 |
=item L<File::pushd> Copyright 2012 David Golden |
|
255 |
|
|
256 |
=back |
|
257 |
|
|
258 |
=head1 LICENSE |
|
259 |
|
|
260 |
Same as Perl. |
|
261 |
|
|
262 |
=head1 CREDITS |
|
263 |
|
|
264 |
=head2 CONTRIBUTORS |
|
265 |
|
|
266 |
Patches and code improvements were contributed by: |
|
267 |
|
|
268 |
Goro Fuji, Kazuhiro Osawa, Tokuhiro Matsuno, Kenichi Ishigaki, Ian |
|
269 |
Wells, Pedro Melo, Masayoshi Sekimura, Matt S Trout (mst), squeeky, |
|
270 |
horus and Ingy dot Net. |
|
271 |
|
|
272 |
=head2 ACKNOWLEDGEMENTS |
|
273 |
|
|
274 |
Bug reports, suggestions and feedbacks were sent by, or general |
|
275 |
acknowledgement goes to: |
|
276 |
|
|
277 |
Jesse Vincent, David Golden, Andreas Koenig, Jos Boumans, Chris |
|
278 |
Williams, Adam Kennedy, Audrey Tang, J. Shirley, Chris Prather, Jesse |
|
279 |
Luehrs, Marcus Ramberg, Shawn M Moore, chocolateboy, Chirs Nehren, |
|
280 |
Jonathan Rockway, Leon Brocard, Simon Elliott, Ricardo Signes, AEvar |
|
281 |
Arnfjord Bjarmason, Eric Wilhelm, Florian Ragwitz and xaicron. |
|
282 |
|
|
283 |
=head1 COMMUNITY |
|
284 |
|
|
285 |
=over 4 |
|
286 |
|
|
287 |
=item L<http://github.com/miyagawa/cpanminus> - source code repository, issue tracker |
|
288 |
|
|
289 |
=item L<irc://irc.perl.org/#toolchain> - discussions about Perl toolchain. I'm there. |
|
290 |
|
|
291 |
=back |
|
292 |
|
|
293 |
=head1 NO WARRANTY |
|
294 |
|
|
295 |
This software is provided "as-is," without any express or implied |
|
296 |
warranty. In no event shall the author be held liable for any damages |
|
297 |
arising from the use of the software. |
|
298 |
|
|
299 |
=head1 SEE ALSO |
|
300 |
|
|
301 |
L<CPAN> L<CPANPLUS> L<pip> |
|
302 |
|
|
303 |
=cut |
|
304 |
|
|
305 |
1; |
|
306 |
APP_CPANMINUS |
|
307 | ||
308 |
$fatpacked{"App/cpanminus/script.pm"} = <<'APP_CPANMINUS_SCRIPT'; |
|
309 |
package App::cpanminus::script; |
|
310 |
use strict; |
|
311 |
use Config; |
|
312 |
use Cwd (); |
|
313 |
use App::cpanminus; |
|
314 |
use File::Basename (); |
|
315 |
use File::Find (); |
|
316 |
use File::Path (); |
|
317 |
use File::Spec (); |
|
318 |
use File::Copy (); |
|
319 |
use File::Temp (); |
|
320 |
use Getopt::Long (); |
|
321 |
use Parse::CPAN::Meta; |
|
322 |
use Symbol (); |
|
323 |
|
|
324 |
use constant WIN32 => $^O eq 'MSWin32'; |
|
325 |
use constant SUNOS => $^O eq 'solaris'; |
|
326 |
|
|
327 |
our $VERSION = $App::cpanminus::VERSION; |
|
328 |
|
|
329 |
if ($INC{"App/FatPacker/Trace.pm"}) { |
|
330 |
require JSON::PP; |
|
331 |
require CPAN::Meta::YAML; |
|
332 |
require CPAN::Meta::Prereqs; |
|
333 |
require version::vpp; |
|
334 |
require File::pushd; |
|
335 |
} |
|
336 |
|
|
337 |
my $quote = WIN32 ? q/"/ : q/'/; |
|
338 |
|
|
339 |
sub agent { |
|
340 |
my $self = shift; |
|
341 |
"cpanminus/$VERSION perl/$]"; |
|
342 |
} |
|
343 |
|
|
344 |
sub determine_home { |
|
345 |
my $class = shift; |
|
346 |
|
|
347 |
my $homedir = $ENV{HOME} |
|
348 |
|| eval { require File::HomeDir; File::HomeDir->my_home } |
|
349 |
|| join('', @ENV{qw(HOMEDRIVE HOMEPATH)}); # Win32 |
|
350 |
|
|
351 |
if (WIN32) { |
|
352 |
require Win32; # no fatpack |
|
353 |
$homedir = Win32::GetShortPathName($homedir); |
|
354 |
} |
|
355 |
|
|
356 |
return "$homedir/.cpanm"; |
|
357 |
} |
|
358 |
|
|
359 |
sub new { |
|
360 |
my $class = shift; |
|
361 |
|
|
362 |
bless { |
|
363 |
home => $class->determine_home, |
|
364 |
cmd => 'install', |
|
365 |
seen => {}, |
|
366 |
notest => undef, |
|
367 |
test_only => undef, |
|
368 |
installdeps => undef, |
|
369 |
force => undef, |
|
370 |
sudo => undef, |
|
371 |
make => undef, |
|
372 |
verbose => undef, |
|
373 |
quiet => undef, |
|
374 |
interactive => undef, |
|
375 |
log => undef, |
|
376 |
mirrors => [], |
|
377 |
mirror_only => undef, |
|
378 |
mirror_index => undef, |
|
379 |
perl => $^X, |
|
380 |
argv => [], |
|
381 |
local_lib => undef, |
|
382 |
self_contained => undef, |
|
383 |
prompt_timeout => 0, |
|
384 |
prompt => undef, |
|
385 |
configure_timeout => 60, |
|
386 |
try_lwp => 1, |
|
387 |
try_wget => 1, |
|
388 |
try_curl => 1, |
|
389 |
uninstall_shadows => ($] < 5.012), |
|
390 |
skip_installed => 1, |
|
391 |
skip_satisfied => 0, |
|
392 |
auto_cleanup => 7, # days |
|
393 |
pod2man => 1, |
|
394 |
installed_dists => 0, |
|
395 |
showdeps => 0, |
|
396 |
scandeps => 0, |
|
397 |
scandeps_tree => [], |
|
398 |
format => 'tree', |
|
399 |
save_dists => undef, |
|
400 |
skip_configure => 0, |
|
401 |
verify => 0, |
|
402 |
@_, |
|
403 |
}, $class; |
|
404 |
} |
|
405 |
|
|
406 |
sub env { |
|
407 |
my($self, $key) = @_; |
|
408 |
$ENV{"PERL_CPANM_" . $key}; |
|
409 |
} |
|
410 |
|
|
411 |
sub parse_options { |
|
412 |
my $self = shift; |
|
413 |
|
|
414 |
local @ARGV = @{$self->{argv}}; |
|
415 |
push @ARGV, split /\s+/, $self->env('OPT'); |
|
416 |
push @ARGV, @_; |
|
417 |
|
|
418 |
Getopt::Long::Configure("bundling"); |
|
419 |
Getopt::Long::GetOptions( |
|
420 |
'f|force' => sub { $self->{skip_installed} = 0; $self->{force} = 1 }, |
|
421 |
'n|notest!' => \$self->{notest}, |
|
422 |
'test-only' => sub { $self->{notest} = 0; $self->{skip_installed} = 0; $self->{test_only} = 1 }, |
|
423 |
'S|sudo!' => \$self->{sudo}, |
|
424 |
'v|verbose' => sub { $self->{verbose} = $self->{interactive} = 1 }, |
|
425 |
'verify!' => \$self->{verify}, |
|
426 |
'q|quiet!' => \$self->{quiet}, |
|
427 |
'h|help' => sub { $self->{action} = 'show_help' }, |
|
428 |
'V|version' => sub { $self->{action} = 'show_version' }, |
|
429 |
'perl=s' => \$self->{perl}, |
|
430 |
'l|local-lib=s' => sub { $self->{local_lib} = $self->maybe_abs($_[1]) }, |
|
431 |
'L|local-lib-contained=s' => sub { |
|
432 |
$self->{local_lib} = $self->maybe_abs($_[1]); |
|
433 |
$self->{self_contained} = 1; |
|
434 |
$self->{pod2man} = undef; |
|
435 |
}, |
|
436 |
'mirror=s@' => $self->{mirrors}, |
|
437 |
'mirror-only!' => \$self->{mirror_only}, |
|
438 |
'mirror-index=s' => \$self->{mirror_index}, |
|
439 |
'cascade-search!' => \$self->{cascade_search}, |
|
440 |
'prompt!' => \$self->{prompt}, |
|
441 |
'installdeps' => \$self->{installdeps}, |
|
442 |
'skip-installed!' => \$self->{skip_installed}, |
|
443 |
'skip-satisfied!' => \$self->{skip_satisfied}, |
|
444 |
'reinstall' => sub { $self->{skip_installed} = 0 }, |
|
445 |
'interactive!' => \$self->{interactive}, |
|
446 |
'i|install' => sub { $self->{cmd} = 'install' }, |
|
447 |
'info' => sub { $self->{cmd} = 'info' }, |
|
448 |
'look' => sub { $self->{cmd} = 'look'; $self->{skip_installed} = 0 }, |
|
449 |
'self-upgrade' => sub { $self->check_upgrade; $self->{cmd} = 'install'; $self->{skip_installed} = 1; push @ARGV, 'App::cpanminus' }, |
|
450 |
'uninst-shadows!' => \$self->{uninstall_shadows}, |
|
451 |
'lwp!' => \$self->{try_lwp}, |
|
452 |
'wget!' => \$self->{try_wget}, |
|
453 |
'curl!' => \$self->{try_curl}, |
|
454 |
'auto-cleanup=s' => \$self->{auto_cleanup}, |
|
455 |
'man-pages!' => \$self->{pod2man}, |
|
456 |
'scandeps' => \$self->{scandeps}, |
|
457 |
'showdeps' => sub { $self->{showdeps} = 1; $self->{skip_installed} = 0 }, |
|
458 |
'format=s' => \$self->{format}, |
|
459 |
'save-dists=s' => sub { |
|
460 |
$self->{save_dists} = $self->maybe_abs($_[1]); |
|
461 |
}, |
|
462 |
'skip-configure!' => \$self->{skip_configure}, |
|
463 |
'dev!' => \$self->{dev_release}, |
|
464 |
'metacpan!' => \$self->{metacpan}, |
|
465 |
); |
|
466 |
|
|
467 |
if (!@ARGV && $0 ne '-' && !-t STDIN){ # e.g. # cpanm < author/requires.cpanm |
|
468 |
push @ARGV, $self->load_argv_from_fh(\*STDIN); |
|
469 |
$self->{load_from_stdin} = 1; |
|
470 |
} |
|
471 |
|
|
472 |
$self->{argv} = \@ARGV; |
|
473 |
} |
|
474 |
|
|
475 |
sub check_upgrade { |
|
476 |
if ($0 !~ /^$Config{installsitebin}/) { |
|
477 |
if ($0 =~ m!perlbrew/bin!) { |
|
478 |
warn <<WARN; |
|
479 |
It appears your cpanm executable was installed via `perlbrew install-cpanm`. |
|
480 |
cpanm --self-upgrade won't upgrade the version of cpanm you're running. |
|
481 |
|
|
482 |
Run the following command to get it upgraded. |
|
483 |
|
|
484 |
perlbrew install-cpanm |
|
485 |
|
|
486 |
WARN |
|
487 |
} else { |
|
488 |
warn <<WARN; |
|
489 |
You are running cpanm from the path where your current perl won't install executables to. |
|
490 |
Because of that, cpanm --self-upgrade won't upgrade the version of cpanm you're running. |
|
491 |
|
|
492 |
cpanm path : $0 |
|
493 |
Install path : $Config{installsitebin} |
|
494 |
|
|
495 |
It means you either installed cpanm globally with system perl, or use distro packages such |
|
496 |
as rpm or apt-get, and you have to use them again to upgrade cpanm. |
|
497 |
WARN |
|
498 |
} |
|
499 |
} |
|
500 |
} |
|
501 |
|
|
502 |
sub check_libs { |
|
503 |
my $self = shift; |
|
504 |
return if $self->{_checked}++; |
|
505 |
|
|
506 |
$self->bootstrap_local_lib; |
|
507 |
if (@{$self->{bootstrap_deps} || []}) { |
|
508 |
local $self->{notest} = 1; # test failure in bootstrap should be tolerated |
|
509 |
local $self->{scandeps} = 0; |
|
510 |
$self->install_deps(Cwd::cwd, 0, @{$self->{bootstrap_deps}}); |
|
511 |
} |
|
512 |
} |
|
513 |
|
|
514 |
sub setup_verify { |
|
515 |
my $self = shift; |
|
516 |
|
|
517 |
my $has_modules = eval { require Module::Signature; require Digest::SHA; 1 }; |
|
518 |
$self->{cpansign} = $self->which('cpansign'); |
|
519 |
|
|
520 |
unless ($has_modules && $self->{cpansign}) { |
|
521 |
warn "WARNING: Module::Signature and Digest::SHA is required for distribution verifications.\n"; |
|
522 |
$self->{verify} = 0; |
|
523 |
} |
|
524 |
} |
|
525 |
|
|
526 |
sub parse_module_args { |
|
527 |
my($self, $module) = @_; |
|
528 |
|
|
529 |
# Plack@1.2 -> Plack~"==1.2" |
|
530 |
# BUT don't expand @ in git URLs |
|
531 |
$module =~ s/^([A-Za-z0-9_:]+)@([v\d\._]+)$/$1~== $2/; |
|
532 |
|
|
533 |
# Plack~1.20, DBI~"> 1.0, <= 2.0" |
|
534 |
if ($module =~ /\~[v\d\._,\!<>= ]+$/) { |
|
535 |
return split /\~/, $module, 2; |
|
536 |
} else { |
|
537 |
return $module, undef; |
|
538 |
} |
|
539 |
} |
|
540 |
|
|
541 |
sub doit { |
|
542 |
my $self = shift; |
|
543 |
|
|
544 |
$self->setup_home; |
|
545 |
$self->init_tools; |
|
546 |
$self->setup_verify if $self->{verify}; |
|
547 |
|
|
548 |
if (my $action = $self->{action}) { |
|
549 |
$self->$action() and return 1; |
|
550 |
} |
|
551 |
|
|
552 |
$self->show_help(1) |
|
553 |
unless @{$self->{argv}} or $self->{load_from_stdin}; |
|
554 |
|
|
555 |
$self->configure_mirrors; |
|
556 |
|
|
557 |
my $cwd = Cwd::cwd; |
|
558 |
|
|
559 |
my @fail; |
|
560 |
for my $module (@{$self->{argv}}) { |
|
561 |
if ($module =~ s/\.pm$//i) { |
|
562 |
my ($volume, $dirs, $file) = File::Spec->splitpath($module); |
|
563 |
$module = join '::', grep { $_ } File::Spec->splitdir($dirs), $file; |
|
564 |
} |
|
565 |
|
|
566 |
($module, my $version) = $self->parse_module_args($module); |
|
567 |
if ($self->{skip_satisfied}) { |
|
568 |
$self->check_libs; |
|
569 |
my($ok, $local) = $self->check_module($module, $version || 0); |
|
570 |
if ($ok) { |
|
571 |
$self->diag("You have $module ($local)\n", 1); |
|
572 |
next; |
|
573 |
} |
|
574 |
} |
|
575 |
|
|
576 |
$self->chdir($cwd); |
|
577 |
$self->install_module($module, 0, $version) |
|
578 |
or push @fail, $module; |
|
579 |
} |
|
580 |
|
|
581 |
if ($self->{base} && $self->{auto_cleanup}) { |
|
582 |
$self->cleanup_workdirs; |
|
583 |
} |
|
584 |
|
|
585 |
if ($self->{installed_dists}) { |
|
586 |
my $dists = $self->{installed_dists} > 1 ? "distributions" : "distribution"; |
|
587 |
$self->diag("$self->{installed_dists} $dists installed\n", 1); |
|
588 |
} |
|
589 |
|
|
590 |
if ($self->{scandeps}) { |
|
591 |
$self->dump_scandeps(); |
|
592 |
} |
|
593 |
# Workaround for older File::Temp's |
|
594 |
# where creating a tempdir with an implicit $PWD |
|
595 |
# causes tempdir non-cleanup if $PWD changes |
|
596 |
# as paths are stored internally without being resolved |
|
597 |
# absolutely. |
|
598 |
# https://rt.cpan.org/Public/Bug/Display.html?id=44924 |
|
599 |
$self->chdir($cwd); |
|
600 |
|
|
601 |
return !@fail; |
|
602 |
} |
|
603 |
|
|
604 |
sub setup_home { |
|
605 |
my $self = shift; |
|
606 |
|
|
607 |
$self->{home} = $self->env('HOME') if $self->env('HOME'); |
|
608 |
|
|
609 |
unless (_writable($self->{home})) { |
|
610 |
die "Can't write to cpanm home '$self->{home}': You should fix it with chown/chmod first.\n"; |
|
611 |
} |
|
612 |
|
|
613 |
$self->{base} = "$self->{home}/work/" . time . ".$$"; |
|
614 |
File::Path::mkpath([ $self->{base} ], 0, 0777); |
|
615 |
|
|
616 |
my $link = "$self->{home}/latest-build"; |
|
617 |
eval { unlink $link; symlink $self->{base}, $link }; |
|
618 |
|
|
619 |
$self->{log} = File::Spec->catfile($self->{home}, "build.log"); # because we use shell redirect |
|
620 |
|
|
621 |
{ |
|
622 |
my $log = $self->{log}; my $base = $self->{base}; |
|
623 |
$self->{at_exit} = sub { |
|
624 |
my $self = shift; |
|
625 |
File::Copy::copy($self->{log}, "$self->{base}/build.log"); |
|
626 |
}; |
|
627 |
} |
|
628 |
|
|
629 |
{ open my $out, ">$self->{log}" or die "$self->{log}: $!" } |
|
630 |
|
|
631 |
$self->chat("cpanm (App::cpanminus) $VERSION on perl $] built for $Config{archname}\n" . |
|
632 |
"Work directory is $self->{base}\n"); |
|
633 |
} |
|
634 |
|
|
635 |
sub fetch_meta_sco { |
|
636 |
my($self, $dist) = @_; |
|
637 |
return if $self->{mirror_only}; |
|
638 |
|
|
639 |
my $meta_yml = $self->get("http://search.cpan.org/meta/$dist->{distvname}/META.yml"); |
|
640 |
return $self->parse_meta_string($meta_yml); |
|
641 |
} |
|
642 |
|
|
643 |
sub package_index_for { |
|
644 |
my ($self, $mirror) = @_; |
|
645 |
return $self->source_for($mirror) . "/02packages.details.txt"; |
|
646 |
} |
|
647 |
|
|
648 |
sub generate_mirror_index { |
|
649 |
my ($self, $mirror) = @_; |
|
650 |
my $file = $self->package_index_for($mirror); |
|
651 |
my $gz_file = $file . '.gz'; |
|
652 |
my $index_mtime = (stat $gz_file)[9]; |
|
653 |
|
|
654 |
unless (-e $file && (stat $file)[9] >= $index_mtime) { |
|
655 |
$self->chat("Uncompressing index file...\n"); |
|
656 |
if (eval {require Compress::Zlib}) { |
|
657 |
my $gz = Compress::Zlib::gzopen($gz_file, "rb") |
|
658 |
or do { $self->diag_fail("$Compress::Zlib::gzerrno opening compressed index"); return}; |
|
659 |
open my $fh, '>', $file |
|
660 |
or do { $self->diag_fail("$! opening uncompressed index for write"); return }; |
|
661 |
my $buffer; |
|
662 |
while (my $status = $gz->gzread($buffer)) { |
|
663 |
if ($status < 0) { |
|
664 |
$self->diag_fail($gz->gzerror . " reading compressed index"); |
|
665 |
return; |
|
666 |
} |
|
667 |
print $fh $buffer; |
|
668 |
} |
|
669 |
} else { |
|
670 |
if (system("gunzip -c $gz_file > $file")) { |
|
671 |
$self->diag_fail("Cannot uncompress -- please install gunzip or Compress::Zlib"); |
|
672 |
return; |
|
673 |
} |
|
674 |
} |
|
675 |
utime $index_mtime, $index_mtime, $file; |
|
676 |
} |
|
677 |
return 1; |
|
678 |
} |
|
679 |
|
|
680 |
sub search_mirror_index { |
|
681 |
my ($self, $mirror, $module, $version) = @_; |
|
682 |
$self->search_mirror_index_file($self->package_index_for($mirror), $module, $version); |
|
683 |
} |
|
684 |
|
|
685 |
sub search_mirror_index_file { |
|
686 |
my($self, $file, $module, $version) = @_; |
|
687 |
|
|
688 |
open my $fh, '<', $file or return; |
|
689 |
my $found; |
|
690 |
while (<$fh>) { |
|
691 |
if (m!^\Q$module\E\s+([\w\.]+)\s+(\S*)!m) { |
|
692 |
$found = $self->cpan_module($module, $2, $1); |
|
693 |
last; |
|
694 |
} |
|
695 |
} |
|
696 |
|
|
697 |
return $found unless $self->{cascade_search}; |
|
698 |
|
|
699 |
if ($found) { |
|
700 |
if ($self->satisfy_version($module, $found->{module_version}, $version)) { |
|
701 |
return $found; |
|
702 |
} else { |
|
703 |
$self->chat("Found $module $found->{module_version} which doesn't satisfy $version.\n"); |
|
704 |
} |
|
705 |
} |
|
706 |
|
|
707 |
return; |
|
708 |
} |
|
709 |
|
|
710 |
sub with_version_range { |
|
711 |
my($self, $version) = @_; |
|
712 |
defined($version) && $version =~ /[<>=]/; |
|
713 |
} |
|
714 |
|
|
715 |
sub encode_json { |
|
716 |
my($self, $data) = @_; |
|
717 |
require JSON::PP; |
|
718 |
|
|
719 |
my $json = JSON::PP::encode_json($data); |
|
720 |
$json =~ s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/eg; |
|
721 |
$json; |
|
722 |
} |
|
723 |
|
|
724 |
# TODO extract this as a module? |
|
725 |
sub version_to_query { |
|
726 |
my($self, $module, $version) = @_; |
|
727 |
|
|
728 |
require CPAN::Meta::Requirements; |
|
729 |
|
|
730 |
my $requirements = CPAN::Meta::Requirements->new; |
|
731 |
$requirements->add_string_requirement($module, $version || '0'); |
|
732 |
|
|
733 |
my $req = $requirements->requirements_for_module($module); |
|
734 |
|
|
735 |
if ($req =~ s/^==\s*//) { |
|
736 |
return { |
|
737 |
term => { 'module.version' => $req }, |
|
738 |
}; |
|
739 |
} elsif ($req !~ /\s/) { |
|
740 |
return { |
|
741 |
range => { 'module.version_numified' => { 'gte' => $self->numify_ver($req) } }, |
|
742 |
}; |
|
743 |
} else { |
|
744 |
my %ops = qw(< lt <= lte > gt >= gte); |
|
745 |
my(%range, @exclusion); |
|
746 |
my @requirements = split /,\s*/, $req; |
|
747 |
for my $r (@requirements) { |
|
748 |
if ($r =~ s/^([<>]=?)\s*//) { |
|
749 |
$range{$ops{$1}} = $self->numify_ver($r); |
|
750 |
} elsif ($r =~ s/\!=\s*//) { |
|
751 |
push @exclusion, $self->numify_ver($r); |
|
752 |
} |
|
753 |
} |
|
754 |
|
|
755 |
my @filters= ( |
|
756 |
{ range => { 'module.version_numified' => \%range } }, |
|
757 |
); |
|
758 |
|
|
759 |
if (@exclusion) { |
|
760 |
push @filters, { |
|
761 |
not => { or => [ map { +{ term => { 'module.version_numified' => $self->numify_ver($_) } } } @exclusion ] }, |
|
762 |
}; |
|
763 |
} |
|
764 |
|
|
765 |
return @filters; |
|
766 |
} |
|
767 |
} |
|
768 |
|
|
769 |
sub numify_ver { |
|
770 |
my($self, $ver) = @_; |
|
771 |
version->new($ver)->numify; |
|
772 |
} |
|
773 |
|
|
774 |
sub maturity_filter { |
|
775 |
my($self, $module, $version) = @_; |
|
776 |
|
|
777 |
my @filters; |
|
778 |
|
|
779 |
# TODO: dev release should be enabled per dist |
|
780 |
if (!$self->with_version_range($version) or $self->{dev_release}) { |
|
781 |
# backpan'ed dev release are considered "cancelled" |
|
782 |
push @filters, { not => { term => { status => 'backpan' } } }; |
|
783 |
} |
|
784 |
|
|
785 |
unless ($self->{dev_release} or $version =~ /==/) { |
|
786 |
push @filters, { term => { maturity => 'released' } }; |
|
787 |
} |
|
788 |
|
|
789 |
return @filters; |
|
790 |
} |
|
791 |
|
|
792 |
sub search_metacpan { |
|
793 |
my($self, $module, $version) = @_; |
|
794 |
|
|
795 |
require JSON::PP; |
|
796 |
|
|
797 |
$self->chat("Searching $module ($version) on metacpan ...\n"); |
|
798 |
|
|
799 |
my $metacpan_uri = 'http://api.metacpan.org/v0'; |
|
800 |
|
|
801 |
my @filter = $self->maturity_filter($module, $version); |
|
802 |
|
|
803 |
my $query = { filtered => { |
|
804 |
(@filter ? (filter => { and => \@filter }) : ()), |
|
805 |
query => { nested => { |
|
806 |
score_mode => 'max', |
|
807 |
path => 'module', |
|
808 |
query => { custom_score => { |
|
809 |
metacpan_script => "score_version_numified", |
|
810 |
query => { constant_score => { |
|
811 |
filter => { and => [ |
|
812 |
{ term => { 'module.authorized' => JSON::PP::true() } }, |
|
813 |
{ term => { 'module.indexed' => JSON::PP::true() } }, |
|
814 |
{ term => { 'module.name' => $module } }, |
|
815 |
$self->version_to_query($module, $version), |
|
816 |
] } |
|
817 |
} }, |
|
818 |
} }, |
|
819 |
} }, |
|
820 |
} }; |
|
821 |
|
|
822 |
my $module_uri = "$metacpan_uri/file/_search?source="; |
|
823 |
$module_uri .= $self->encode_json({ |
|
824 |
query => $query, |
|
825 |
fields => [ 'release', 'module' ], |
|
826 |
}); |
|
827 |
|
|
828 |
my($release, $module_version); |
|
829 |
|
|
830 |
my $module_json = $self->get($module_uri); |
|
831 |
my $module_meta = eval { JSON::PP::decode_json($module_json) }; |
|
832 |
my $match = $module_meta ? $module_meta->{hits}{hits}[0]{fields} : undef; |
|
833 |
if ($match) { |
|
834 |
$release = $match->{release}; |
|
835 |
my $module_matched = (grep { $_->{name} eq $module } @{$match->{module}})[0]; |
|
836 |
$module_version = $module_matched->{version}; |
|
837 |
} |
|
838 |
|
|
839 |
unless ($release) { |
|
840 |
$self->chat("! Could not find a release matching $module ($version) on MetaCPAN.\n"); |
|
841 |
return; |
|
842 |
} |
|
843 |
|
|
844 |
my $dist_uri = "$metacpan_uri/release/_search?source="; |
|
845 |
$dist_uri .= $self->encode_json({ |
|
846 |
filter => { |
|
847 |
term => { 'release.name' => $release }, |
|
848 |
}, |
|
849 |
fields => [ 'download_url', 'stat', 'status' ], |
|
850 |
}); |
|
851 |
|
|
852 |
my $dist_json = $self->get($dist_uri); |
|
853 |
my $dist_meta = eval { JSON::PP::decode_json($dist_json) }; |
|
854 |
|
|
855 |
if ($dist_meta) { |
|
856 |
$dist_meta = $dist_meta->{hits}{hits}[0]{fields}; |
|
857 |
} |
|
858 |
if ($dist_meta && $dist_meta->{download_url}) { |
|
859 |
(my $distfile = $dist_meta->{download_url}) =~ s!.+/authors/id/!!; |
|
860 |
local $self->{mirrors} = $self->{mirrors}; |
|
861 |
if ($dist_meta->{status} eq 'backpan') { |
|
862 |
$self->{mirrors} = [ 'http://backpan.perl.org' ]; |
|
863 |
} elsif ($dist_meta->{stat}{mtime} > time()-24*60*60) { |
|
864 |
$self->{mirrors} = [ 'http://cpan.metacpan.org' ]; |
|
865 |
} |
|
866 |
return $self->cpan_module($module, $distfile, $module_version); |
|
867 |
} |
|
868 |
|
|
869 |
$self->diag_fail("Finding $module on metacpan failed."); |
|
870 |
return; |
|
871 |
} |
|
872 |
|
|
873 |
sub search_database { |
|
874 |
my($self, $module, $version) = @_; |
|
875 |
|
|
876 |
my $found; |
|
877 |
my $range = ($self->with_version_range($version) || $self->{dev_release}); |
|
878 |
|
|
879 |
if ($range or $self->{metacpan}) { |
|
880 |
$found = $self->search_metacpan($module, $version) and return $found; |
|
881 |
$found = $self->search_cpanmetadb($module, $version) and return $found; |
|
882 |
} else { |
|
883 |
$found = $self->search_cpanmetadb($module, $version) and return $found; |
|
884 |
$found = $self->search_metacpan($module, $version) and return $found; |
|
885 |
} |
|
886 |
} |
|
887 |
|
|
888 |
sub search_cpanmetadb { |
|
889 |
my($self, $module, $version) = @_; |
|
890 |
|
|
891 |
$self->chat("Searching $module on cpanmetadb ...\n"); |
|
892 |
|
|
893 |
my $uri = "http://cpanmetadb.plackperl.org/v1.0/package/$module"; |
|
894 |
my $yaml = $self->get($uri); |
|
895 |
my $meta = $self->parse_meta_string($yaml); |
|
896 |
if ($meta && $meta->{distfile}) { |
|
897 |
return $self->cpan_module($module, $meta->{distfile}, $meta->{version}); |
|
898 |
} |
|
899 |
|
|
900 |
$self->diag_fail("Finding $module on cpanmetadb failed."); |
|
901 |
return; |
|
902 |
} |
|
903 |
|
|
904 |
sub search_module { |
|
905 |
my($self, $module, $version) = @_; |
|
906 |
|
|
907 |
if ($self->{mirror_index}) { |
|
908 |
$self->chat("Searching $module on mirror index $self->{mirror_index} ...\n"); |
|
909 |
my $pkg = $self->search_mirror_index_file($self->{mirror_index}, $module, $version); |
|
910 |
return $pkg if $pkg; |
|
911 |
|
|
912 |
unless ($self->{cascade_search}) { |
|
913 |
$self->diag_fail("Finding $module ($version) on mirror index $self->{mirror_index} failed."); |
|
914 |
return; |
|
915 |
} |
|
916 |
} |
|
917 |
|
|
918 |
unless ($self->{mirror_only}) { |
|
919 |
my $found = $self->search_database($module, $version); |
|
920 |
return $found if $found; |
|
921 |
} |
|
922 |
|
|
923 |
MIRROR: for my $mirror (@{ $self->{mirrors} }) { |
|
924 |
$self->chat("Searching $module on mirror $mirror ...\n"); |
|
925 |
my $name = '02packages.details.txt.gz'; |
|
926 |
my $uri = "$mirror/modules/$name"; |
|
927 |
my $gz_file = $self->package_index_for($mirror) . '.gz'; |
|
928 |
|
|
929 |
unless ($self->{pkgs}{$uri}) { |
|
930 |
$self->chat("Downloading index file $uri ...\n"); |
|
931 |
$self->mirror($uri, $gz_file); |
|
932 |
$self->generate_mirror_index($mirror) or next MIRROR; |
|
933 |
$self->{pkgs}{$uri} = "!!retrieved!!"; |
|
934 |
} |
|
935 |
|
|
936 |
my $pkg = $self->search_mirror_index($mirror, $module, $version); |
|
937 |
return $pkg if $pkg; |
|
938 |
|
|
939 |
$self->diag_fail("Finding $module ($version) on mirror $mirror failed."); |
|
940 |
} |
|
941 |
|
|
942 |
return; |
|
943 |
} |
|
944 |
|
|
945 |
sub source_for { |
|
946 |
my($self, $mirror) = @_; |
|
947 |
$mirror =~ s/[^\w\.\-]+/%/g; |
|
948 |
|
|
949 |
my $dir = "$self->{home}/sources/$mirror"; |
|
950 |
File::Path::mkpath([ $dir ], 0, 0777); |
|
951 |
|
|
952 |
return $dir; |
|
953 |
} |
|
954 |
|
|
955 |
sub load_argv_from_fh { |
|
956 |
my($self, $fh) = @_; |
|
957 |
|
|
958 |
my @argv; |
|
959 |
while(defined(my $line = <$fh>)){ |
|
960 |
chomp $line; |
|
961 |
$line =~ s/#.+$//; # comment |
|
962 |
$line =~ s/^\s+//; # trim spaces |
|
963 |
$line =~ s/\s+$//; # trim spaces |
|
964 |
|
|
965 |
push @argv, split ' ', $line if $line; |
|
966 |
} |
|
967 |
return @argv; |
|
968 |
} |
|
969 |
|
|
970 |
sub show_version { |
|
971 |
print "cpanm (App::cpanminus) version $VERSION\n"; |
|
972 |
return 1; |
|
973 |
} |
|
974 |
|
|
975 |
sub show_help { |
|
976 |
my $self = shift; |
|
977 |
|
|
978 |
if ($_[0]) { |
|
979 |
die <<USAGE; |
|
980 |
Usage: cpanm [options] Module [...] |
|
981 |
|
|
982 |
Try `cpanm --help` or `man cpanm` for more options. |
|
983 |
USAGE |
|
984 |
} |
|
985 |
|
|
986 |
print <<HELP; |
|
987 |
Usage: cpanm [options] Module [...] |
|
988 |
|
|
989 |
Options: |
|
990 |
-v,--verbose Turns on chatty output |
|
991 |
-q,--quiet Turns off the most output |
|
992 |
--interactive Turns on interactive configure (required for Task:: modules) |
|
993 |
-f,--force force install |
|
994 |
-n,--notest Do not run unit tests |
|
995 |
--test-only Run tests only, do not install |
|
996 |
-S,--sudo sudo to run install commands |
|
997 |
--installdeps Only install dependencies |
|
998 |
--showdeps Only display direct dependencies |
|
999 |
--reinstall Reinstall the distribution even if you already have the latest version installed |
|
1000 |
--mirror Specify the base URL for the mirror (e.g. http://cpan.cpantesters.org/) |
|
1001 |
--mirror-only Use the mirror's index file instead of the CPAN Meta DB |
|
1002 |
--prompt Prompt when configure/build/test fails |
|
1003 |
-l,--local-lib Specify the install base to install modules |
|
1004 |
-L,--local-lib-contained Specify the install base to install all non-core modules |
|
1005 |
--auto-cleanup Number of days that cpanm's work directories expire in. Defaults to 7 |
|
1006 |
|
|
1007 |
Commands: |
|
1008 |
--self-upgrade upgrades itself |
|
1009 |
--info Displays distribution info on CPAN |
|
1010 |
--look Opens the distribution with your SHELL |
|
1011 |
-V,--version Displays software version |
|
1012 |
|
|
1013 |
Examples: |
|
1014 |
|
|
1015 |
cpanm Test::More # install Test::More |
|
1016 |
cpanm MIYAGAWA/Plack-0.99_05.tar.gz # full distribution path |
|
1017 |
cpanm http://example.org/LDS/CGI.pm-3.20.tar.gz # install from URL |
|
1018 |
cpanm ~/dists/MyCompany-Enterprise-1.00.tar.gz # install from a local file |
|
1019 |
cpanm --interactive Task::Kensho # Configure interactively |
|
1020 |
cpanm . # install from local directory |
|
1021 |
cpanm --installdeps . # install all the deps for the current directory |
|
1022 |
cpanm -L extlib Plack # install Plack and all non-core deps into extlib |
|
1023 |
cpanm --mirror http://cpan.cpantesters.org/ DBI # use the fast-syncing mirror |
|
1024 |
|
|
1025 |
You can also specify the default options in PERL_CPANM_OPT environment variable in the shell rc: |
|
1026 |
|
|
1027 |
export PERL_CPANM_OPT="--prompt --reinstall -l ~/perl --mirror http://cpan.cpantesters.org" |
|
1028 |
|
|
1029 |
Type `man cpanm` or `perldoc cpanm` for the more detailed explanation of the options. |
|
1030 |
|
|
1031 |
HELP |
|
1032 |
|
|
1033 |
return 1; |
|
1034 |
} |
|
1035 |
|
|
1036 |
sub _writable { |
|
1037 |
my $dir = shift; |
|
1038 |
my @dir = File::Spec->splitdir($dir); |
|
1039 |
while (@dir) { |
|
1040 |
$dir = File::Spec->catdir(@dir); |
|
1041 |
if (-e $dir) { |
|
1042 |
return -w _; |
|
1043 |
} |
|
1044 |
pop @dir; |
|
1045 |
} |
|
1046 |
|
|
1047 |
return; |
|
1048 |
} |
|
1049 |
|
|
1050 |
sub maybe_abs { |
|
1051 |
my($self, $lib) = @_; |
|
1052 |
if ($lib eq '_' or $lib =~ /^~/ or File::Spec->file_name_is_absolute($lib)) { |
|
1053 |
return $lib; |
|
1054 |
} else { |
|
1055 |
return File::Spec->canonpath(File::Spec->catdir(Cwd::cwd(), $lib)); |
|
1056 |
} |
|
1057 |
} |
|
1058 |
|
|
1059 |
sub bootstrap_local_lib { |
|
1060 |
my $self = shift; |
|
1061 |
|
|
1062 |
# If -l is specified, use that. |
|
1063 |
if ($self->{local_lib}) { |
|
1064 |
return $self->setup_local_lib($self->{local_lib}); |
|
1065 |
} |
|
1066 |
|
|
1067 |
# root, locally-installed perl or --sudo: don't care about install_base |
|
1068 |
return if $self->{sudo} or (_writable($Config{installsitelib}) and _writable($Config{installsitebin})); |
|
1069 |
|
|
1070 |
# local::lib is configured in the shell -- yay |
|
1071 |
if ($ENV{PERL_MM_OPT} and ($ENV{MODULEBUILDRC} or $ENV{PERL_MB_OPT})) { |
|
1072 |
$self->bootstrap_local_lib_deps; |
|
1073 |
return; |
|
1074 |
} |
|
1075 |
|
|
1076 |
$self->setup_local_lib; |
|
1077 |
|
|
1078 |
$self->diag(<<DIAG); |
|
1079 |
! |
|
1080 |
! Can't write to $Config{installsitelib} and $Config{installsitebin}: Installing modules to $ENV{HOME}/perl5 |
|
1081 |
! To turn off this warning, you have to do one of the following: |
|
1082 |
! - run me as a root or with --sudo option (to install to $Config{installsitelib} and $Config{installsitebin}) |
|
1083 |
! - Configure local::lib your existing local::lib in this shell to set PERL_MM_OPT etc. |
|
1084 |
! - Install local::lib by running the following commands |
|
1085 |
! |
|
1086 |
! cpanm --local-lib=~/perl5 local::lib && eval \$(perl -I ~/perl5/lib/perl5/ -Mlocal::lib) |
|
1087 |
! |
|
1088 |
DIAG |
|
1089 |
sleep 2; |
|
1090 |
} |
|
1091 |
|
|
1092 |
sub _core_only_inc { |
|
1093 |
my($self, $base) = @_; |
|
1094 |
require local::lib; |
|
1095 |
( |
|
1096 |
local::lib->resolve_path(local::lib->install_base_perl_path($base)), |
|
1097 |
local::lib->resolve_path(local::lib->install_base_arch_path($base)), |
|
1098 |
@Config{qw(privlibexp archlibexp)}, |
|
1099 |
); |
|
1100 |
} |
|
1101 |
|
|
1102 |
sub _diff { |
|
1103 |
my($self, $old, $new) = @_; |
|
1104 |
|
|
1105 |
my @diff; |
|
1106 |
my %old = map { $_ => 1 } @$old; |
|
1107 |
for my $n (@$new) { |
|
1108 |
push @diff, $n unless exists $old{$n}; |
|
1109 |
} |
|
1110 |
|
|
1111 |
@diff; |
|
1112 |
} |
|
1113 |
|
|
1114 |
sub _setup_local_lib_env { |
|
1115 |
my($self, $base) = @_; |
|
1116 |
local $SIG{__WARN__} = sub { }; # catch 'Attempting to write ...' |
|
1117 |
local::lib->setup_env_hash_for($base); |
|
1118 |
} |
|
1119 |
|
|
1120 |
sub setup_local_lib { |
|
1121 |
my($self, $base) = @_; |
|
1122 |
$base = undef if $base eq '_'; |
|
1123 |
|
|
1124 |
require local::lib; |
|
1125 |
{ |
|
1126 |
local $0 = 'cpanm'; # so curl/wget | perl works |
|
1127 |
$base ||= "~/perl5"; |
|
1128 |
if ($self->{self_contained}) { |
|
1129 |
my @inc = $self->_core_only_inc($base); |
|
1130 |
$self->{search_inc} = [ @inc ]; |
|
1131 |
} else { |
|
1132 |
$self->{search_inc} = [ |
|
1133 |
local::lib->resolve_path(local::lib->install_base_arch_path($base)), |
|
1134 |
local::lib->resolve_path(local::lib->install_base_perl_path($base)), |
|
1135 |
@INC, |
|
1136 |
]; |
|
1137 |
} |
|
1138 |
$self->_setup_local_lib_env($base); |
|
1139 |
} |
|
1140 |
|
|
1141 |
$self->bootstrap_local_lib_deps; |
|
1142 |
} |
|
1143 |
|
|
1144 |
sub bootstrap_local_lib_deps { |
|
1145 |
my $self = shift; |
|
1146 |
push @{$self->{bootstrap_deps}}, |
|
1147 |
'ExtUtils::MakeMaker' => 6.31, |
|
1148 |
'ExtUtils::Install' => 1.46; |
|
1149 |
} |
|
1150 |
|
|
1151 |
sub prompt_bool { |
|
1152 |
my($self, $mess, $def) = @_; |
|
1153 |
|
|
1154 |
my $val = $self->prompt($mess, $def); |
|
1155 |
return lc $val eq 'y'; |
|
1156 |
} |
|
1157 |
|
|
1158 |
sub prompt { |
|
1159 |
my($self, $mess, $def) = @_; |
|
1160 |
|
|
1161 |
my $isa_tty = -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT)) ; |
|
1162 |
my $dispdef = defined $def ? "[$def] " : " "; |
|
1163 |
$def = defined $def ? $def : ""; |
|
1164 |
|
|
1165 |
if (!$self->{prompt} || (!$isa_tty && eof STDIN)) { |
|
1166 |
return $def; |
|
1167 |
} |
|
1168 |
|
|
1169 |
local $|=1; |
|
1170 |
local $\; |
|
1171 |
my $ans; |
|
1172 |
eval { |
|
1173 |
local $SIG{ALRM} = sub { undef $ans; die "alarm\n" }; |
|
1174 |
print STDOUT "$mess $dispdef"; |
|
1175 |
alarm $self->{prompt_timeout} if $self->{prompt_timeout}; |
|
1176 |
$ans = <STDIN>; |
|
1177 |
alarm 0; |
|
1178 |
}; |
|
1179 |
if ( defined $ans ) { |
|
1180 |
chomp $ans; |
|
1181 |
} else { # user hit ctrl-D or alarm timeout |
|
1182 |
print STDOUT "\n"; |
|
1183 |
} |
|
1184 |
|
|
1185 |
return (!defined $ans || $ans eq '') ? $def : $ans; |
|
1186 |
} |
|
1187 |
|
|
1188 |
sub diag_ok { |
|
1189 |
my($self, $msg) = @_; |
|
1190 |
chomp $msg; |
|
1191 |
$msg ||= "OK"; |
|
1192 |
if ($self->{in_progress}) { |
|
1193 |
$self->_diag("$msg\n"); |
|
1194 |
$self->{in_progress} = 0; |
|
1195 |
} |
|
1196 |
$self->log("-> $msg\n"); |
|
1197 |
} |
|
1198 |
|
|
1199 |
sub diag_fail { |
|
1200 |
my($self, $msg, $always) = @_; |
|
1201 |
chomp $msg; |
|
1202 |
if ($self->{in_progress}) { |
|
1203 |
$self->_diag("FAIL\n"); |
|
1204 |
$self->{in_progress} = 0; |
|
1205 |
} |
|
1206 |
|
|
1207 |
if ($msg) { |
|
1208 |
$self->_diag("! $msg\n", $always); |
|
1209 |
$self->log("-> FAIL $msg\n"); |
|
1210 |
} |
|
1211 |
} |
|
1212 |
|
|
1213 |
sub diag_progress { |
|
1214 |
my($self, $msg) = @_; |
|
1215 |
chomp $msg; |
|
1216 |
$self->{in_progress} = 1; |
|
1217 |
$self->_diag("$msg ... "); |
|
1218 |
$self->log("$msg\n"); |
|
1219 |
} |
|
1220 |
|
|
1221 |
sub _diag { |
|
1222 |
my($self, $msg, $always) = @_; |
|
1223 |
print STDERR $msg if $always or $self->{verbose} or !$self->{quiet}; |
|
1224 |
} |
|
1225 |
|
|
1226 |
sub diag { |
|
1227 |
my($self, $msg, $always) = @_; |
|
1228 |
$self->_diag($msg, $always); |
|
1229 |
$self->log($msg); |
|
1230 |
} |
|
1231 |
|
|
1232 |
sub chat { |
|
1233 |
my $self = shift; |
|
1234 |
print STDERR @_ if $self->{verbose}; |
|
1235 |
$self->log(@_); |
|
1236 |
} |
|
1237 |
|
|
1238 |
sub log { |
|
1239 |
my $self = shift; |
|
1240 |
open my $out, ">>$self->{log}"; |
|
1241 |
print $out @_; |
|
1242 |
} |
|
1243 |
|
|
1244 |
sub run { |
|
1245 |
my($self, $cmd) = @_; |
|
1246 |
|
|
1247 |
if (WIN32 && ref $cmd eq 'ARRAY') { |
|
1248 |
$cmd = join q{ }, map { $self->shell_quote($_) } @$cmd; |
|
1249 |
} |
|
1250 |
|
|
1251 |
if (ref $cmd eq 'ARRAY') { |
|
1252 |
my $pid = fork; |
|
1253 |
if ($pid) { |
|
1254 |
waitpid $pid, 0; |
|
1255 |
return !$?; |
|
1256 |
} else { |
|
1257 |
$self->run_exec($cmd); |
|
1258 |
} |
|
1259 |
} else { |
|
1260 |
unless ($self->{verbose}) { |
|
1261 |
$cmd .= " >> " . $self->shell_quote($self->{log}) . " 2>&1"; |
|
1262 |
} |
|
1263 |
!system $cmd; |
|
1264 |
} |
|
1265 |
} |
|
1266 |
|
|
1267 |
sub run_exec { |
|
1268 |
my($self, $cmd) = @_; |
|
1269 |
|
|
1270 |
if (ref $cmd eq 'ARRAY') { |
|
1271 |
unless ($self->{verbose}) { |
|
1272 |
open my $logfh, ">>", $self->{log}; |
|
1273 |
open STDERR, '>&', $logfh; |
|
1274 |
open STDOUT, '>&', $logfh; |
|
1275 |
close $logfh; |
|
1276 |
} |
|
1277 |
exec @$cmd; |
|
1278 |
} else { |
|
1279 |
unless ($self->{verbose}) { |
|
1280 |
$cmd .= " >> " . $self->shell_quote($self->{log}) . " 2>&1"; |
|
1281 |
} |
|
1282 |
exec $cmd; |
|
1283 |
} |
|
1284 |
} |
|
1285 |
|
|
1286 |
sub run_timeout { |
|
1287 |
my($self, $cmd, $timeout) = @_; |
|
1288 |
return $self->run($cmd) if WIN32 || $self->{verbose} || !$timeout; |
|
1289 |
|
|
1290 |
my $pid = fork; |
|
1291 |
if ($pid) { |
|
1292 |
eval { |
|
1293 |
local $SIG{ALRM} = sub { die "alarm\n" }; |
|
1294 |
alarm $timeout; |
|
1295 |
waitpid $pid, 0; |
|
1296 |
alarm 0; |
|
1297 |
}; |
|
1298 |
if ($@ && $@ eq "alarm\n") { |
|
1299 |
$self->diag_fail("Timed out (> ${timeout}s). Use --verbose to retry."); |
|
1300 |
local $SIG{TERM} = 'IGNORE'; |
|
1301 |
kill TERM => 0; |
|
1302 |
waitpid $pid, 0; |
|
1303 |
return; |
|
1304 |
} |
|
1305 |
return !$?; |
|
1306 |
} elsif ($pid == 0) { |
|
1307 |
$self->run_exec($cmd); |
|
1308 |
} else { |
|
1309 |
$self->chat("! fork failed: falling back to system()\n"); |
|
1310 |
$self->run($cmd); |
|
1311 |
} |
|
1312 |
} |
|
1313 |
|
|
1314 |
sub configure { |
|
1315 |
my($self, $cmd) = @_; |
|
1316 |
|
|
1317 |
# trick AutoInstall |
|
1318 |
local $ENV{PERL5_CPAN_IS_RUNNING} = local $ENV{PERL5_CPANPLUS_IS_RUNNING} = $$; |
|
1319 |
|
|
1320 |
# e.g. skip CPAN configuration on local::lib |
|
1321 |
local $ENV{PERL5_CPANM_IS_RUNNING} = $$; |
|
1322 |
|
|
1323 |
my $use_default = !$self->{interactive}; |
|
1324 |
local $ENV{PERL_MM_USE_DEFAULT} = $use_default; |
|
1325 |
|
|
1326 |
# skip man page generation |
|
1327 |
local $ENV{PERL_MM_OPT} = $ENV{PERL_MM_OPT}; |
|
1328 |
unless ($self->{pod2man}) { |
|
1329 |
$ENV{PERL_MM_OPT} .= " INSTALLMAN1DIR=none INSTALLMAN3DIR=none"; |
|
1330 |
} |
|
1331 |
|
|
1332 |
local $self->{verbose} = $self->{verbose} || $self->{interactive}; |
|
1333 |
$self->run_timeout($cmd, $self->{configure_timeout}); |
|
1334 |
} |
|
1335 |
|
|
1336 |
sub build { |
|
1337 |
my($self, $cmd, $distname) = @_; |
|
1338 |
|
|
1339 |
return 1 if $self->run_timeout($cmd, $self->{build_timeout}); |
|
1340 |
while (1) { |
|
1341 |
my $ans = lc $self->prompt("Building $distname failed.\nYou can s)kip, r)etry, e)xamine build log, or l)ook ?", "s"); |
|
1342 |
return if $ans eq 's'; |
|
1343 |
return $self->build($cmd, $distname) if $ans eq 'r'; |
|
1344 |
$self->show_build_log if $ans eq 'e'; |
|
1345 |
$self->look if $ans eq 'l'; |
|
1346 |
} |
|
1347 |
} |
|
1348 |
|
|
1349 |
sub test { |
|
1350 |
my($self, $cmd, $distname) = @_; |
|
1351 |
return 1 if $self->{notest}; |
|
1352 |
|
|
1353 |
# https://rt.cpan.org/Ticket/Display.html?id=48965#txn-1013385 |
|
1354 |
local $ENV{PERL_MM_USE_DEFAULT} = 1; |
|
1355 |
|
|
1356 |
return 1 if $self->run_timeout($cmd, $self->{test_timeout}); |
|
1357 |
if ($self->{force}) { |
|
1358 |
$self->diag_fail("Testing $distname failed but installing it anyway."); |
|
1359 |
return 1; |
|
1360 |
} else { |
|
1361 |
$self->diag_fail; |
|
1362 |
while (1) { |
|
1363 |
my $ans = lc $self->prompt("Testing $distname failed.\nYou can s)kip, r)etry, f)orce install, e)xamine build log, or l)ook ?", "s"); |
|
1364 |
return if $ans eq 's'; |
|
1365 |
return $self->test($cmd, $distname) if $ans eq 'r'; |
|
1366 |
return 1 if $ans eq 'f'; |
|
1367 |
$self->show_build_log if $ans eq 'e'; |
|
1368 |
$self->look if $ans eq 'l'; |
|
1369 |
} |
|
1370 |
} |
|
1371 |
} |
|
1372 |
|
|
1373 |
sub install { |
|
1374 |
my($self, $cmd, $uninst_opts, $depth) = @_; |
|
1375 |
|
|
1376 |
if ($depth == 0 && $self->{test_only}) { |
|
1377 |
return 1; |
|
1378 |
} |
|
1379 |
|
|
1380 |
if ($self->{sudo}) { |
|
1381 |
unshift @$cmd, "sudo"; |
|
1382 |
} |
|
1383 |
|
|
1384 |
if ($self->{uninstall_shadows} && !$ENV{PERL_MM_OPT}) { |
|
1385 |
push @$cmd, @$uninst_opts; |
|
1386 |
} |
|
1387 |
|
|
1388 |
$self->run($cmd); |
|
1389 |
} |
|
1390 |
|
|
1391 |
sub look { |
|
1392 |
my $self = shift; |
|
1393 |
|
|
1394 |
my $shell = $ENV{SHELL}; |
|
1395 |
$shell ||= $ENV{COMSPEC} if WIN32; |
|
1396 |
if ($shell) { |
|
1397 |
my $cwd = Cwd::cwd; |
|
1398 |
$self->diag("Entering $cwd with $shell\n"); |
|
1399 |
system $shell; |
|
1400 |
} else { |
|
1401 |
$self->diag_fail("You don't seem to have a SHELL :/"); |
|
1402 |
} |
|
1403 |
} |
|
1404 |
|
|
1405 |
sub show_build_log { |
|
1406 |
my $self = shift; |
|
1407 |
|
|
1408 |
my @pagers = ( |
|
1409 |
$ENV{PAGER}, |
|
1410 |
(WIN32 ? () : ('less')), |
|
1411 |
'more' |
|
1412 |
); |
|
1413 |
my $pager; |
|
1414 |
while (@pagers) { |
|
1415 |
$pager = shift @pagers; |
|
1416 |
next unless $pager; |
|
1417 |
$pager = $self->which($pager); |
|
1418 |
next unless $pager; |
|
1419 |
last; |
|
1420 |
} |
|
1421 |
|
|
1422 |
if ($pager) { |
|
1423 |
# win32 'more' doesn't allow "more build.log", the < is required |
|
1424 |
system("$pager < $self->{log}"); |
|
1425 |
} |
|
1426 |
else { |
|
1427 |
$self->diag_fail("You don't seem to have a PAGER :/"); |
|
1428 |
} |
|
1429 |
} |
|
1430 |
|
|
1431 |
sub chdir { |
|
1432 |
my $self = shift; |
|
1433 |
Cwd::chdir(File::Spec->canonpath($_[0])) or die "$_[0]: $!"; |
|
1434 |
} |
|
1435 |
|
|
1436 |
sub configure_mirrors { |
|
1437 |
my $self = shift; |
|
1438 |
unless (@{$self->{mirrors}}) { |
|
1439 |
$self->{mirrors} = [ 'http://www.cpan.org' ]; |
|
1440 |
} |
|
1441 |
for (@{$self->{mirrors}}) { |
|
1442 |
s!^/!file:///!; |
|
1443 |
s!/$!!; |
|
1444 |
} |
|
1445 |
} |
|
1446 |
|
|
1447 |
sub self_upgrade { |
|
1448 |
my $self = shift; |
|
1449 |
$self->{argv} = [ 'App::cpanminus' ]; |
|
1450 |
return; # continue |
|
1451 |
} |
|
1452 |
|
|
1453 |
sub install_module { |
|
1454 |
my($self, $module, $depth, $version) = @_; |
|
1455 |
|
|
1456 |
if ($self->{seen}{$module}++) { |
|
1457 |
$self->chat("Already tried $module. Skipping.\n"); |
|
1458 |
return 1; |
|
1459 |
} |
|
1460 |
|
|
1461 |
my $dist = $self->resolve_name($module, $version); |
|
1462 |
unless ($dist) { |
|
1463 |
$self->diag_fail("Couldn't find module or a distribution $module ($version)", 1); |
|
1464 |
return; |
|
1465 |
} |
|
1466 |
|
|
1467 |
if ($dist->{distvname} && $self->{seen}{$dist->{distvname}}++) { |
|
1468 |
$self->chat("Already tried $dist->{distvname}. Skipping.\n"); |
|
1469 |
return 1; |
|
1470 |
} |
|
1471 |
|
|
1472 |
if ($self->{cmd} eq 'info') { |
|
1473 |
print $self->format_dist($dist), "\n"; |
|
1474 |
return 1; |
|
1475 |
} |
|
1476 |
|
|
1477 |
$self->check_libs; |
|
1478 |
$self->setup_module_build_patch unless $self->{pod2man}; |
|
1479 |
|
|
1480 |
if ($dist->{module}) { |
|
1481 |
unless ($self->with_version_range($version)) { |
|
1482 |
my($ok, $local) = $self->check_module($dist->{module}, $dist->{module_version} || 0); |
|
1483 |
if ($self->{skip_installed} && $ok) { |
|
1484 |
$self->diag("$dist->{module} is up to date. ($local)\n", 1); |
|
1485 |
return 1; |
|
1486 |
} |
|
1487 |
} |
|
1488 |
|
|
1489 |
unless ($self->satisfy_version($dist->{module}, $dist->{module_version}, $version)) { |
|
1490 |
$self->diag("Found $dist->{module} $dist->{module_version} which doesn't satisfy $version.\n"); |
|
1491 |
return; |
|
1492 |
} |
|
1493 |
} |
|
1494 |
|
|
1495 |
if ($dist->{dist} eq 'perl'){ |
|
1496 |
$self->diag("skipping $dist->{pathname}\n"); |
|
1497 |
return 1; |
|
1498 |
} |
|
1499 |
|
|
1500 |
$self->diag("--> Working on $module\n"); |
|
1501 |
|
|
1502 |
$dist->{dir} ||= $self->fetch_module($dist); |
|
1503 |
|
|
1504 |
unless ($dist->{dir}) { |
|
1505 |
$self->diag_fail("Failed to fetch distribution $dist->{distvname}", 1); |
|
1506 |
return; |
|
1507 |
} |
|
1508 |
|
|
1509 |
$self->chat("Entering $dist->{dir}\n"); |
|
1510 |
$self->chdir($self->{base}); |
|
1511 |
$self->chdir($dist->{dir}); |
|
1512 |
|
|
1513 |
if ($self->{cmd} eq 'look') { |
|
1514 |
$self->look; |
|
1515 |
return 1; |
|
1516 |
} |
|
1517 |
|
|
1518 |
return $self->build_stuff($module, $dist, $depth); |
|
1519 |
} |
|
1520 |
|
|
1521 |
sub format_dist { |
|
1522 |
my($self, $dist) = @_; |
|
1523 |
|
|
1524 |
# TODO support --dist-format? |
|
1525 |
return "$dist->{cpanid}/$dist->{filename}"; |
|
1526 |
} |
|
1527 |
|
|
1528 |
sub fetch_module { |
|
1529 |
my($self, $dist) = @_; |
|
1530 |
|
|
1531 |
$self->chdir($self->{base}); |
|
1532 |
|
|
1533 |
for my $uri (@{$dist->{uris}}) { |
|
1534 |
$self->diag_progress("Fetching $uri"); |
|
1535 |
|
|
1536 |
# Ugh, $dist->{filename} can contain sub directory |
|
1537 |
my $filename = $dist->{filename} || $uri; |
|
1538 |
my $name = File::Basename::basename($filename); |
|
1539 |
|
|
1540 |
my $cancelled; |
|
1541 |
my $fetch = sub { |
|
1542 |
my $file; |
|
1543 |
eval { |
|
1544 |
local $SIG{INT} = sub { $cancelled = 1; die "SIGINT\n" }; |
|
1545 |
$self->mirror($uri, $name); |
|
1546 |
$file = $name if -e $name; |
|
1547 |
}; |
|
1548 |
$self->chat("$@") if $@ && $@ ne "SIGINT\n"; |
|
1549 |
return $file; |
|
1550 |
}; |
|
1551 |
|
|
1552 |
my($try, $file); |
|
1553 |
while ($try++ < 3) { |
|
1554 |
$file = $fetch->(); |
|
1555 |
last if $cancelled or $file; |
|
1556 |
$self->diag_fail("Download $uri failed. Retrying ... "); |
|
1557 |
} |
|
1558 |
|
|
1559 |
if ($cancelled) { |
|
1560 |
$self->diag_fail("Download cancelled."); |
|
1561 |
return; |
|
1562 |
} |
|
1563 |
|
|
1564 |
unless ($file) { |
|
1565 |
$self->diag_fail("Failed to download $uri"); |
|
1566 |
next; |
|
1567 |
} |
|
1568 |
|
|
1569 |
$self->diag_ok; |
|
1570 |
$dist->{local_path} = File::Spec->rel2abs($name); |
|
1571 |
|
|
1572 |
my $dir = $self->unpack($file, $uri, $dist); |
|
1573 |
next unless $dir; # unpack failed |
|
1574 |
|
|
1575 |
if (my $save = $self->{save_dists}) { |
|
1576 |
my $path = "$save/authors/id/$dist->{pathname}"; |
|
1577 |
$self->chat("Copying $name to $path\n"); |
|
1578 |
File::Path::mkpath([ File::Basename::dirname($path) ], 0, 0777); |
|
1579 |
File::Copy::copy($file, $path) or warn $!; |
|
1580 |
} |
|
1581 |
|
|
1582 |
return $dist, $dir; |
|
1583 |
} |
|
1584 |
} |
|
1585 |
|
|
1586 |
sub unpack { |
|
1587 |
my($self, $file, $uri, $dist) = @_; |
|
1588 |
|
|
1589 |
if ($self->{verify}) { |
|
1590 |
$self->verify_archive($file, $uri, $dist) or return; |
|
1591 |
} |
|
1592 |
|
|
1593 |
$self->chat("Unpacking $file\n"); |
|
1594 |
my $dir = $file =~ /\.zip/i ? $self->unzip($file) : $self->untar($file); |
|
1595 |
unless ($dir) { |
|
1596 |
$self->diag_fail("Failed to unpack $file: no directory"); |
|
1597 |
} |
|
1598 |
return $dir; |
|
1599 |
} |
|
1600 |
|
|
1601 |
sub verify_checksums_signature { |
|
1602 |
my($self, $chk_file) = @_; |
|
1603 |
|
|
1604 |
require Module::Signature; # no fatpack |
|
1605 |
|
|
1606 |
$self->chat("Verifying the signature of CHECKSUMS\n"); |
|
1607 |
|
|
1608 |
my $rv = eval { |
|
1609 |
local $SIG{__WARN__} = sub {}; # suppress warnings |
|
1610 |
my $v = Module::Signature::_verify($chk_file); |
|
1611 |
$v == Module::Signature::SIGNATURE_OK(); |
|
1612 |
}; |
|
1613 |
if ($rv) { |
|
1614 |
$self->chat("Verified OK!\n"); |
|
1615 |
} else { |
|
1616 |
$self->diag_fail("Verifying CHECKSUMS signature failed: $rv\n"); |
|
1617 |
return; |
|
1618 |
} |
|
1619 |
|
|
1620 |
return 1; |
|
1621 |
} |
|
1622 |
|
|
1623 |
sub verify_archive { |
|
1624 |
my($self, $file, $uri, $dist) = @_; |
|
1625 |
|
|
1626 |
unless ($dist->{cpanid}) { |
|
1627 |
$self->chat("Archive '$file' does not seem to be from PAUSE. Skip verification.\n"); |
|
1628 |
} |
|
1629 |
|
|
1630 |
(my $mirror = $uri) =~ s!/authors/id.*$!!; |
|
1631 |
|
|
1632 |
(my $chksum_uri = $uri) =~ s!/[^/]*$!/CHECKSUMS!; |
|
1633 |
my $chk_file = $self->source_for($mirror) . "/$dist->{cpanid}.CHECKSUMS"; |
|
1634 |
$self->diag_progress("Fetching $chksum_uri"); |
|
1635 |
$self->mirror($chksum_uri, $chk_file); |
|
1636 |
|
|
1637 |
unless (-e $chk_file) { |
|
1638 |
$self->diag_fail("Fetching $chksum_uri failed.\n"); |
|
1639 |
return; |
|
1640 |
} |
|
1641 |
|
|
1642 |
$self->diag_ok; |
|
1643 |
$self->verify_checksums_signature($chk_file) or return; |
|
1644 |
$self->verify_checksum($file, $chk_file); |
|
1645 |
} |
|
1646 |
|
|
1647 |
sub verify_checksum { |
|
1648 |
my($self, $file, $chk_file) = @_; |
|
1649 |
|
|
1650 |
$self->chat("Verifying the SHA1 for $file\n"); |
|
1651 |
|
|
1652 |
open my $fh, "<$chk_file" or die "$chk_file: $!"; |
|
1653 |
my $data = join '', <$fh>; |
|
1654 |
$data =~ s/\015?\012/\n/g; |
|
1655 |
|
|
1656 |
require Safe; # no fatpack |
|
1657 |
my $chksum = Safe->new->reval($data); |
|
1658 |
|
|
1659 |
if (!ref $chksum or ref $chksum ne 'HASH') { |
|
1660 |
$self->diag_fail("! Checksum file downloaded from $chk_file is broken.\n"); |
|
1661 |
return; |
|
1662 |
} |
|
1663 |
|
|
1664 |
if (my $sha = $chksum->{$file}{sha256}) { |
|
1665 |
my $hex = $self->sha1_for($file); |
|
1666 |
if ($hex eq $sha) { |
|
1667 |
$self->chat("Checksum for $file: Verified!\n"); |
|
1668 |
} else { |
|
1669 |
$self->diag_fail("Checksum mismatch for $file\n"); |
|
1670 |
return; |
|
1671 |
} |
|
1672 |
} else { |
|
1673 |
$self->chat("Checksum for $file not found in CHECKSUMS.\n"); |
|
1674 |
return; |
|
1675 |
} |
|
1676 |
} |
|
1677 |
|
|
1678 |
sub sha1_for { |
|
1679 |
my($self, $file) = @_; |
|
1680 |
|
|
1681 |
require Digest::SHA; # no fatpack |
|
1682 |
|
|
1683 |
open my $fh, "<", $file or die "$file: $!"; |
|
1684 |
my $dg = Digest::SHA->new(256); |
|
1685 |
my($data); |
|
1686 |
while (read($fh, $data, 4096)) { |
|
1687 |
$dg->add($data); |
|
1688 |
} |
|
1689 |
|
|
1690 |
return $dg->hexdigest; |
|
1691 |
} |
|
1692 |
|
|
1693 |
sub verify_signature { |
|
1694 |
my($self, $dist) = @_; |
|
1695 |
|
|
1696 |
$self->diag_progress("Verifying the SIGNATURE file"); |
|
1697 |
my $out = `$self->{cpansign} -v --skip 2>&1`; |
|
1698 |
$self->log($out); |
|
1699 |
|
|
1700 |
if ($out =~ /Signature verified OK/) { |
|
1701 |
$self->diag_ok("Verified OK"); |
|
1702 |
return 1; |
|
1703 |
} else { |
|
1704 |
$self->diag_fail("SIGNATURE verificaion for $dist->{filename} failed\n"); |
|
1705 |
return; |
|
1706 |
} |
|
1707 |
} |
|
1708 |
|
|
1709 |
sub resolve_name { |
|
1710 |
my($self, $module, $version) = @_; |
|
1711 |
|
|
1712 |
# URL |
|
1713 |
if ($module =~ /^(ftp|https?|file):/) { |
|
1714 |
if ($module =~ m!authors/id/(.*)!) { |
|
1715 |
return $self->cpan_dist($1, $module); |
|
1716 |
} else { |
|
1717 |
return { uris => [ $module ] }; |
|
1718 |
} |
|
1719 |
} |
|
1720 |
|
|
1721 |
# Directory |
|
1722 |
if ($module =~ m!^[\./]! && -d $module) { |
|
1723 |
return { |
|
1724 |
source => 'local', |
|
1725 |
dir => Cwd::abs_path($module), |
|
1726 |
}; |
|
1727 |
} |
|
1728 |
|
|
1729 |
# File |
|
1730 |
if (-f $module) { |
|
1731 |
return { |
|
1732 |
source => 'local', |
|
1733 |
uris => [ "file://" . Cwd::abs_path($module) ], |
|
1734 |
}; |
|
1735 |
} |
|
1736 |
|
|
1737 |
# Git |
|
1738 |
if ($module =~ /(^git:|\.git$)/) { |
|
1739 |
return $self->git_uri($module); |
|
1740 |
} |
|
1741 |
|
|
1742 |
# cpan URI |
|
1743 |
if ($module =~ s!^cpan:///distfile/!!) { |
|
1744 |
return $self->cpan_dist($module); |
|
1745 |
} |
|
1746 |
|
|
1747 |
# PAUSEID/foo |
|
1748 |
if ($module =~ m!([A-Z]{3,})/!) { |
|
1749 |
return $self->cpan_dist($module); |
|
1750 |
} |
|
1751 |
|
|
1752 |
# Module name |
|
1753 |
return $self->search_module($module, $version); |
|
1754 |
} |
|
1755 |
|
|
1756 |
sub cpan_module { |
|
1757 |
my($self, $module, $dist, $version) = @_; |
|
1758 |
|
|
1759 |
my $dist = $self->cpan_dist($dist); |
|
1760 |
$dist->{module} = $module; |
|
1761 |
$dist->{module_version} = $version if $version && $version ne 'undef'; |
|
1762 |
|
|
1763 |
return $dist; |
|
1764 |
} |
|
1765 |
|
|
1766 |
sub cpan_dist { |
|
1767 |
my($self, $dist, $url) = @_; |
|
1768 |
|
|
1769 |
$dist =~ s!^([A-Z]{3})!substr($1,0,1)."/".substr($1,0,2)."/".$1!e; |
|
1770 |
|
|
1771 |
require CPAN::DistnameInfo; |
|
1772 |
my $d = CPAN::DistnameInfo->new($dist); |
|
1773 |
|
|
1774 |
if ($url) { |
|
1775 |
$url = [ $url ] unless ref $url eq 'ARRAY'; |
|
1776 |
} else { |
|
1777 |
my $id = $d->cpanid; |
|
1778 |
my $fn = substr($id, 0, 1) . "/" . substr($id, 0, 2) . "/" . $id . "/" . $d->filename; |
|
1779 |
|
|
1780 |
my @mirrors = @{$self->{mirrors}}; |
|
1781 |
my @urls = map "$_/authors/id/$fn", @mirrors; |
|
1782 |
|
|
1783 |
$url = \@urls, |
|
1784 |
} |
|
1785 |
|
|
1786 |
return { |
|
1787 |
$d->properties, |
|
1788 |
source => 'cpan', |
|
1789 |
uris => $url, |
|
1790 |
}; |
|
1791 |
} |
|
1792 |
|
|
1793 |
sub git_uri { |
|
1794 |
my ($self, $uri) = @_; |
|
1795 |
|
|
1796 |
# similar to http://www.pip-installer.org/en/latest/logic.html#vcs-support |
|
1797 |
# git URL has to end with .git when you need to use pin @ commit/tag/branch |
|
1798 |
|
|
1799 |
($uri, my $commitish) = split /(?<=\.git)@/i, $uri, 2; |
|
1800 |
|
|
1801 |
my $dh = File::Temp->newdir(CLEANUP => 1); |
|
1802 |
my $dir = Cwd::abs_path($dh->dirname); |
|
1803 |
|
|
1804 |
$self->diag_progress("Cloning $uri"); |
|
1805 |
$self->run([ 'git', 'clone', $uri, $dir ]); |
|
1806 |
|
|
1807 |
unless (-e "$dir/.git") { |
|
1808 |
$self->diag_fail("Failed cloning git repository $uri"); |
|
1809 |
return; |
|
1810 |
} |
|
1811 |
|
|
1812 |
if ($commitish) { |
|
1813 |
require File::pushd; |
|
1814 |
my $dir = File::pushd::pushd($dir); |
|
1815 |
|
|
1816 |
unless ($self->run([ 'git', 'checkout', $commitish ])) { |
|
1817 |
$self->diag_fail("Failed to checkout '$commitish' in git repository $uri\n"); |
|
1818 |
return; |
|
1819 |
} |
|
1820 |
} |
|
1821 |
|
|
1822 |
$self->diag_ok; |
|
1823 |
|
|
1824 |
return { |
|
1825 |
source => 'local', |
|
1826 |
dir => $dir, |
|
1827 |
handle => $dh, |
|
1828 |
}; |
|
1829 |
} |
|
1830 |
|
|
1831 |
sub setup_module_build_patch { |
|
1832 |
my $self = shift; |
|
1833 |
|
|
1834 |
open my $out, ">$self->{base}/ModuleBuildSkipMan.pm" or die $!; |
|
1835 |
print $out <<EOF; |
|
1836 |
package ModuleBuildSkipMan; |
|
1837 |
CHECK { |
|
1838 |
if (%Module::Build::) { |
|
1839 |
no warnings 'redefine'; |
|
1840 |
*Module::Build::Base::ACTION_manpages = sub {}; |
|
1841 |
*Module::Build::Base::ACTION_docs = sub {}; |
|
1842 |
} |
|
1843 |
} |
|
1844 |
1; |
|
1845 |
EOF |
|
1846 |
} |
|
1847 |
|
|
1848 |
sub check_module { |
|
1849 |
my($self, $mod, $want_ver) = @_; |
|
1850 |
|
|
1851 |
require Module::Metadata; |
|
1852 |
my $meta = Module::Metadata->new_from_module($mod, inc => $self->{search_inc}) |
|
1853 |
or return 0, undef; |
|
1854 |
|
|
1855 |
my $version = $meta->version; |
|
1856 |
|
|
1857 |
# When -L is in use, the version loaded from 'perl' library path |
|
1858 |
# might be newer than (or actually wasn't core at) the version |
|
1859 |
# that is shipped with the current perl |
|
1860 |
if ($self->{self_contained} && $self->loaded_from_perl_lib($meta)) { |
|
1861 |
require Module::CoreList; # no fatpack |
|
1862 |
unless (exists $Module::CoreList::version{$]+0}{$mod}) { |
|
1863 |
return 0, undef; |
|
1864 |
} |
|
1865 |
$version = $Module::CoreList::version{$]+0}{$mod}; |
|
1866 |
} |
|
1867 |
|
|
1868 |
$self->{local_versions}{$mod} = $version; |
|
1869 |
|
|
1870 |
if ($self->is_deprecated($meta)){ |
|
1871 |
return 0, $version; |
|
1872 |
} elsif ($self->satisfy_version($mod, $version, $want_ver)) { |
|
1873 |
return 1, ($version || 'undef'); |
|
1874 |
} else { |
|
1875 |
return 0, $version; |
|
1876 |
} |
|
1877 |
} |
|
1878 |
|
|
1879 |
sub satisfy_version { |
|
1880 |
my($self, $mod, $version, $want_ver) = @_; |
|
1881 |
|
|
1882 |
$want_ver = '0' unless defined($want_ver) && length($want_ver); |
|
1883 |
|
|
1884 |
require CPAN::Meta::Requirements; |
|
1885 |
my $requirements = CPAN::Meta::Requirements->new; |
|
1886 |
$requirements->add_string_requirement($mod, $want_ver); |
|
1887 |
$requirements->accepts_module($mod, $version); |
|
1888 |
} |
|
1889 |
|
|
1890 |
sub unsatisfy_how { |
|
1891 |
my($self, $ver, $want_ver) = @_; |
|
1892 |
|
|
1893 |
if ($want_ver =~ /^[v0-9\.\_]+$/) { |
|
1894 |
return "$ver < $want_ver"; |
|
1895 |
} else { |
|
1896 |
return "$ver doesn't satisfy $want_ver"; |
|
1897 |
} |
|
1898 |
} |
|
1899 |
|
|
1900 |
sub is_deprecated { |
|
1901 |
my($self, $meta) = @_; |
|
1902 |
|
|
1903 |
my $deprecated = eval { |
|
1904 |
require Module::CoreList; # no fatpack |
|
1905 |
Module::CoreList::is_deprecated($meta->{module}); |
|
1906 |
}; |
|
1907 |
|
|
1908 |
return $deprecated && $self->loaded_from_perl_lib($meta); |
|
1909 |
} |
|
1910 |
|
|
1911 |
sub loaded_from_perl_lib { |
|
1912 |
my($self, $meta) = @_; |
|
1913 |
|
|
1914 |
require Config; |
|
1915 |
for my $dir (qw(archlibexp privlibexp)) { |
|
1916 |
my $confdir = $Config{$dir}; |
|
1917 |
if ($confdir eq substr($meta->filename, 0, length($confdir))) { |
|
1918 |
return 1; |
|
1919 |
} |
|
1920 |
} |
|
1921 |
|
|
1922 |
return; |
|
1923 |
} |
|
1924 |
|
|
1925 |
sub should_install { |
|
1926 |
my($self, $mod, $ver) = @_; |
|
1927 |
|
|
1928 |
$self->chat("Checking if you have $mod $ver ... "); |
|
1929 |
my($ok, $local) = $self->check_module($mod, $ver); |
|
1930 |
|
|
1931 |
if ($ok) { $self->chat("Yes ($local)\n") } |
|
1932 |
elsif ($local) { $self->chat("No (" . $self->unsatisfy_how($local, $ver) . ")\n") } |
|
1933 |
else { $self->chat("No\n") } |
|
1934 |
|
|
1935 |
return $mod unless $ok; |
|
1936 |
return; |
|
1937 |
} |
|
1938 |
|
|
1939 |
sub install_deps { |
|
1940 |
my($self, $dir, $depth, @deps) = @_; |
|
1941 |
|
|
1942 |
my(@install, %seen); |
|
1943 |
while (my($mod, $ver) = splice @deps, 0, 2) { |
|
1944 |
next if $seen{$mod} or $mod eq 'perl' or $mod eq 'Config'; |
|
1945 |
if ($self->should_install($mod, $ver)) { |
|
1946 |
push @install, [ $mod, $ver ]; |
|
1947 |
$seen{$mod} = 1; |
|
1948 |
} |
|
1949 |
} |
|
1950 |
|
|
1951 |
if (@install) { |
|
1952 |
$self->diag("==> Found dependencies: " . join(", ", map $_->[0], @install) . "\n"); |
|
1953 |
} |
|
1954 |
|
|
1955 |
my @fail; |
|
1956 |
for my $mod (@install) { |
|
1957 |
$self->install_module($mod->[0], $depth + 1, $mod->[1]) |
|
1958 |
or push @fail, $mod->[0]; |
|
1959 |
} |
|
1960 |
|
|
1961 |
$self->chdir($self->{base}); |
|
1962 |
$self->chdir($dir) if $dir; |
|
1963 |
|
|
1964 |
return @fail; |
|
1965 |
} |
|
1966 |
|
|
1967 |
sub install_deps_bailout { |
|
1968 |
my($self, $target, $dir, $depth, @deps) = @_; |
|
1969 |
|
|
1970 |
my @fail = $self->install_deps($dir, $depth, @deps); |
|
1971 |
if (@fail) { |
|
1972 |
unless ($self->prompt_bool("Installing the following dependencies failed:\n==> " . |
|
1973 |
join(", ", @fail) . "\nDo you want to continue building $target anyway?", "n")) { |
|
1974 |
$self->diag_fail("Bailing out the installation for $target. Retry with --prompt or --force.", 1); |
|
1975 |
return; |
|
1976 |
} |
|
1977 |
} |
|
1978 |
|
|
1979 |
return 1; |
|
1980 |
} |
|
1981 |
|
|
1982 |
sub build_stuff { |
|
1983 |
my($self, $stuff, $dist, $depth) = @_; |
|
1984 |
|
|
1985 |
if ($self->{verify} && -e 'SIGNATURE') { |
|
1986 |
$self->verify_signature($dist) or return; |
|
1987 |
} |
|
1988 |
|
|
1989 |
my @config_deps; |
|
1990 |
if (-e 'META.json') { |
|
1991 |
$self->chat("Checking configure dependencies from META.json\n"); |
|
1992 |
$dist->{meta} = $self->parse_meta('META.json'); |
|
1993 |
} elsif (-e 'META.yml') { |
|
1994 |
$self->chat("Checking configure dependencies from META.yml\n"); |
|
1995 |
$dist->{meta} = $self->parse_meta('META.yml'); |
|
1996 |
} |
|
1997 |
|
|
1998 |
if (!$dist->{meta} && $dist->{source} eq 'cpan') { |
|
1999 |
$self->chat("META.yml/json not found or unparsable. Fetching META.yml from search.cpan.org\n"); |
|
2000 |
$dist->{meta} = $self->fetch_meta_sco($dist); |
|
2001 |
} |
|
2002 |
|
|
2003 |
$dist->{meta} ||= {}; |
|
2004 |
|
|
2005 |
if ( $dist->{meta}->{prereqs} ) { |
|
2006 |
push @config_deps, %{$dist->{meta}{prereqs}{configure}{requires} || {}}; |
|
2007 |
} |
|
2008 |
else { |
|
2009 |
push @config_deps, %{$dist->{meta}{configure_requires} || {}}; |
|
2010 |
} |
|
2011 |
|
|
2012 |
my $target = $dist->{meta}{name} ? "$dist->{meta}{name}-$dist->{meta}{version}" : $dist->{dir}; |
|
2013 |
|
|
2014 |
$self->install_deps_bailout($target, $dist->{dir}, $depth, @config_deps) |
|
2015 |
or return; |
|
2016 |
|
|
2017 |
$self->diag_progress("Configuring $target"); |
|
2018 |
|
|
2019 |
my $configure_state = $self->configure_this($dist, $depth); |
|
2020 |
|
|
2021 |
$self->diag_ok($configure_state->{configured_ok} ? "OK" : "N/A"); |
|
2022 |
|
|
2023 |
my @deps = $self->find_prereqs($dist); |
|
2024 |
my $module_name = $self->find_module_name($configure_state) || $dist->{meta}{name}; |
|
2025 |
$module_name =~ s/-/::/g; |
|
2026 |
|
|
2027 |
if ($self->{showdeps}) { |
|
2028 |
my %rootdeps = (@config_deps, @deps); # merge |
|
2029 |
for my $mod (keys %rootdeps) { |
|
2030 |
my $ver = $rootdeps{$mod}; |
|
2031 |
print $mod, ($ver ? "~$ver" : ""), "\n"; |
|
2032 |
} |
|
2033 |
return 1; |
|
2034 |
} |
|
2035 |
|
|
2036 |
my $distname = $dist->{meta}{name} ? "$dist->{meta}{name}-$dist->{meta}{version}" : $stuff; |
|
2037 |
|
|
2038 |
my $walkup; |
|
2039 |
if ($self->{scandeps}) { |
|
2040 |
$walkup = $self->scandeps_append_child($dist); |
|
2041 |
} |
|
2042 |
|
|
2043 |
$self->install_deps_bailout($distname, $dist->{dir}, $depth, @deps) |
|
2044 |
or return; |
|
2045 |
|
|
2046 |
if ($self->{scandeps}) { |
|
2047 |
unless ($configure_state->{configured_ok}) { |
|
2048 |
my $diag = <<DIAG; |
|
2049 |
! Configuring $distname failed. See $self->{log} for details. |
|
2050 |
! You might have to install the following modules first to get --scandeps working correctly. |
|
2051 |
DIAG |
|
2052 |
if (@config_deps) { |
|
2053 |
my @tree = @{$self->{scandeps_tree}}; |
|
2054 |
$diag .= "!\n" . join("", map "! * $_->[0]{module}\n", @tree[0..$#tree-1]) if @tree; |
|
2055 |
} |
|
2056 |
$self->diag("!\n$diag!\n", 1); |
|
2057 |
} |
|
2058 |
$walkup->(); |
|
2059 |
return 1; |
|
2060 |
} |
|
2061 |
|
|
2062 |
if ($self->{installdeps} && $depth == 0) { |
|
2063 |
if ($configure_state->{configured_ok}) { |
|
2064 |
$self->diag("<== Installed dependencies for $stuff. Finishing.\n"); |
|
2065 |
return 1; |
|
2066 |
} else { |
|
2067 |
$self->diag("! Configuring $distname failed. See $self->{log} for details.\n", 1); |
|
2068 |
return; |
|
2069 |
} |
|
2070 |
} |
|
2071 |
|
|
2072 |
my $installed; |
|
2073 |
if ($configure_state->{use_module_build} && -e 'Build' && -f _) { |
|
2074 |
my @switches = $self->{pod2man} ? () : ("-I$self->{base}", "-MModuleBuildSkipMan"); |
|
2075 |
$self->diag_progress("Building " . ($self->{notest} ? "" : "and testing ") . $distname); |
|
2076 |
$self->build([ $self->{perl}, @switches, "./Build" ], $distname) && |
|
2077 |
$self->test([ $self->{perl}, "./Build", "test" ], $distname) && |
|
2078 |
$self->install([ $self->{perl}, @switches, "./Build", "install" ], [ "--uninst", 1 ], $depth) && |
|
2079 |
$installed++; |
|
2080 |
} elsif ($self->{make} && -e 'Makefile') { |
|
2081 |
$self->diag_progress("Building " . ($self->{notest} ? "" : "and testing ") . $distname); |
|
2082 |
$self->build([ $self->{make} ], $distname) && |
|
2083 |
$self->test([ $self->{make}, "test" ], $distname) && |
|
2084 |
$self->install([ $self->{make}, "install" ], [ "UNINST=1" ], $depth) && |
|
2085 |
$installed++; |
|
2086 |
} else { |
|
2087 |
my $why; |
|
2088 |
my $configure_failed = $configure_state->{configured} && !$configure_state->{configured_ok}; |
|
2089 |
if ($configure_failed) { $why = "Configure failed for $distname." } |
|
2090 |
elsif ($self->{make}) { $why = "The distribution doesn't have a proper Makefile.PL/Build.PL" } |
|
2091 |
else { $why = "Can't configure the distribution. You probably need to have 'make'." } |
|
2092 |
|
|
2093 |
$self->diag_fail("$why See $self->{log} for details.", 1); |
|
2094 |
return; |
|
2095 |
} |
|
2096 |
|
|
2097 |
if ($installed && $self->{test_only}) { |
|
2098 |
$self->diag_ok; |
|
2099 |
$self->diag("Successfully tested $distname\n", 1); |
|
2100 |
} elsif ($installed) { |
|
2101 |
my $local = $self->{local_versions}{$dist->{module} || ''}; |
|
2102 |
my $version = $dist->{module_version} || $dist->{meta}{version} || $dist->{version}; |
|
2103 |
my $reinstall = $local && ($local eq $version); |
|
2104 |
|
|
2105 |
my $how = $reinstall ? "reinstalled $distname" |
|
2106 |
: $local ? "installed $distname (upgraded from $local)" |
|
2107 |
: "installed $distname" ; |
|
2108 |
my $msg = "Successfully $how"; |
|
2109 |
$self->diag_ok; |
|
2110 |
$self->diag("$msg\n", 1); |
|
2111 |
$self->{installed_dists}++; |
|
2112 |
$self->save_meta($stuff, $dist, $module_name, \@config_deps, \@deps); |
|
2113 |
return 1; |
|
2114 |
} else { |
|
2115 |
my $what = $self->{test_only} ? "Testing" : "Installing"; |
|
2116 |
$self->diag_fail("$what $stuff failed. See $self->{log} for details.", 1); |
|
2117 |
return; |
|
2118 |
} |
|
2119 |
} |
|
2120 |
|
|
2121 |
sub configure_this { |
|
2122 |
my($self, $dist, $depth) = @_; |
|
2123 |
|
|
2124 |
if (-e 'cpanfile' && $self->{installdeps} && $depth == 0) { |
|
2125 |
require Module::CPANfile; |
|
2126 |
$dist->{cpanfile} = eval { Module::CPANfile->load('cpanfile') }; |
|
2127 |
$self->diag_fail($@, 1) if $@; |
|
2128 |
return { |
|
2129 |
configured => 1, |
|
2130 |
configured_ok => !!$dist->{cpanfile}, |
|
2131 |
use_module_build => 0, |
|
2132 |
}; |
|
2133 |
} |
|
2134 |
|
|
2135 |
if ($self->{skip_configure}) { |
|
2136 |
my $eumm = -e 'Makefile'; |
|
2137 |
my $mb = -e 'Build' && -f _; |
|
2138 |
return { |
|
2139 |
configured => 1, |
|
2140 |
configured_ok => $eumm || $mb, |
|
2141 |
use_module_build => $mb, |
|
2142 |
}; |
|
2143 |
} |
|
2144 |
|
|
2145 |
my @mb_switches; |
|
2146 |
unless ($self->{pod2man}) { |
|
2147 |
# it has to be push, so Module::Build is loaded from the adjusted path when -L is in use |
|
2148 |
push @mb_switches, ("-I$self->{base}", "-MModuleBuildSkipMan"); |
|
2149 |
} |
|
2150 |
|
|
2151 |
my $state = {}; |
|
2152 |
|
|
2153 |
my $try_eumm = sub { |
|
2154 |
if (-e 'Makefile.PL') { |
|
2155 |
$self->chat("Running Makefile.PL\n"); |
|
2156 |
|
|
2157 |
# NOTE: according to Devel::CheckLib, most XS modules exit |
|
2158 |
# with 0 even if header files are missing, to avoid receiving |
|
2159 |
# tons of FAIL reports in such cases. So exit code can't be |
|
2160 |
# trusted if it went well. |
|
2161 |
if ($self->configure([ $self->{perl}, "Makefile.PL" ])) { |
|
2162 |
$state->{configured_ok} = -e 'Makefile'; |
|
2163 |
} |
|
2164 |
$state->{configured}++; |
|
2165 |
} |
|
2166 |
}; |
|
2167 |
|
|
2168 |
my $try_mb = sub { |
|
2169 |
if (-e 'Build.PL') { |
|
2170 |
$self->chat("Running Build.PL\n"); |
|
2171 |
if ($self->configure([ $self->{perl}, @mb_switches, "Build.PL" ])) { |
|
2172 |
$state->{configured_ok} = -e 'Build' && -f _; |
|
2173 |
} |
|
2174 |
$state->{use_module_build}++; |
|
2175 |
$state->{configured}++; |
|
2176 |
} |
|
2177 |
}; |
|
2178 |
|
|
2179 |
# Module::Build deps should use MakeMaker because that causes circular deps and fail |
|
2180 |
# Otherwise we should prefer Build.PL |
|
2181 |
my %should_use_mm = map { $_ => 1 } qw( version ExtUtils-ParseXS ExtUtils-Install ExtUtils-Manifest ); |
|
2182 |
|
|
2183 |
my @try; |
|
2184 |
if ($dist->{dist} && $should_use_mm{$dist->{dist}}) { |
|
2185 |
@try = ($try_eumm, $try_mb); |
|
2186 |
} else { |
|
2187 |
@try = ($try_mb, $try_eumm); |
|
2188 |
} |
|
2189 |
|
|
2190 |
for my $try (@try) { |
|
2191 |
$try->(); |
|
2192 |
last if $state->{configured_ok}; |
|
2193 |
} |
|
2194 |
|
|
2195 |
unless ($state->{configured_ok}) { |
|
2196 |
while (1) { |
|
2197 |
my $ans = lc $self->prompt("Configuring $dist->{dist} failed.\nYou can s)kip, r)etry, e)xamine build log, or l)ook ?", "s"); |
|
2198 |
last if $ans eq 's'; |
|
2199 |
return $self->configure_this($dist, $depth) if $ans eq 'r'; |
|
2200 |
$self->show_build_log if $ans eq 'e'; |
|
2201 |
$self->look if $ans eq 'l'; |
|
2202 |
} |
|
2203 |
} |
|
2204 |
|
|
2205 |
return $state; |
|
2206 |
} |
|
2207 |
|
|
2208 |
sub find_module_name { |
|
2209 |
my($self, $state) = @_; |
|
2210 |
|
|
2211 |
return unless $state->{configured_ok}; |
|
2212 |
|
|
2213 |
if ($state->{use_module_build} && |
|
2214 |
-e "_build/build_params") { |
|
2215 |
my $params = do { open my $in, "_build/build_params"; $self->safe_eval(join "", <$in>) }; |
|
2216 |
return eval { $params->[2]{module_name} } || undef; |
|
2217 |
} elsif (-e "Makefile") { |
|
2218 |
open my $mf, "Makefile"; |
|
2219 |
while (<$mf>) { |
|
2220 |
if (/^\#\s+NAME\s+=>\s+(.*)/) { |
|
2221 |
return $self->safe_eval($1); |
|
2222 |
} |
|
2223 |
} |
|
2224 |
} |
|
2225 |
|
|
2226 |
return; |
|
2227 |
} |
|
2228 |
|
|
2229 |
sub save_meta { |
|
2230 |
my($self, $module, $dist, $module_name, $config_deps, $build_deps) = @_; |
|
2231 |
|
|
2232 |
return unless $dist->{distvname} && $dist->{source} eq 'cpan'; |
|
2233 |
|
|
2234 |
my $base = ($ENV{PERL_MM_OPT} || '') =~ /INSTALL_BASE=/ |
|
2235 |
? ($self->install_base($ENV{PERL_MM_OPT}) . "/lib/perl5") : $Config{sitelibexp}; |
|
2236 |
|
|
2237 |
my $provides = $self->_merge_hashref( |
|
2238 |
map Module::Metadata->package_versions_from_directory($_), |
|
2239 |
qw( blib/lib blib/arch ) # FCGI.pm :( |
|
2240 |
); |
|
2241 |
|
|
2242 |
File::Path::mkpath("blib/meta", 0, 0777); |
|
2243 |
|
|
2244 |
my $local = { |
|
2245 |
name => $module_name, |
|
2246 |
target => $module, |
|
2247 |
version => $provides->{$module_name}{version} || $dist->{version}, |
|
2248 |
dist => $dist->{distvname}, |
|
2249 |
pathname => $dist->{pathname}, |
|
2250 |
provides => $provides, |
|
2251 |
}; |
|
2252 |
|
|
2253 |
require JSON::PP; |
|
2254 |
open my $fh, ">", "blib/meta/install.json" or die $!; |
|
2255 |
print $fh JSON::PP::encode_json($local); |
|
2256 |
|
|
2257 |
# Existence of MYMETA.* Depends on EUMM/M::B versions and CPAN::Meta |
|
2258 |
if (-e "MYMETA.json") { |
|
2259 |
File::Copy::copy("MYMETA.json", "blib/meta/MYMETA.json"); |
|
2260 |
} |
|
2261 |
|
|
2262 |
my @cmd = ( |
|
2263 |
($self->{sudo} ? 'sudo' : ()), |
|
2264 |
$^X, |
|
2265 |
'-MExtUtils::Install=install', |
|
2266 |
'-e', |
|
2267 |
qq[install({ 'blib/meta' => '$base/$Config{archname}/.meta/$dist->{distvname}' })], |
|
2268 |
); |
|
2269 |
$self->run(\@cmd); |
|
2270 |
} |
|
2271 |
|
|
2272 |
sub _merge_hashref { |
|
2273 |
my($self, @hashrefs) = @_; |
|
2274 |
|
|
2275 |
my %hash; |
|
2276 |
for my $h (@hashrefs) { |
|
2277 |
%hash = (%hash, %$h); |
|
2278 |
} |
|
2279 |
|
|
2280 |
return \%hash; |
|
2281 |
} |
|
2282 |
|
|
2283 |
sub install_base { |
|
2284 |
my($self, $mm_opt) = @_; |
|
2285 |
$mm_opt =~ /INSTALL_BASE=(\S+)/ and return $1; |
|
2286 |
die "Your PERL_MM_OPT doesn't contain INSTALL_BASE"; |
|
2287 |
} |
|
2288 |
|
|
2289 |
sub safe_eval { |
|
2290 |
my($self, $code) = @_; |
|
2291 |
eval $code; |
|
2292 |
} |
|
2293 |
|
|
2294 |
sub find_prereqs { |
|
2295 |
my($self, $dist) = @_; |
|
2296 |
|
|
2297 |
my @deps = $self->extract_meta_prereqs($dist); |
|
2298 |
|
|
2299 |
if ($dist->{module} =~ /^Bundle::/i) { |
|
2300 |
push @deps, $self->bundle_deps($dist); |
|
2301 |
} |
|
2302 |
|
|
2303 |
return @deps; |
|
2304 |
} |
|
2305 |
|
|
2306 |
sub extract_meta_prereqs { |
|
2307 |
my($self, $dist) = @_; |
|
2308 |
|
|
2309 |
if ($dist->{cpanfile}) { |
|
2310 |
my $prereq = $dist->{cpanfile}->prereq; |
|
2311 |
my @phase = $self->{notest} ? qw( build runtime ) : qw( build test runtime ); |
|
2312 |
require CPAN::Meta::Requirements; |
|
2313 |
my $req = CPAN::Meta::Requirements->new; |
|
2314 |
$req->add_requirements($prereq->requirements_for($_, 'requires')) for @phase; |
|
2315 |
return %{$req->as_string_hash}; |
|
2316 |
} |
|
2317 |
|
|
2318 |
my $meta = $dist->{meta}; |
|
2319 |
|
|
2320 |
my @deps; |
|
2321 |
if (-e "MYMETA.json") { |
|
2322 |
require JSON::PP; |
|
2323 |
$self->chat("Checking dependencies from MYMETA.json ...\n"); |
|
2324 |
my $json = do { open my $in, "<MYMETA.json"; local $/; <$in> }; |
|
2325 |
my $mymeta = JSON::PP::decode_json($json); |
|
2326 |
if ($mymeta) { |
|
2327 |
$meta->{$_} = $mymeta->{$_} for qw(name version); |
|
2328 |
return $self->extract_requires($mymeta); |
|
2329 |
} |
|
2330 |
} |
|
2331 |
|
|
2332 |
if (-e 'MYMETA.yml') { |
|
2333 |
$self->chat("Checking dependencies from MYMETA.yml ...\n"); |
|
2334 |
my $mymeta = $self->parse_meta('MYMETA.yml'); |
|
2335 |
if ($mymeta) { |
|
2336 |
$meta->{$_} = $mymeta->{$_} for qw(name version); |
|
2337 |
return $self->extract_requires($mymeta); |
|
2338 |
} |
|
2339 |
} |
|
2340 |
|
|
2341 |
if (-e '_build/prereqs') { |
|
2342 |
$self->chat("Checking dependencies from _build/prereqs ...\n"); |
|
2343 |
my $mymeta = do { open my $in, "_build/prereqs"; $self->safe_eval(join "", <$in>) }; |
|
2344 |
@deps = $self->extract_requires($mymeta); |
|
2345 |
} elsif (-e 'Makefile') { |
|
2346 |
$self->chat("Finding PREREQ from Makefile ...\n"); |
|
2347 |
open my $mf, "Makefile"; |
|
2348 |
while (<$mf>) { |
|
2349 |
if (/^\#\s+PREREQ_PM => \{\s*(.*?)\s*\}/) { |
|
2350 |
my @all; |
|
2351 |
my @pairs = split ', ', $1; |
|
2352 |
for (@pairs) { |
|
2353 |
my ($pkg, $v) = split '=>', $_; |
|
2354 |
push @all, [ $pkg, $v ]; |
|
2355 |
} |
|
2356 |
my $list = join ", ", map { "'$_->[0]' => $_->[1]" } @all; |
|
2357 |
my $prereq = $self->safe_eval("no strict; +{ $list }"); |
|
2358 |
push @deps, %$prereq if $prereq; |
|
2359 |
last; |
|
2360 |
} |
|
2361 |
} |
|
2362 |
} |
|
2363 |
|
|
2364 |
return @deps; |
|
2365 |
} |
|
2366 |
|
|
2367 |
sub bundle_deps { |
|
2368 |
my($self, $dist) = @_; |
|
2369 |
|
|
2370 |
my @files; |
|
2371 |
File::Find::find({ |
|
2372 |
wanted => sub { push @files, File::Spec->rel2abs($_) if /\.pm/i }, |
|
2373 |
no_chdir => 1, |
|
2374 |
}, '.'); |
|
2375 |
|
|
2376 |
my @deps; |
|
2377 |
|
|
2378 |
for my $file (@files) { |
|
2379 |
open my $pod, "<", $file or next; |
|
2380 |
my $in_contents; |
|
2381 |
while (<$pod>) { |
|
2382 |
if (/^=head\d\s+CONTENTS/) { |
|
2383 |
$in_contents = 1; |
|
2384 |
} elsif (/^=/) { |
|
2385 |
$in_contents = 0; |
|
2386 |
} elsif ($in_contents) { |
|
2387 |
/^(\S+)\s*(\S+)?/ |
|
2388 |
and push @deps, $1, $self->maybe_version($2); |
|
2389 |
} |
|
2390 |
} |
|
2391 |
} |
|
2392 |
|
|
2393 |
return @deps; |
|
2394 |
} |
|
2395 |
|
|
2396 |
sub maybe_version { |
|
2397 |
my($self, $string) = @_; |
|
2398 |
return $string && $string =~ /^\.?\d/ ? $string : undef; |
|
2399 |
} |
|
2400 |
|
|
2401 |
sub extract_requires { |
|
2402 |
my($self, $meta) = @_; |
|
2403 |
|
|
2404 |
if ($meta->{'meta-spec'} && $meta->{'meta-spec'}{version} == 2) { |
|
2405 |
my @phase = $self->{notest} ? qw( build runtime ) : qw( build test runtime ); |
|
2406 |
my @deps = map { |
|
2407 |
my $p = $meta->{prereqs}{$_} || {}; |
|
2408 |
%{$p->{requires} || {}}; |
|
2409 |
} @phase; |
|
2410 |
return @deps; |
|
2411 |
} |
|
2412 |
|
|
2413 |
my @deps; |
|
2414 |
push @deps, %{$meta->{build_requires}} if $meta->{build_requires}; |
|
2415 |
push @deps, %{$meta->{requires}} if $meta->{requires}; |
|
2416 |
|
|
2417 |
return @deps; |
|
2418 |
} |
|
2419 |
|
|
2420 |
sub cleanup_workdirs { |
|
2421 |
my $self = shift; |
|
2422 |
|
|
2423 |
my $expire = time - 24 * 60 * 60 * $self->{auto_cleanup}; |
|
2424 |
my @targets; |
|
2425 |
|
|
2426 |
opendir my $dh, "$self->{home}/work"; |
|
2427 |
while (my $e = readdir $dh) { |
|
2428 |
next if $e !~ /^(\d+)\.\d+$/; # {UNIX time}.{PID} |
|
2429 |
my $time = $1; |
|
2430 |
if ($time < $expire) { |
|
2431 |
push @targets, "$self->{home}/work/$e"; |
|
2432 |
} |
|
2433 |
} |
|
2434 |
|
|
2435 |
if (@targets) { |
|
2436 |
$self->chat("Expiring ", scalar(@targets), " work directories.\n"); |
|
2437 |
File::Path::rmtree(\@targets, 0, 0); # safe = 0, since blib usually doesn't have write bits |
|
2438 |
} |
|
2439 |
} |
|
2440 |
|
|
2441 |
sub scandeps_append_child { |
|
2442 |
my($self, $dist) = @_; |
|
2443 |
|
|
2444 |
my $new_node = [ $dist, [] ]; |
|
2445 |
|
|
2446 |
my $curr_node = $self->{scandeps_current} || [ undef, $self->{scandeps_tree} ]; |
|
2447 |
push @{$curr_node->[1]}, $new_node; |
|
2448 |
|
|
2449 |
$self->{scandeps_current} = $new_node; |
|
2450 |
|
|
2451 |
return sub { $self->{scandeps_current} = $curr_node }; |
|
2452 |
} |
|
2453 |
|
|
2454 |
sub dump_scandeps { |
|
2455 |
my $self = shift; |
|
2456 |
|
|
2457 |
if ($self->{format} eq 'tree') { |
|
2458 |
$self->walk_down(sub { |
|
2459 |
my($dist, $depth) = @_; |
|
2460 |
if ($depth == 0) { |
|
2461 |
print "$dist->{distvname}\n"; |
|
2462 |
} else { |
|
2463 |
print " " x ($depth - 1); |
|
2464 |
print "\\_ $dist->{distvname}\n"; |
|
2465 |
} |
|
2466 |
}, 1); |
|
2467 |
} elsif ($self->{format} =~ /^dists?$/) { |
|
2468 |
$self->walk_down(sub { |
|
2469 |
my($dist, $depth) = @_; |
|
2470 |
print $self->format_dist($dist), "\n"; |
|
2471 |
}, 0); |
|
2472 |
} elsif ($self->{format} eq 'json') { |
|
2473 |
require JSON::PP; |
|
2474 |
print JSON::PP::encode_json($self->{scandeps_tree}); |
|
2475 |
} elsif ($self->{format} eq 'yaml') { |
|
2476 |
require YAML; # no fatpack |
|
2477 |
print YAML::Dump($self->{scandeps_tree}); |
|
2478 |
} else { |
|
2479 |
$self->diag("Unknown format: $self->{format}\n"); |
|
2480 |
} |
|
2481 |
} |
|
2482 |
|
|
2483 |
sub walk_down { |
|
2484 |
my($self, $cb, $pre) = @_; |
|
2485 |
$self->_do_walk_down($self->{scandeps_tree}, $cb, 0, $pre); |
|
2486 |
} |
|
2487 |
|
|
2488 |
sub _do_walk_down { |
|
2489 |
my($self, $children, $cb, $depth, $pre) = @_; |
|
2490 |
|
|
2491 |
# DFS - $pre determines when we call the callback |
|
2492 |
for my $node (@$children) { |
|
2493 |
$cb->($node->[0], $depth) if $pre; |
|
2494 |
$self->_do_walk_down($node->[1], $cb, $depth + 1, $pre); |
|
2495 |
$cb->($node->[0], $depth) unless $pre; |
|
2496 |
} |
|
2497 |
} |
|
2498 |
|
|
2499 |
sub DESTROY { |
|
2500 |
my $self = shift; |
|
2501 |
$self->{at_exit}->($self) if $self->{at_exit}; |
|
2502 |
} |
|
2503 |
|
|
2504 |
# Utils |
|
2505 |
|
|
2506 |
sub shell_quote { |
|
2507 |
my($self, $stuff) = @_; |
|
2508 |
$stuff =~ /^${quote}.+${quote}$/ ? $stuff : ($quote . $stuff . $quote); |
|
2509 |
} |
|
2510 |
|
|
2511 |
sub which { |
|
2512 |
my($self, $name) = @_; |
|
2513 |
my $exe_ext = $Config{_exe}; |
|
2514 |
for my $dir (File::Spec->path) { |
|
2515 |
my $fullpath = File::Spec->catfile($dir, $name); |
|
2516 |
if (-x $fullpath || -x ($fullpath .= $exe_ext)) { |
|
2517 |
if ($fullpath =~ /\s/ && $fullpath !~ /^$quote/) { |
|
2518 |
$fullpath = $self->shell_quote($fullpath); |
|
2519 |
} |
|
2520 |
return $fullpath; |
|
2521 |
} |
|
2522 |
} |
|
2523 |
return; |
|
2524 |
} |
|
2525 |
|
|
2526 |
sub get { |
|
2527 |
my($self, $uri) = @_; |
|
2528 |
if ($uri =~ /^file:/) { |
|
2529 |
$self->file_get($uri); |
|
2530 |
} else { |
|
2531 |
$self->{_backends}{get}->(@_); |
|
2532 |
} |
|
2533 |
} |
|
2534 |
|
|
2535 |
sub mirror { |
|
2536 |
my($self, $uri, $local) = @_; |
|
2537 |
if ($uri =~ /^file:/) { |
|
2538 |
$self->file_mirror($uri, $local); |
|
2539 |
} else { |
|
2540 |
$self->{_backends}{mirror}->(@_); |
|
2541 |
} |
|
2542 |
} |
|
2543 |
|
|
2544 |
sub untar { $_[0]->{_backends}{untar}->(@_) }; |
|
2545 |
sub unzip { $_[0]->{_backends}{unzip}->(@_) }; |
|
2546 |
|
|
2547 |
sub uri_to_file { |
|
2548 |
my($self, $uri) = @_; |
|
2549 |
|
|
2550 |
# file:///path/to/file -> /path/to/file |
|
2551 |
# file://C:/path -> C:/path |
|
2552 |
if ($uri =~ s!file:/+!!) { |
|
2553 |
$uri = "/$uri" unless $uri =~ m![a-zA-Z]:!; |
|
2554 |
} |
|
2555 |
|
|
2556 |
return $uri; |
|
2557 |
} |
|
2558 |
|
|
2559 |
sub file_get { |
|
2560 |
my($self, $uri) = @_; |
|
2561 |
my $file = $self->uri_to_file($uri); |
|
2562 |
open my $fh, "<$file" or return; |
|
2563 |
join '', <$fh>; |
|
2564 |
} |
|
2565 |
|
|
2566 |
sub file_mirror { |
|
2567 |
my($self, $uri, $path) = @_; |
|
2568 |
my $file = $self->uri_to_file($uri); |
|
2569 |
File::Copy::copy($file, $path); |
|
2570 |
} |
|
2571 |
|
|
2572 |
sub init_tools { |
|
2573 |
my $self = shift; |
|
2574 |
|
|
2575 |
return if $self->{initialized}++; |
|
2576 |
|
|
2577 |
if ($self->{make} = $self->which($Config{make})) { |
|
2578 |
$self->chat("You have make $self->{make}\n"); |
|
2579 |
} |
|
2580 |
|
|
2581 |
# use --no-lwp if they have a broken LWP, to upgrade LWP |
|
2582 |
if ($self->{try_lwp} && eval { require LWP::UserAgent; LWP::UserAgent->VERSION(5.802) }) { |
|
2583 |
$self->chat("You have LWP $LWP::VERSION\n"); |
|
2584 |
my $ua = sub { |
|
2585 |
LWP::UserAgent->new( |
|
2586 |
parse_head => 0, |
|
2587 |
env_proxy => 1, |
|
2588 |
agent => $self->agent, |
|
2589 |
timeout => 30, |
|
2590 |
@_, |
|
2591 |
); |
|
2592 |
}; |
|
2593 |
$self->{_backends}{get} = sub { |
|
2594 |
my $self = shift; |
|
2595 |
my $res = $ua->()->request(HTTP::Request->new(GET => $_[0])); |
|
2596 |
return unless $res->is_success; |
|
2597 |
return $res->decoded_content; |
|
2598 |
}; |
|
2599 |
$self->{_backends}{mirror} = sub { |
|
2600 |
my $self = shift; |
|
2601 |
my $res = $ua->()->mirror(@_); |
|
2602 |
$res->code; |
|
2603 |
}; |
|
2604 |
} elsif ($self->{try_wget} and my $wget = $self->which('wget')) { |
|
2605 |
$self->chat("You have $wget\n"); |
|
2606 |
my @common = ( |
|
2607 |
'--user-agent', $self->agent, |
|
2608 |
'--retry-connrefused', |
|
2609 |
($self->{verbose} ? () : ('-q')), |
|
2610 |
); |
|
2611 |
$self->{_backends}{get} = sub { |
|
2612 |
my($self, $uri) = @_; |
|
2613 |
$self->safeexec( my $fh, $wget, $uri, @common, '-O', '-' ) or die "wget $uri: $!"; |
|
2614 |
local $/; |
|
2615 |
<$fh>; |
|
2616 |
}; |
|
2617 |
$self->{_backends}{mirror} = sub { |
|
2618 |
my($self, $uri, $path) = @_; |
|
2619 |
$self->safeexec( my $fh, $wget, $uri, @common, '-O', $path ) or die "wget $uri: $!"; |
|
2620 |
local $/; |
|
2621 |
<$fh>; |
|
2622 |
}; |
|
2623 |
} elsif ($self->{try_curl} and my $curl = $self->which('curl')) { |
|
2624 |
$self->chat("You have $curl\n"); |
|
2625 |
my @common = ( |
|
2626 |
'--location', |
|
2627 |
'--user-agent', $self->agent, |
|
2628 |
($self->{verbose} ? () : '-s'), |
|
2629 |
); |
|
2630 |
$self->{_backends}{get} = sub { |
|
2631 |
my($self, $uri) = @_; |
|
2632 |
$self->safeexec( my $fh, $curl, @common, $uri ) or die "curl $uri: $!"; |
|
2633 |
local $/; |
|
2634 |
<$fh>; |
|
2635 |
}; |
|
2636 |
$self->{_backends}{mirror} = sub { |
|
2637 |
my($self, $uri, $path) = @_; |
|
2638 |
$self->safeexec( my $fh, $curl, @common, $uri, '-#', '-o', $path ) or die "curl $uri: $!"; |
|
2639 |
local $/; |
|
2640 |
<$fh>; |
|
2641 |
}; |
|
2642 |
} else { |
|
2643 |
require HTTP::Tiny; |
|
2644 |
$self->chat("Falling back to HTTP::Tiny $HTTP::Tiny::VERSION\n"); |
|
2645 |
my %common = ( |
|
2646 |
agent => $self->agent, |
|
2647 |
); |
|
2648 |
$self->{_backends}{get} = sub { |
|
2649 |
my $self = shift; |
|
2650 |
my $res = HTTP::Tiny->new(%common)->get($_[0]); |
|
2651 |
return unless $res->{success}; |
|
2652 |
return $res->{content}; |
|
2653 |
}; |
|
2654 |
$self->{_backends}{mirror} = sub { |
|
2655 |
my $self = shift; |
|
2656 |
my $res = HTTP::Tiny->new(%common)->mirror(@_); |
|
2657 |
return $res->{status}; |
|
2658 |
}; |
|
2659 |
} |
|
2660 |
|
|
2661 |
my $tar = $self->which('tar'); |
|
2662 |
my $tar_ver; |
|
2663 |
my $maybe_bad_tar = sub { WIN32 || SUNOS || (($tar_ver = `$tar --version 2>/dev/null`) =~ /GNU.*1\.13/i) }; |
|
2664 |
|
|
2665 |
if ($tar && !$maybe_bad_tar->()) { |
|
2666 |
chomp $tar_ver; |
|
2667 |
$self->chat("You have $tar: $tar_ver\n"); |
|
2668 |
$self->{_backends}{untar} = sub { |
|
2669 |
my($self, $tarfile) = @_; |
|
2670 |
|
|
2671 |
my $xf = ($self->{verbose} ? 'v' : '')."xf"; |
|
2672 |
my $ar = $tarfile =~ /bz2$/ ? 'j' : 'z'; |
|
2673 |
|
|
2674 |
my($root, @others) = `$tar ${ar}tf $tarfile` |
|
2675 |
or return undef; |
|
2676 |
|
|
2677 |
FILE: { |
|
2678 |
chomp $root; |
|
2679 |
$root =~ s!^\./!!; |
|
2680 |
$root =~ s{^(.+?)/.*$}{$1}; |
|
2681 |
|
|
2682 |
if (!length($root)) { |
|
2683 |
# archive had ./ as the first entry, so try again |
|
2684 |
$root = shift(@others); |
|
2685 |
redo FILE if $root; |
|
2686 |
} |
|
2687 |
} |
|
2688 |
|
|
2689 |
system "$tar $ar$xf $tarfile"; |
|
2690 |
return $root if -d $root; |
|
2691 |
|
|
2692 |
$self->diag_fail("Bad archive: $tarfile"); |
|
2693 |
return undef; |
|
2694 |
} |
|
2695 |
} elsif ( $tar |
|
2696 |
and my $gzip = $self->which('gzip') |
|
2697 |
and my $bzip2 = $self->which('bzip2')) { |
|
2698 |
$self->chat("You have $tar, $gzip and $bzip2\n"); |
|
2699 |
$self->{_backends}{untar} = sub { |
|
2700 |
my($self, $tarfile) = @_; |
|
2701 |
|
|
2702 |
my $x = "x" . ($self->{verbose} ? 'v' : '') . "f -"; |
|
2703 |
my $ar = $tarfile =~ /bz2$/ ? $bzip2 : $gzip; |
|
2704 |
|
|
2705 |
my($root, @others) = `$ar -dc $tarfile | $tar tf -` |
|
2706 |
or return undef; |
|
2707 |
|
|
2708 |
FILE: { |
|
2709 |
chomp $root; |
|
2710 |
$root =~ s!^\./!!; |
|
2711 |
$root =~ s{^(.+?)/.*$}{$1}; |
|
2712 |
|
|
2713 |
if (!length($root)) { |
|
2714 |
# archive had ./ as the first entry, so try again |
|
2715 |
$root = shift(@others); |
|
2716 |
redo FILE if $root; |
|
2717 |
} |
|
2718 |
} |
|
2719 |
|
|
2720 |
system "$ar -dc $tarfile | $tar $x"; |
|
2721 |
return $root if -d $root; |
|
2722 |
|
|
2723 |
$self->diag_fail("Bad archive: $tarfile"); |
|
2724 |
return undef; |
|
2725 |
} |
|
2726 |
} elsif (eval { require Archive::Tar }) { # uses too much memory! |
|
2727 |
$self->chat("Falling back to Archive::Tar $Archive::Tar::VERSION\n"); |
|
2728 |
$self->{_backends}{untar} = sub { |
|
2729 |
my $self = shift; |
|
2730 |
my $t = Archive::Tar->new($_[0]); |
|
2731 |
my($root, @others) = $t->list_files; |
|
2732 |
FILE: { |
|
2733 |
$root =~ s!^\./!!; |
|
2734 |
$root =~ s{^(.+?)/.*$}{$1}; |
|
2735 |
|
|
2736 |
if (!length($root)) { |
|
2737 |
# archive had ./ as the first entry, so try again |
|
2738 |
$root = shift(@others); |
|
2739 |
redo FILE if $root; |
|
2740 |
} |
|
2741 |
} |
|
2742 |
$t->extract; |
|
2743 |
return -d $root ? $root : undef; |
|
2744 |
}; |
|
2745 |
} else { |
|
2746 |
$self->{_backends}{untar} = sub { |
|
2747 |
die "Failed to extract $_[1] - You need to have tar or Archive::Tar installed.\n"; |
|
2748 |
}; |
|
2749 |
} |
|
2750 |
|
|
2751 |
if (my $unzip = $self->which('unzip')) { |
|
2752 |
$self->chat("You have $unzip\n"); |
|
2753 |
$self->{_backends}{unzip} = sub { |
|
2754 |
my($self, $zipfile) = @_; |
|
2755 |
|
|
2756 |
my $opt = $self->{verbose} ? '' : '-q'; |
|
2757 |
my(undef, $root, @others) = `$unzip -t $zipfile` |
|
2758 |
or return undef; |
|
2759 |
|
|
2760 |
chomp $root; |
|
2761 |
$root =~ s{^\s+testing:\s+([^/]+)/.*?\s+OK$}{$1}; |
|
2762 |
|
|
2763 |
system "$unzip $opt $zipfile"; |
|
2764 |
return $root if -d $root; |
|
2765 |
|
|
2766 |
$self->diag_fail("Bad archive: [$root] $zipfile"); |
|
2767 |
return undef; |
|
2768 |
} |
|
2769 |
} else { |
|
2770 |
$self->{_backends}{unzip} = sub { |
|
2771 |
eval { require Archive::Zip } |
|
2772 |
or die "Failed to extract $_[1] - You need to have unzip or Archive::Zip installed.\n"; |
|
2773 |
my($self, $file) = @_; |
|
2774 |
my $zip = Archive::Zip->new(); |
|
2775 |
my $status; |
|
2776 |
$status = $zip->read($file); |
|
2777 |
$self->diag_fail("Read of file[$file] failed") |
|
2778 |
if $status != Archive::Zip::AZ_OK(); |
|
2779 |
my @members = $zip->members(); |
|
2780 |
for my $member ( @members ) { |
|
2781 |
my $af = $member->fileName(); |
|
2782 |
next if ($af =~ m!^(/|\.\./)!); |
|
2783 |
$status = $member->extractToFileNamed( $af ); |
|
2784 |
$self->diag_fail("Extracting of file[$af] from zipfile[$file failed") |
|
2785 |
if $status != Archive::Zip::AZ_OK(); |
|
2786 |
} |
|
2787 |
|
|
2788 |
my ($root) = $zip->membersMatching( qr<^[^/]+/$> ); |
|
2789 |
$root &&= $root->fileName; |
|
2790 |
return -d $root ? $root : undef; |
|
2791 |
}; |
|
2792 |
} |
|
2793 |
} |
|
2794 |
|
|
2795 |
sub safeexec { |
|
2796 |
my $self = shift; |
|
2797 |
my $rdr = $_[0] ||= Symbol::gensym(); |
|
2798 |
|
|
2799 |
if (WIN32) { |
|
2800 |
my $cmd = join q{ }, map { $self->shell_quote($_) } @_[ 1 .. $#_ ]; |
|
2801 |
return open( $rdr, "$cmd |" ); |
|
2802 |
} |
|
2803 |
|
|
2804 |
if ( my $pid = open( $rdr, '-|' ) ) { |
|
2805 |
return $pid; |
|
2806 |
} |
|
2807 |
elsif ( defined $pid ) { |
|
2808 |
exec( @_[ 1 .. $#_ ] ); |
|
2809 |
exit 1; |
|
2810 |
} |
|
2811 |
else { |
|
2812 |
return; |
|
2813 |
} |
|
2814 |
} |
|
2815 |
|
|
2816 |
sub parse_meta { |
|
2817 |
my($self, $file) = @_; |
|
2818 |
return eval { Parse::CPAN::Meta->load_file($file) }; |
|
2819 |
} |
|
2820 |
|
|
2821 |
sub parse_meta_string { |
|
2822 |
my($self, $yaml) = @_; |
|
2823 |
return eval { Parse::CPAN::Meta->load_yaml_string($yaml) }; |
|
2824 |
} |
|
2825 |
|
|
2826 |
1; |
|
2827 |
APP_CPANMINUS_SCRIPT |
|
2828 | ||
2829 |
$fatpacked{"CPAN/DistnameInfo.pm"} = <<'CPAN_DISTNAMEINFO'; |
|
2830 |
|
|
2831 |
package CPAN::DistnameInfo; |
|
2832 |
|
|
2833 |
$VERSION = "0.12"; |
|
2834 |
use strict; |
|
2835 |
|
|
2836 |
sub distname_info { |
|
2837 |
my $file = shift or return; |
|
2838 |
|
|
2839 |
my ($dist, $version) = $file =~ /^ |
|
2840 |
((?:[-+.]*(?:[A-Za-z0-9]+|(?<=\D)_|_(?=\D))* |
|
2841 |
(?: |
|
2842 |
[A-Za-z](?=[^A-Za-z]|$) |
|
2843 |
| |
|
2844 |
\d(?=-) |
|
2845 |
)(?<![._-][vV]) |
|
2846 |
)+)(.*) |
|
2847 |
$/xs or return ($file,undef,undef); |
|
2848 |
|
|
2849 |
if ($dist =~ /-undef\z/ and ! length $version) { |
|
2850 |
$dist =~ s/-undef\z//; |
|
2851 |
} |
|
2852 |
|
|
2853 |
# Remove potential -withoutworldwriteables suffix |
|
2854 |
$version =~ s/-withoutworldwriteables$//; |
|
2855 |
|
|
2856 |
if ($version =~ /^(-[Vv].*)-(\d.*)/) { |
|
2857 |
|
|
2858 |
# Catch names like Unicode-Collate-Standard-V3_1_1-0.1 |
|
2859 |
# where the V3_1_1 is part of the distname |
|
2860 |
$dist .= $1; |
|
2861 |
$version = $2; |
|
2862 |
} |
|
2863 |
|
|
2864 |
if ($version =~ /(.+_.*)-(\d.*)/) { |
|
2865 |
# Catch names like Task-Deprecations5_14-1.00.tar.gz where the 5_14 is |
|
2866 |
# part of the distname. However, names like libao-perl_0.03-1.tar.gz |
|
2867 |
# should still have 0.03-1 as their version. |
|
2868 |
$dist .= $1; |
|
2869 |
$version = $2; |
|
2870 |
} |
|
2871 |
|
|
2872 |
# Normalize the Dist.pm-1.23 convention which CGI.pm and |
|
2873 |
# a few others use. |
|
2874 |
$dist =~ s{\.pm$}{}; |
|
2875 |
|
|
2876 |
$version = $1 |
|
2877 |
if !length $version and $dist =~ s/-(\d+\w)$//; |
|
2878 |
|
|
2879 |
$version = $1 . $version |
|
2880 |
if $version =~ /^\d+$/ and $dist =~ s/-(\w+)$//; |
|
2881 |
|
|
2882 |
if ($version =~ /\d\.\d/) { |
|
2883 |
$version =~ s/^[-_.]+//; |
|
2884 |
} |
|
2885 |
else { |
|
2886 |
$version =~ s/^[-_]+//; |
|
2887 |
} |
|
2888 |
|
|
2889 |
my $dev; |
|
2890 |
if (length $version) { |
|
2891 |
if ($file =~ /^perl-?\d+\.(\d+)(?:\D(\d+))?(-(?:TRIAL|RC)\d+)?$/) { |
|
2892 |
$dev = 1 if (($1 > 6 and $1 & 1) or ($2 and $2 >= 50)) or $3; |
|
2893 |
} |
|
2894 |
elsif ($version =~ /\d\D\d+_\d/ or $version =~ /-TRIAL/) { |
|
2895 |
$dev = 1; |
|
2896 |
} |
|
2897 |
} |
|
2898 |
else { |
|
2899 |
$version = undef; |
|
2900 |
} |
|
2901 |
|
|
2902 |
($dist, $version, $dev); |
|
2903 |
} |
|
2904 |
|
|
2905 |
sub new { |
|
2906 |
my $class = shift; |
|
2907 |
my $distfile = shift; |
|
2908 |
|
|
2909 |
$distfile =~ s,//+,/,g; |
|
2910 |
|
|
2911 |
my %info = ( pathname => $distfile ); |
|
2912 |
|
|
2913 |
($info{filename} = $distfile) =~ s,^(((.*?/)?authors/)?id/)?([A-Z])/(\4[A-Z])/(\5[-A-Z0-9]*)/,, |
|
2914 |
and $info{cpanid} = $6; |
|
2915 |
|
|
2916 |
if ($distfile =~ m,([^/]+)\.(tar\.(?:g?z|bz2)|zip|tgz)$,i) { # support more ? |
|
2917 |
$info{distvname} = $1; |
|
2918 |
$info{extension} = $2; |
|
2919 |
} |
|
2920 |
|
|
2921 |
@info{qw(dist version beta)} = distname_info($info{distvname}); |
|
2922 |
$info{maturity} = delete $info{beta} ? 'developer' : 'released'; |
|
2923 |
|
|
2924 |
return bless \%info, $class; |
|
2925 |
} |
|
2926 |
|
|
2927 |
sub dist { shift->{dist} } |
|
2928 |
sub version { shift->{version} } |
|
2929 |
sub maturity { shift->{maturity} } |
|
2930 |
sub filename { shift->{filename} } |
|
2931 |
sub cpanid { shift->{cpanid} } |
|
2932 |
sub distvname { shift->{distvname} } |
|
2933 |
sub extension { shift->{extension} } |
|
2934 |
sub pathname { shift->{pathname} } |
|
2935 |
|
|
2936 |
sub properties { %{ $_[0] } } |
|
2937 |
|
|
2938 |
1; |
|
2939 |
|
|
2940 |
__END__ |
|
2941 |
|
|
2942 |
CPAN_DISTNAMEINFO |
|
2943 | ||
2944 |
$fatpacked{"CPAN/Meta.pm"} = <<'CPAN_META'; |
|
2945 |
use 5.006; |
|
2946 |
use strict; |
|
2947 |
use warnings; |
|
2948 |
package CPAN::Meta; |
|
2949 |
our $VERSION = '2.120921'; # VERSION |
|
2950 |
|
|
2951 |
|
|
2952 |
use Carp qw(carp croak); |
|
2953 |
use CPAN::Meta::Feature; |
|
2954 |
use CPAN::Meta::Prereqs; |
|
2955 |
use CPAN::Meta::Converter; |
|
2956 |
use CPAN::Meta::Validator; |
|
2957 |
use Parse::CPAN::Meta 1.4403 (); |
|
2958 |
|
|
2959 |
BEGIN { *_dclone = \&CPAN::Meta::Converter::_dclone } |
|
2960 |
|
|
2961 |
|
|
2962 |
BEGIN { |
|
2963 |
my @STRING_READERS = qw( |
|
2964 |
abstract |
|
2965 |
description |
|
2966 |
dynamic_config |
|
2967 |
generated_by |
|
2968 |
name |
|
2969 |
release_status |
|
2970 |
version |
|
2971 |
); |
|
2972 |
|
|
2973 |
no strict 'refs'; |
|
2974 |
for my $attr (@STRING_READERS) { |
|
2975 |
*$attr = sub { $_[0]{ $attr } }; |
|
2976 |
} |
|
2977 |
} |
|
2978 |
|
|
2979 |
|
|
2980 |
BEGIN { |
|
2981 |
my @LIST_READERS = qw( |
|
2982 |
author |
|
2983 |
keywords |
|
2984 |
license |
|
2985 |
); |
|
2986 |
|
|
2987 |
no strict 'refs'; |
|
2988 |
for my $attr (@LIST_READERS) { |
|
2989 |
*$attr = sub { |
|
2990 |
my $value = $_[0]{ $attr }; |
|
2991 |
croak "$attr must be called in list context" |
|
2992 |
unless wantarray; |
|
2993 |
return @{ _dclone($value) } if ref $value; |
|
2994 |
return $value; |
|
2995 |
}; |
|
2996 |
} |
|
2997 |
} |
|
2998 |
|
|
2999 |
sub authors { $_[0]->author } |
|
3000 |
sub licenses { $_[0]->license } |
|
3001 |
|
|
3002 |
|
|
3003 |
BEGIN { |
|
3004 |
my @MAP_READERS = qw( |
|
3005 |
meta-spec |
|
3006 |
resources |
|
3007 |
provides |
|
3008 |
no_index |
|
3009 |
|
|
3010 |
prereqs |
|
3011 |
optional_features |
|
3012 |
); |
|
3013 |
|
|
3014 |
no strict 'refs'; |
|
3015 |
for my $attr (@MAP_READERS) { |
|
3016 |
(my $subname = $attr) =~ s/-/_/; |
|
3017 |
*$subname = sub { |
|
3018 |
my $value = $_[0]{ $attr }; |
|
3019 |
return _dclone($value) if $value; |
|
3020 |
return {}; |
|
3021 |
}; |
|
3022 |
} |
|
3023 |
} |
|
3024 |
|
|
3025 |
|
|
3026 |
sub custom_keys { |
|
3027 |
return grep { /^x_/i } keys %{$_[0]}; |
|
3028 |
} |
|
3029 |
|
|
3030 |
sub custom { |
|
3031 |
my ($self, $attr) = @_; |
|
3032 |
my $value = $self->{$attr}; |
|
3033 |
return _dclone($value) if ref $value; |
|
3034 |
return $value; |
|
3035 |
} |
|
3036 |
|
|
3037 |
|
|
3038 |
sub _new { |
|
3039 |
my ($class, $struct, $options) = @_; |
|
3040 |
my $self; |
|
3041 |
|
|
3042 |
if ( $options->{lazy_validation} ) { |
|
3043 |
# try to convert to a valid structure; if succeeds, then return it |
|
3044 |
my $cmc = CPAN::Meta::Converter->new( $struct ); |
|
3045 |
$self = $cmc->convert( version => 2 ); # valid or dies |
|
3046 |
return bless $self, $class; |
|
3047 |
} |
|
3048 |
else { |
|
3049 |
# validate original struct |
|
3050 |
my $cmv = CPAN::Meta::Validator->new( $struct ); |
|
3051 |
unless ( $cmv->is_valid) { |
|
3052 |
die "Invalid metadata structure. Errors: " |
|
3053 |
. join(", ", $cmv->errors) . "\n"; |
|
3054 |
} |
|
3055 |
} |
|
3056 |
|
|
3057 |
# up-convert older spec versions |
|
3058 |
my $version = $struct->{'meta-spec'}{version} || '1.0'; |
|
3059 |
if ( $version == 2 ) { |
|
3060 |
$self = $struct; |
|
3061 |
} |
|
3062 |
else { |
|
3063 |
my $cmc = CPAN::Meta::Converter->new( $struct ); |
|
3064 |
$self = $cmc->convert( version => 2 ); |
|
3065 |
} |
|
3066 |
|
|
3067 |
return bless $self, $class; |
|
3068 |
} |
|
3069 |
|
|
3070 |
sub new { |
|
3071 |
my ($class, $struct, $options) = @_; |
|
3072 |
my $self = eval { $class->_new($struct, $options) }; |
|
3073 |
croak($@) if $@; |
|
3074 |
return $self; |
|
3075 |
} |
|
3076 |
|
|
3077 |
|
|
3078 |
sub create { |
|
3079 |
my ($class, $struct, $options) = @_; |
|
3080 |
my $version = __PACKAGE__->VERSION || 2; |
|
3081 |
$struct->{generated_by} ||= __PACKAGE__ . " version $version" ; |
|
3082 |
$struct->{'meta-spec'}{version} ||= int($version); |
|
3083 |
my $self = eval { $class->_new($struct, $options) }; |
|
3084 |
croak ($@) if $@; |
|
3085 |
return $self; |
|
3086 |
} |
|
3087 |
|
|
3088 |
|
|
3089 |
sub load_file { |
|
3090 |
my ($class, $file, $options) = @_; |
|
3091 |
$options->{lazy_validation} = 1 unless exists $options->{lazy_validation}; |
|
3092 |
|
|
3093 |
croak "load_file() requires a valid, readable filename" |
|
3094 |
unless -r $file; |
|
3095 |
|
|
3096 |
my $self; |
|
3097 |
eval { |
|
3098 |
my $struct = Parse::CPAN::Meta->load_file( $file ); |
|
3099 |
$self = $class->_new($struct, $options); |
|
3100 |
}; |
|
3101 |
croak($@) if $@; |
|
3102 |
return $self; |
|
3103 |
} |
|
3104 |
|
|
3105 |
|
|
3106 |
sub load_yaml_string { |
|
3107 |
my ($class, $yaml, $options) = @_; |
|
3108 |
$options->{lazy_validation} = 1 unless exists $options->{lazy_validation}; |
|
3109 |
|
|
3110 |
my $self; |
|
3111 |
eval { |
|
3112 |
my ($struct) = Parse::CPAN::Meta->load_yaml_string( $yaml ); |
|
3113 |
$self = $class->_new($struct, $options); |
|
3114 |
}; |
|
3115 |
croak($@) if $@; |
|
3116 |
return $self; |
|
3117 |
} |
|
3118 |
|
|
3119 |
|
|
3120 |
sub load_json_string { |
|
3121 |
my ($class, $json, $options) = @_; |
|
3122 |
$options->{lazy_validation} = 1 unless exists $options->{lazy_validation}; |
|
3123 |
|
|
3124 |
my $self; |
|
3125 |
eval { |
|
3126 |
my $struct = Parse::CPAN::Meta->load_json_string( $json ); |
|
3127 |
$self = $class->_new($struct, $options); |
|
3128 |
}; |
|
3129 |
croak($@) if $@; |
|
3130 |
return $self; |
|
3131 |
} |
|
3132 |
|
|
3133 |
|
|
3134 |
sub save { |
|
3135 |
my ($self, $file, $options) = @_; |
|
3136 |
|
|
3137 |
my $version = $options->{version} || '2'; |
|
3138 |
my $layer = $] ge '5.008001' ? ':utf8' : ''; |
|
3139 |
|
|
3140 |
if ( $version ge '2' ) { |
|
3141 |
carp "'$file' should end in '.json'" |
|
3142 |
unless $file =~ m{\.json$}; |
|
3143 |
} |
|
3144 |
else { |
|
3145 |
carp "'$file' should end in '.yml'" |
|
3146 |
unless $file =~ m{\.yml$}; |
|
3147 |
} |
|
3148 |
|
|
3149 |
my $data = $self->as_string( $options ); |
|
3150 |
open my $fh, ">$layer", $file |
|
3151 |
or die "Error opening '$file' for writing: $!\n"; |
|
3152 |
|
|
3153 |
print {$fh} $data; |
|
3154 |
close $fh |
|
3155 |
or die "Error closing '$file': $!\n"; |
|
3156 |
|
|
3157 |
return 1; |
|
3158 |
} |
|
3159 |
|
|
3160 |
|
|
3161 |
sub meta_spec_version { |
|
3162 |
my ($self) = @_; |
|
3163 |
return $self->meta_spec->{version}; |
|
3164 |
} |
|
3165 |
|
|
3166 |
|
|
3167 |
sub effective_prereqs { |
|
3168 |
my ($self, $features) = @_; |
|
3169 |
$features ||= []; |
|
3170 |
|
|
3171 |
my $prereq = CPAN::Meta::Prereqs->new($self->prereqs); |
|
3172 |
|
|
3173 |
return $prereq unless @$features; |
|
3174 |
|
|
3175 |
my @other = map {; $self->feature($_)->prereqs } @$features; |
|
3176 |
|
|
3177 |
return $prereq->with_merged_prereqs(\@other); |
|
3178 |
} |
|
3179 |
|
|
3180 |
|
|
3181 |
sub should_index_file { |
|
3182 |
my ($self, $filename) = @_; |
|
3183 |
|
|
3184 |
for my $no_index_file (@{ $self->no_index->{file} || [] }) { |
|
3185 |
return if $filename eq $no_index_file; |
|
3186 |
} |
|
3187 |
|
|
3188 |
for my $no_index_dir (@{ $self->no_index->{directory} }) { |
|
3189 |
$no_index_dir =~ s{$}{/} unless $no_index_dir =~ m{/\z}; |
|
3190 |
return if index($filename, $no_index_dir) == 0; |
|
3191 |
} |
|
3192 |
|
|
3193 |
return 1; |
|
3194 |
} |
|
3195 |
|
|
3196 |
|
|
3197 |
sub should_index_package { |
|
3198 |
my ($self, $package) = @_; |
|
3199 |
|
|
3200 |
for my $no_index_pkg (@{ $self->no_index->{package} || [] }) { |
|
3201 |
return if $package eq $no_index_pkg; |
|
3202 |
} |
|
3203 |
|
|
3204 |
for my $no_index_ns (@{ $self->no_index->{namespace} }) { |
|
3205 |
return if index($package, "${no_index_ns}::") == 0; |
|
3206 |
} |
|
3207 |
|
|
3208 |
return 1; |
|
3209 |
} |
|
3210 |
|
|
3211 |
|
|
3212 |
sub features { |
|
3213 |
my ($self) = @_; |
|
3214 |
|
|
3215 |
my $opt_f = $self->optional_features; |
|
3216 |
my @features = map {; CPAN::Meta::Feature->new($_ => $opt_f->{ $_ }) } |
|
3217 |
keys %$opt_f; |
|
3218 |
|
|
3219 |
return @features; |
|
3220 |
} |
|
3221 |
|
|
3222 |
|
|
3223 |
sub feature { |
|
3224 |
my ($self, $ident) = @_; |
|
3225 |
|
|
3226 |
croak "no feature named $ident" |
|
3227 |
unless my $f = $self->optional_features->{ $ident }; |
|
3228 |
|
|
3229 |
return CPAN::Meta::Feature->new($ident, $f); |
|
3230 |
} |
|
3231 |
|
|
3232 |
|
|
3233 |
sub as_struct { |
|
3234 |
my ($self, $options) = @_; |
|
3235 |
my $struct = _dclone($self); |
|
3236 |
if ( $options->{version} ) { |
|
3237 |
my $cmc = CPAN::Meta::Converter->new( $struct ); |
|
3238 |
$struct = $cmc->convert( version => $options->{version} ); |
|
3239 |
} |
|
3240 |
return $struct; |
|
3241 |
} |
|
3242 |
|
|
3243 |
|
|
3244 |
sub as_string { |
|
3245 |
my ($self, $options) = @_; |
|
3246 |
|
|
3247 |
my $version = $options->{version} || '2'; |
|
3248 |
|
|
3249 |
my $struct; |
|
3250 |
if ( $self->meta_spec_version ne $version ) { |
|
3251 |
my $cmc = CPAN::Meta::Converter->new( $self->as_struct ); |
|
3252 |
$struct = $cmc->convert( version => $version ); |
|
3253 |
} |
|
3254 |
else { |
|
3255 |
$struct = $self->as_struct; |
|
3256 |
} |
|
3257 |
|
|
3258 |
my ($data, $backend); |
|
3259 |
if ( $version ge '2' ) { |
|
3260 |
$backend = Parse::CPAN::Meta->json_backend(); |
|
3261 |
$data = $backend->new->pretty->canonical->encode($struct); |
|
3262 |
} |
|
3263 |
else { |
|
3264 |
$backend = Parse::CPAN::Meta->yaml_backend(); |
|
3265 |
$data = eval { no strict 'refs'; &{"$backend\::Dump"}($struct) }; |
|
3266 |
if ( $@ ) { |
|
3267 |
croak $backend->can('errstr') ? $backend->errstr : $@ |
|
3268 |
} |
|
3269 |
} |
|
3270 |
|
|
3271 |
return $data; |
|
3272 |
} |
|
3273 |
|
|
3274 |
# Used by JSON::PP, etc. for "convert_blessed" |
|
3275 |
sub TO_JSON { |
|
3276 |
return { %{ $_[0] } }; |
|
3277 |
} |
|
3278 |
|
|
3279 |
1; |
|
3280 |
|
|
3281 |
# ABSTRACT: the distribution metadata for a CPAN dist |
|
3282 |
|
|
3283 |
|
|
3284 |
|
|
3285 |
|
|
3286 |
__END__ |
|
3287 |
|
|
3288 |
|
|
3289 |
CPAN_META |
|
3290 | ||
3291 |
$fatpacked{"CPAN/Meta/Converter.pm"} = <<'CPAN_META_CONVERTER'; |
|
3292 |
use 5.006; |
|
3293 |
use strict; |
|
3294 |
use warnings; |
|
3295 |
package CPAN::Meta::Converter; |
|
3296 |
our $VERSION = '2.120921'; # VERSION |
|
3297 |
|
|
3298 |
|
|
3299 |
use CPAN::Meta::Validator; |
|
3300 |
use CPAN::Meta::Requirements; |
|
3301 |
use version 0.88 (); |
|
3302 |
use Parse::CPAN::Meta 1.4400 (); |
|
3303 |
|
|
3304 |
sub _dclone { |
|
3305 |
my $ref = shift; |
|
3306 |
|
|
3307 |
# if an object is in the data structure and doesn't specify how to |
|
3308 |
# turn itself into JSON, we just stringify the object. That does the |
|
3309 |
# right thing for typical things that might be there, like version objects, |
|
3310 |
# Path::Class objects, etc. |
|
3311 |
no warnings 'once'; |
|
3312 |
local *UNIVERSAL::TO_JSON = sub { return "$_[0]" }; |
|
3313 |
|
|
3314 |
my $backend = Parse::CPAN::Meta->json_backend(); |
|
3315 |
return $backend->new->utf8->decode( |
|
3316 |
$backend->new->utf8->allow_blessed->convert_blessed->encode($ref) |
|
3317 |
); |
|
3318 |
} |
|
3319 |
|
|
3320 |
my %known_specs = ( |
|
3321 |
'2' => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec', |
|
3322 |
'1.4' => 'http://module-build.sourceforge.net/META-spec-v1.4.html', |
|
3323 |
'1.3' => 'http://module-build.sourceforge.net/META-spec-v1.3.html', |
|
3324 |
'1.2' => 'http://module-build.sourceforge.net/META-spec-v1.2.html', |
|
3325 |
'1.1' => 'http://module-build.sourceforge.net/META-spec-v1.1.html', |
|
3326 |
'1.0' => 'http://module-build.sourceforge.net/META-spec-v1.0.html' |
|
3327 |
); |
|
3328 |
|
|
3329 |
my @spec_list = sort { $a <=> $b } keys %known_specs; |
|
3330 |
my ($LOWEST, $HIGHEST) = @spec_list[0,-1]; |
|
3331 |
|
|
3332 |
#--------------------------------------------------------------------------# |
|
3333 |
# converters |
|
3334 |
# |
|
3335 |
# called as $converter->($element, $field_name, $full_meta, $to_version) |
|
3336 |
# |
|
3337 |
# defined return value used for field |
|
3338 |
# undef return value means field is skipped |
|
3339 |
#--------------------------------------------------------------------------# |
|
3340 |
|
|
3341 |
sub _keep { $_[0] } |
|
3342 |
|
|
3343 |
sub _keep_or_one { defined($_[0]) ? $_[0] : 1 } |
|
3344 |
|
|
3345 |
sub _keep_or_zero { defined($_[0]) ? $_[0] : 0 } |
|
3346 |
|
|
3347 |
sub _keep_or_unknown { defined($_[0]) && length($_[0]) ? $_[0] : "unknown" } |
|
3348 |
|
|
3349 |
sub _generated_by { |
|
3350 |
my $gen = shift; |
|
3351 |
my $sig = __PACKAGE__ . " version " . (__PACKAGE__->VERSION || "<dev>"); |
|
3352 |
|
|
3353 |
return $sig unless defined $gen and length $gen; |
|
3354 |
return $gen if $gen =~ /(, )\Q$sig/; |
|
3355 |
return "$gen, $sig"; |
|
3356 |
} |
|
3357 |
|
|
3358 |
sub _listify { ! defined $_[0] ? undef : ref $_[0] eq 'ARRAY' ? $_[0] : [$_[0]] } |
|
3359 |
|
|
3360 |
sub _prefix_custom { |
|
3361 |
my $key = shift; |
|
3362 |
$key =~ s/^(?!x_) # Unless it already starts with x_ |
|
3363 |
(?:x-?)? # Remove leading x- or x (if present) |
|
3364 |
/x_/ix; # and prepend x_ |
|
3365 |
return $key; |
|
3366 |
} |
|
3367 |
|
|
3368 |
sub _ucfirst_custom { |
|
3369 |
my $key = shift; |
|
3370 |
$key = ucfirst $key unless $key =~ /[A-Z]/; |
|
3371 |
return $key; |
|
3372 |
} |
|
3373 |
|
|
3374 |
sub _change_meta_spec { |
|
3375 |
my ($element, undef, undef, $version) = @_; |
|
3376 |
$element->{version} = $version; |
|
3377 |
$element->{url} = $known_specs{$version}; |
|
3378 |
return $element; |
|
3379 |
} |
|
3380 |
|
|
3381 |
my @valid_licenses_1 = ( |
|
3382 |
'perl', |
|
3383 |
'gpl', |
|
3384 |
'apache', |
|
3385 |
'artistic', |
|
3386 |
'artistic_2', |
|
3387 |
'lgpl', |
|
3388 |
'bsd', |
|
3389 |
'gpl', |
|
3390 |
'mit', |
|
3391 |
'mozilla', |
|
3392 |
'open_source', |
|
3393 |
'unrestricted', |
|
3394 |
'restrictive', |
|
3395 |
'unknown', |
|
3396 |
); |
|
3397 |
|
|
3398 |
my %license_map_1 = ( |
|
3399 |
( map { $_ => $_ } @valid_licenses_1 ), |
|
3400 |
artistic2 => 'artistic_2', |
|
3401 |
); |
|
3402 |
|
|
3403 |
sub _license_1 { |
|
3404 |
my ($element) = @_; |
|
3405 |
return 'unknown' unless defined $element; |
|
3406 |
if ( $license_map_1{lc $element} ) { |
|
3407 |
return $license_map_1{lc $element}; |
|
3408 |
} |
|
3409 |
return 'unknown'; |
|
3410 |
} |
|
3411 |
|
|
3412 |
my @valid_licenses_2 = qw( |
|
3413 |
agpl_3 |
|
3414 |
apache_1_1 |
|
3415 |
apache_2_0 |
|
3416 |
artistic_1 |
|
3417 |
artistic_2 |
|
3418 |
bsd |
|
3419 |
freebsd |
|
3420 |
gfdl_1_2 |
|
3421 |
gfdl_1_3 |
|
3422 |
gpl_1 |
|
3423 |
gpl_2 |
|
3424 |
gpl_3 |
|
3425 |
lgpl_2_1 |
|
3426 |
lgpl_3_0 |
|
3427 |
mit |
|
3428 |
mozilla_1_0 |
|
3429 |
mozilla_1_1 |
|
3430 |
openssl |
|
3431 |
perl_5 |
|
3432 |
qpl_1_0 |
|
3433 |
ssleay |
|
3434 |
sun |
|
3435 |
zlib |
|
3436 |
open_source |
|
3437 |
restricted |
|
3438 |
unrestricted |
|
3439 |
unknown |
|
3440 |
); |
|
3441 |
|
|
3442 |
# The "old" values were defined by Module::Build, and were often vague. I have |
|
3443 |
# made the decisions below based on reading Module::Build::API and how clearly |
|
3444 |
# it specifies the version of the license. |
|
3445 |
my %license_map_2 = ( |
|
3446 |
(map { $_ => $_ } @valid_licenses_2), |
|
3447 |
apache => 'apache_2_0', # clearly stated as 2.0 |
|
3448 |
artistic => 'artistic_1', # clearly stated as 1 |
|
3449 |
artistic2 => 'artistic_2', # clearly stated as 2 |
|
3450 |
gpl => 'open_source', # we don't know which GPL; punt |
|
3451 |
lgpl => 'open_source', # we don't know which LGPL; punt |
|
3452 |
mozilla => 'open_source', # we don't know which MPL; punt |
|
3453 |
perl => 'perl_5', # clearly Perl 5 |
|
3454 |
restrictive => 'restricted', |
|
3455 |
); |
|
3456 |
|
|
3457 |
sub _license_2 { |
|
3458 |
my ($element) = @_; |
|
3459 |
return [ 'unknown' ] unless defined $element; |
|
3460 |
$element = [ $element ] unless ref $element eq 'ARRAY'; |
|
3461 |
my @new_list; |
|
3462 |
for my $lic ( @$element ) { |
|
3463 |
next unless defined $lic; |
|
3464 |
if ( my $new = $license_map_2{lc $lic} ) { |
|
3465 |
push @new_list, $new; |
|
3466 |
} |
|
3467 |
} |
|
3468 |
return @new_list ? \@new_list : [ 'unknown' ]; |
|
3469 |
} |
|
3470 |
|
|
3471 |
my %license_downgrade_map = qw( |
|
3472 |
agpl_3 open_source |
|
3473 |
apache_1_1 apache |
|
3474 |
apache_2_0 apache |
|
3475 |
artistic_1 artistic |
|
3476 |
artistic_2 artistic_2 |
|
3477 |
bsd bsd |
|
3478 |
freebsd open_source |
|
3479 |
gfdl_1_2 open_source |
|
3480 |
gfdl_1_3 open_source |
|
3481 |
gpl_1 gpl |
|
3482 |
gpl_2 gpl |
|
3483 |
gpl_3 gpl |
|
3484 |
lgpl_2_1 lgpl |
|
3485 |
lgpl_3_0 lgpl |
|
3486 |
mit mit |
|
3487 |
mozilla_1_0 mozilla |
|
3488 |
mozilla_1_1 mozilla |
|
3489 |
openssl open_source |
|
3490 |
perl_5 perl |
|
3491 |
qpl_1_0 open_source |
|
3492 |
ssleay open_source |
|
3493 |
sun open_source |
|
3494 |
zlib open_source |
|
3495 |
open_source open_source |
|
3496 |
restricted restrictive |
|
3497 |
unrestricted unrestricted |
|
3498 |
unknown unknown |
|
3499 |
); |
|
3500 |
|
|
3501 |
sub _downgrade_license { |
|
3502 |
my ($element) = @_; |
|
3503 |
if ( ! defined $element ) { |
|
3504 |
return "unknown"; |
|
3505 |
} |
|
3506 |
elsif( ref $element eq 'ARRAY' ) { |
|
3507 |
if ( @$element == 1 ) { |
|
3508 |
return $license_downgrade_map{$element->[0]} || "unknown"; |
|
3509 |
} |
|
3510 |
} |
|
3511 |
elsif ( ! ref $element ) { |
|
3512 |
return $license_downgrade_map{$element} || "unknown"; |
|
3513 |
} |
|
3514 |
return "unknown"; |
|
3515 |
} |
|
3516 |
|
|
3517 |
my $no_index_spec_1_2 = { |
|
3518 |
'file' => \&_listify, |
|
3519 |
'dir' => \&_listify, |
|
3520 |
'package' => \&_listify, |
|
3521 |
'namespace' => \&_listify, |
|
3522 |
}; |
|
3523 |
|
|
3524 |
my $no_index_spec_1_3 = { |
|
3525 |
'file' => \&_listify, |
|
3526 |
'directory' => \&_listify, |
|
3527 |
'package' => \&_listify, |
|
3528 |
'namespace' => \&_listify, |
|
3529 |
}; |
|
3530 |
|
|
3531 |
my $no_index_spec_2 = { |
|
3532 |
'file' => \&_listify, |
|
3533 |
'directory' => \&_listify, |
|
3534 |
'package' => \&_listify, |
|
3535 |
'namespace' => \&_listify, |
|
3536 |
':custom' => \&_prefix_custom, |
|
3537 |
}; |
|
3538 |
|
|
3539 |
sub _no_index_1_2 { |
|
3540 |
my (undef, undef, $meta) = @_; |
|
3541 |
my $no_index = $meta->{no_index} || $meta->{private}; |
|
3542 |
return unless $no_index; |
|
3543 |
|
|
3544 |
# cleanup wrong format |
|
3545 |
if ( ! ref $no_index ) { |
|
3546 |
my $item = $no_index; |
|
3547 |
$no_index = { dir => [ $item ], file => [ $item ] }; |
|
3548 |
} |
|
3549 |
elsif ( ref $no_index eq 'ARRAY' ) { |
|
3550 |
my $list = $no_index; |
|
3551 |
$no_index = { dir => [ @$list ], file => [ @$list ] }; |
|
3552 |
} |
|
3553 |
|
|
3554 |
# common mistake: files -> file |
|
3555 |
if ( exists $no_index->{files} ) { |
|
3556 |
$no_index->{file} = delete $no_index->{file}; |
|
3557 |
} |
|
3558 |
# common mistake: modules -> module |
|
3559 |
if ( exists $no_index->{modules} ) { |
|
3560 |
$no_index->{module} = delete $no_index->{module}; |
|
3561 |
} |
|
3562 |
return _convert($no_index, $no_index_spec_1_2); |
|
3563 |
} |
|
3564 |
|
|
3565 |
sub _no_index_directory { |
|
3566 |
my ($element, $key, $meta, $version) = @_; |
|
3567 |
return unless $element; |
|
3568 |
|
|
3569 |
# cleanup wrong format |
|
3570 |
if ( ! ref $element ) { |
|
3571 |
my $item = $element; |
|
3572 |
$element = { directory => [ $item ], file => [ $item ] }; |
|
3573 |
} |
|
3574 |
elsif ( ref $element eq 'ARRAY' ) { |
|
3575 |
my $list = $element; |
|
3576 |
$element = { directory => [ @$list ], file => [ @$list ] }; |
|
3577 |
} |
|
3578 |
|
|
3579 |
if ( exists $element->{dir} ) { |
|
3580 |
$element->{directory} = delete $element->{dir}; |
|
3581 |
} |
|
3582 |
# common mistake: files -> file |
|
3583 |
if ( exists $element->{files} ) { |
|
3584 |
$element->{file} = delete $element->{file}; |
|
3585 |
} |
|
3586 |
# common mistake: modules -> module |
|
3587 |
if ( exists $element->{modules} ) { |
|
3588 |
$element->{module} = delete $element->{module}; |
|
3589 |
} |
|
3590 |
my $spec = $version == 2 ? $no_index_spec_2 : $no_index_spec_1_3; |
|
3591 |
return _convert($element, $spec); |
|
3592 |
} |
|
3593 |
|
|
3594 |
sub _is_module_name { |
|
3595 |
my $mod = shift; |
|
3596 |
return unless defined $mod && length $mod; |
|
3597 |
return $mod =~ m{^[A-Za-z][A-Za-z0-9_]*(?:::[A-Za-z0-9_]+)*$}; |
|
3598 |
} |
|
3599 |
|
|
3600 |
sub _clean_version { |
|
3601 |
my ($element, $key, $meta, $to_version) = @_; |
|
3602 |
return 0 if ! defined $element; |
|
3603 |
|
|
3604 |
$element =~ s{^\s*}{}; |
|
3605 |
$element =~ s{\s*$}{}; |
|
3606 |
$element =~ s{^\.}{0.}; |
|
3607 |
|
|
3608 |
return 0 if ! length $element; |
|
3609 |
return 0 if ( $element eq 'undef' || $element eq '<undef>' ); |
|
3610 |
|
|
3611 |
my $v = eval { version->new($element) }; |
|
3612 |
# XXX check defined $v and not just $v because version objects leak memory |
|
3613 |
# in boolean context -- dagolden, 2012-02-03 |
|
3614 |
if ( defined $v ) { |
|
3615 |
return $v->is_qv ? $v->normal : $element; |
|
3616 |
} |
|
3617 |
else { |
|
3618 |
return 0; |
|
3619 |
} |
|
3620 |
} |
|
3621 |
|
|
3622 |
sub _bad_version_hook { |
|
3623 |
my ($v) = @_; |
|
3624 |
$v =~ s{[a-z]+$}{}; # strip trailing alphabetics |
|
3625 |
my $vobj = eval { version->parse($v) }; |
|
3626 |
return defined($vobj) ? $vobj : version->parse(0); # or give up |
|
3627 |
} |
|
3628 |
|
|
3629 |
sub _version_map { |
|
3630 |
my ($element) = @_; |
|
3631 |
return unless defined $element; |
|
3632 |
if ( ref $element eq 'HASH' ) { |
|
3633 |
# XXX turn this into CPAN::Meta::Requirements with bad version hook |
|
3634 |
# and then turn it back into a hash |
|
3635 |
my $new_map = CPAN::Meta::Requirements->new( |
|
3636 |
{ bad_version_hook => sub { version->new(0) } } # punt |
|
3637 |
); |
|
3638 |
while ( my ($k,$v) = each %$element ) { |
|
3639 |
next unless _is_module_name($k); |
|
3640 |
if ( !defined($v) || !length($v) || $v eq 'undef' || $v eq '<undef>' ) { |
|
3641 |
$v = 0; |
|
3642 |
} |
|
3643 |
# some weird, old META have bad yml with module => module |
|
3644 |
# so check if value is like a module name and not like a version |
|
3645 |
if ( _is_module_name($v) && ! version::is_lax($v) ) { |
|
3646 |
$new_map->add_minimum($k => 0); |
|
3647 |
$new_map->add_minimum($v => 0); |
|
3648 |
} |
|
3649 |
$new_map->add_string_requirement($k => $v); |
|
3650 |
} |
|
3651 |
return $new_map->as_string_hash; |
|
3652 |
} |
|
3653 |
elsif ( ref $element eq 'ARRAY' ) { |
|
3654 |
my $hashref = { map { $_ => 0 } @$element }; |
|
3655 |
return _version_map($hashref); # cleanup any weird stuff |
|
3656 |
} |
|
3657 |
elsif ( ref $element eq '' && length $element ) { |
|
3658 |
return { $element => 0 } |
|
3659 |
} |
|
3660 |
return; |
|
3661 |
} |
|
3662 |
|
|
3663 |
sub _prereqs_from_1 { |
|
3664 |
my (undef, undef, $meta) = @_; |
|
3665 |
my $prereqs = {}; |
|
3666 |
for my $phase ( qw/build configure/ ) { |
|
3667 |
my $key = "${phase}_requires"; |
|
3668 |
$prereqs->{$phase}{requires} = _version_map($meta->{$key}) |
|
3669 |
if $meta->{$key}; |
|
3670 |
} |
|
3671 |
for my $rel ( qw/requires recommends conflicts/ ) { |
|
3672 |
$prereqs->{runtime}{$rel} = _version_map($meta->{$rel}) |
|
3673 |
if $meta->{$rel}; |
|
3674 |
} |
|
3675 |
return $prereqs; |
|
3676 |
} |
|
3677 |
|
|
3678 |
my $prereqs_spec = { |
|
3679 |
configure => \&_prereqs_rel, |
|
3680 |
build => \&_prereqs_rel, |
|
3681 |
test => \&_prereqs_rel, |
|
3682 |
runtime => \&_prereqs_rel, |
|
3683 |
develop => \&_prereqs_rel, |
|
3684 |
':custom' => \&_prefix_custom, |
|
3685 |
}; |
|
3686 |
|
|
3687 |
my $relation_spec = { |
|
3688 |
requires => \&_version_map, |
|
3689 |
recommends => \&_version_map, |
|
3690 |
suggests => \&_version_map, |
|
3691 |
conflicts => \&_version_map, |
|
3692 |
':custom' => \&_prefix_custom, |
|
3693 |
}; |
|
3694 |
|
|
3695 |
sub _cleanup_prereqs { |
|
3696 |
my ($prereqs, $key, $meta, $to_version) = @_; |
|
3697 |
return unless $prereqs && ref $prereqs eq 'HASH'; |
|
3698 |
return _convert( $prereqs, $prereqs_spec, $to_version ); |
|
3699 |
} |
|
3700 |
|
|
3701 |
sub _prereqs_rel { |
|
3702 |
my ($relation, $key, $meta, $to_version) = @_; |
|
3703 |
return unless $relation && ref $relation eq 'HASH'; |
|
3704 |
return _convert( $relation, $relation_spec, $to_version ); |
|
3705 |
} |
|
3706 |
|
|
3707 |
|
|
3708 |
BEGIN { |
|
3709 |
my @old_prereqs = qw( |
|
3710 |
requires |
|
3711 |
configure_requires |
|
3712 |
recommends |
|
3713 |
conflicts |
|
3714 |
); |
|
3715 |
|
|
3716 |
for ( @old_prereqs ) { |
|
3717 |
my $sub = "_get_$_"; |
|
3718 |
my ($phase,$type) = split qr/_/, $_; |
|
3719 |
if ( ! defined $type ) { |
|
3720 |
$type = $phase; |
|
3721 |
$phase = 'runtime'; |
|
3722 |
} |
|
3723 |
no strict 'refs'; |
|
3724 |
*{$sub} = sub { _extract_prereqs($_[2]->{prereqs},$phase,$type) }; |
|
3725 |
} |
|
3726 |
} |
|
3727 |
|
|
3728 |
sub _get_build_requires { |
|
3729 |
my ($data, $key, $meta) = @_; |
|
3730 |
|
|
3731 |
my $test_h = _extract_prereqs($_[2]->{prereqs}, qw(test requires)) || {}; |
|
3732 |
my $build_h = _extract_prereqs($_[2]->{prereqs}, qw(build requires)) || {}; |
|
3733 |
|
|
3734 |
my $test_req = CPAN::Meta::Requirements->from_string_hash($test_h); |
|
3735 |
my $build_req = CPAN::Meta::Requirements->from_string_hash($build_h); |
|
3736 |
|
|
3737 |
$test_req->add_requirements($build_req)->as_string_hash; |
|
3738 |
} |
|
3739 |
|
|
3740 |
sub _extract_prereqs { |
|
3741 |
my ($prereqs, $phase, $type) = @_; |
|
3742 |
return unless ref $prereqs eq 'HASH'; |
|
3743 |
return scalar _version_map($prereqs->{$phase}{$type}); |
|
3744 |
} |
|
3745 |
|
|
3746 |
sub _downgrade_optional_features { |
|
3747 |
my (undef, undef, $meta) = @_; |
|
3748 |
return unless exists $meta->{optional_features}; |
|
3749 |
my $origin = $meta->{optional_features}; |
|
3750 |
my $features = {}; |
|
3751 |
for my $name ( keys %$origin ) { |
|
3752 |
$features->{$name} = { |
|
3753 |
description => $origin->{$name}{description}, |
|
3754 |
requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','requires'), |
|
3755 |
configure_requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','configure_requires'), |
|
3756 |
build_requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','build_requires'), |
|
3757 |
recommends => _extract_prereqs($origin->{$name}{prereqs},'runtime','recommends'), |
|
3758 |
conflicts => _extract_prereqs($origin->{$name}{prereqs},'runtime','conflicts'), |
|
3759 |
}; |
|
3760 |
for my $k (keys %{$features->{$name}} ) { |
|
3761 |
delete $features->{$name}{$k} unless defined $features->{$name}{$k}; |
|
3762 |
} |
|
3763 |
} |
|
3764 |
return $features; |
|
3765 |
} |
|
3766 |
|
|
3767 |
sub _upgrade_optional_features { |
|
3768 |
my (undef, undef, $meta) = @_; |
|
3769 |
return unless exists $meta->{optional_features}; |
|
3770 |
my $origin = $meta->{optional_features}; |
|
3771 |
my $features = {}; |
|
3772 |
for my $name ( keys %$origin ) { |
|
3773 |
$features->{$name} = { |
|
3774 |
description => $origin->{$name}{description}, |
|
3775 |
prereqs => _prereqs_from_1(undef, undef, $origin->{$name}), |
|
3776 |
}; |
|
3777 |
delete $features->{$name}{prereqs}{configure}; |
|
3778 |
} |
|
3779 |
return $features; |
|
3780 |
} |
|
3781 |
|
|
3782 |
my $optional_features_2_spec = { |
|
3783 |
description => \&_keep, |
|
3784 |
prereqs => \&_cleanup_prereqs, |
|
3785 |
':custom' => \&_prefix_custom, |
|
3786 |
}; |
|
3787 |
|
|
3788 |
sub _feature_2 { |
|
3789 |
my ($element, $key, $meta, $to_version) = @_; |
|
3790 |
return unless $element && ref $element eq 'HASH'; |
|
3791 |
_convert( $element, $optional_features_2_spec, $to_version ); |
|
3792 |
} |
|
3793 |
|
|
3794 |
sub _cleanup_optional_features_2 { |
|
3795 |
my ($element, $key, $meta, $to_version) = @_; |
|
3796 |
return unless $element && ref $element eq 'HASH'; |
|
3797 |
my $new_data = {}; |
|
3798 |
for my $k ( keys %$element ) { |
|
3799 |
$new_data->{$k} = _feature_2( $element->{$k}, $k, $meta, $to_version ); |
|
3800 |
} |
|
3801 |
return unless keys %$new_data; |
|
3802 |
return $new_data; |
|
3803 |
} |
|
3804 |
|
|
3805 |
sub _optional_features_1_4 { |
|
3806 |
my ($element) = @_; |
|
3807 |
return unless $element; |
|
3808 |
$element = _optional_features_as_map($element); |
|
3809 |
for my $name ( keys %$element ) { |
|
3810 |
for my $drop ( qw/requires_packages requires_os excluded_os/ ) { |
|
3811 |
delete $element->{$name}{$drop}; |
|
3812 |
} |
|
3813 |
} |
|
3814 |
return $element; |
|
3815 |
} |
|
3816 |
|
|
3817 |
sub _optional_features_as_map { |
|
3818 |
my ($element) = @_; |
|
3819 |
return unless $element; |
|
3820 |
if ( ref $element eq 'ARRAY' ) { |
|
3821 |
my %map; |
|
3822 |
for my $feature ( @$element ) { |
|
3823 |
my (@parts) = %$feature; |
|
3824 |
$map{$parts[0]} = $parts[1]; |
|
3825 |
} |
|
3826 |
$element = \%map; |
|
3827 |
} |
|
3828 |
return $element; |
|
3829 |
} |
|
3830 |
|
|
3831 |
sub _is_urlish { defined $_[0] && $_[0] =~ m{\A[-+.a-z0-9]+:.+}i } |
|
3832 |
|
|
3833 |
sub _url_or_drop { |
|
3834 |
my ($element) = @_; |
|
3835 |
return $element if _is_urlish($element); |
|
3836 |
return; |
|
3837 |
} |
|
3838 |
|
|
3839 |
sub _url_list { |
|
3840 |
my ($element) = @_; |
|
3841 |
return unless $element; |
|
3842 |
$element = _listify( $element ); |
|
3843 |
$element = [ grep { _is_urlish($_) } @$element ]; |
|
3844 |
return unless @$element; |
|
3845 |
return $element; |
|
3846 |
} |
|
3847 |
|
|
3848 |
sub _author_list { |
|
3849 |
my ($element) = @_; |
|
3850 |
return [ 'unknown' ] unless $element; |
|
3851 |
$element = _listify( $element ); |
|
3852 |
$element = [ map { defined $_ && length $_ ? $_ : 'unknown' } @$element ]; |
|
3853 |
return [ 'unknown' ] unless @$element; |
|
3854 |
return $element; |
|
3855 |
} |
|
3856 |
|
|
3857 |
my $resource2_upgrade = { |
|
3858 |
license => sub { return _is_urlish($_[0]) ? _listify( $_[0] ) : undef }, |
|
3859 |
homepage => \&_url_or_drop, |
|
3860 |
bugtracker => sub { |
|
3861 |
my ($item) = @_; |
|
3862 |
return unless $item; |
|
3863 |
if ( $item =~ m{^mailto:(.*)$} ) { return { mailto => $1 } } |
|
3864 |
elsif( _is_urlish($item) ) { return { web => $item } } |
|
3865 |
else { return } |
|
3866 |
}, |
|
3867 |
repository => sub { return _is_urlish($_[0]) ? { url => $_[0] } : undef }, |
|
3868 |
':custom' => \&_prefix_custom, |
|
3869 |
}; |
|
3870 |
|
|
3871 |
sub _upgrade_resources_2 { |
|
3872 |
my (undef, undef, $meta, $version) = @_; |
|
3873 |
return unless exists $meta->{resources}; |
|
3874 |
return _convert($meta->{resources}, $resource2_upgrade); |
|
3875 |
} |
|
3876 |
|
|
3877 |
my $bugtracker2_spec = { |
|
3878 |
web => \&_url_or_drop, |
|
3879 |
mailto => \&_keep, |
|
3880 |
':custom' => \&_prefix_custom, |
|
3881 |
}; |
|
3882 |
|
|
3883 |
sub _repo_type { |
|
3884 |
my ($element, $key, $meta, $to_version) = @_; |
|
3885 |
return $element if defined $element; |
|
3886 |
return unless exists $meta->{url}; |
|
3887 |
my $repo_url = $meta->{url}; |
|
3888 |
for my $type ( qw/git svn/ ) { |
|
3889 |
return $type if $repo_url =~ m{\A$type}; |
|
3890 |
} |
|
3891 |
return; |
|
3892 |
} |
|
3893 |
|
|
3894 |
my $repository2_spec = { |
|
3895 |
web => \&_url_or_drop, |
|
3896 |
url => \&_url_or_drop, |
|
3897 |
type => \&_repo_type, |
|
3898 |
':custom' => \&_prefix_custom, |
|
3899 |
}; |
|
3900 |
|
|
3901 |
my $resources2_cleanup = { |
|
3902 |
license => \&_url_list, |
|
3903 |
homepage => \&_url_or_drop, |
|
3904 |
bugtracker => sub { ref $_[0] ? _convert( $_[0], $bugtracker2_spec ) : undef }, |
|
3905 |
repository => sub { my $data = shift; ref $data ? _convert( $data, $repository2_spec ) : undef }, |
|
3906 |
':custom' => \&_prefix_custom, |
|
3907 |
}; |
|
3908 |
|
|
3909 |
sub _cleanup_resources_2 { |
|
3910 |
my ($resources, $key, $meta, $to_version) = @_; |
|
3911 |
return unless $resources && ref $resources eq 'HASH'; |
|
3912 |
return _convert($resources, $resources2_cleanup, $to_version); |
|
3913 |
} |
|
3914 |
|
|
3915 |
my $resource1_spec = { |
|
3916 |
license => \&_url_or_drop, |
|
3917 |
homepage => \&_url_or_drop, |
|
3918 |
bugtracker => \&_url_or_drop, |
|
3919 |
repository => \&_url_or_drop, |
|
3920 |
':custom' => \&_keep, |
|
3921 |
}; |
|
3922 |
|
|
3923 |
sub _resources_1_3 { |
|
3924 |
my (undef, undef, $meta, $version) = @_; |
|
3925 |
return unless exists $meta->{resources}; |
|
3926 |
return _convert($meta->{resources}, $resource1_spec); |
|
3927 |
} |
|
3928 |
|
|
3929 |
*_resources_1_4 = *_resources_1_3; |
|
3930 |
|
|
3931 |
sub _resources_1_2 { |
|
3932 |
my (undef, undef, $meta) = @_; |
|
3933 |
my $resources = $meta->{resources} || {}; |
|
3934 |
if ( $meta->{license_url} && ! $resources->{license} ) { |
|
3935 |
$resources->{license} = $meta->license_url |
|
3936 |
if _is_urlish($meta->{license_url}); |
|
3937 |
} |
|
3938 |
return unless keys %$resources; |
|
3939 |
return _convert($resources, $resource1_spec); |
|
3940 |
} |
|
3941 |
|
|
3942 |
my $resource_downgrade_spec = { |
|
3943 |
license => sub { return ref $_[0] ? $_[0]->[0] : $_[0] }, |
|
3944 |
homepage => \&_url_or_drop, |
|
3945 |
bugtracker => sub { return $_[0]->{web} }, |
|
3946 |
repository => sub { return $_[0]->{url} || $_[0]->{web} }, |
|
3947 |
':custom' => \&_ucfirst_custom, |
|
3948 |
}; |
|
3949 |
|
|
3950 |
sub _downgrade_resources { |
|
3951 |
my (undef, undef, $meta, $version) = @_; |
|
3952 |
return unless exists $meta->{resources}; |
|
3953 |
return _convert($meta->{resources}, $resource_downgrade_spec); |
|
3954 |
} |
|
3955 |
|
|
3956 |
sub _release_status { |
|
3957 |
my ($element, undef, $meta) = @_; |
|
3958 |
return $element if $element && $element =~ m{\A(?:stable|testing|unstable)\z}; |
|
3959 |
return _release_status_from_version(undef, undef, $meta); |
|
3960 |
} |
|
3961 |
|
|
3962 |
sub _release_status_from_version { |
|
3963 |
my (undef, undef, $meta) = @_; |
|
3964 |
my $version = $meta->{version} || ''; |
|
3965 |
return ( $version =~ /_/ ) ? 'testing' : 'stable'; |
|
3966 |
} |
|
3967 |
|
|
3968 |
my $provides_spec = { |
|
3969 |
file => \&_keep, |
|
3970 |
version => \&_clean_version, |
|
3971 |
}; |
|
3972 |
|
|
3973 |
my $provides_spec_2 = { |
|
3974 |
file => \&_keep, |
|
3975 |
version => \&_clean_version, |
|
3976 |
':custom' => \&_prefix_custom, |
|
3977 |
}; |
|
3978 |
|
|
3979 |
sub _provides { |
|
3980 |
my ($element, $key, $meta, $to_version) = @_; |
|
3981 |
return unless defined $element && ref $element eq 'HASH'; |
|
3982 |
my $spec = $to_version == 2 ? $provides_spec_2 : $provides_spec; |
|
3983 |
my $new_data = {}; |
|
3984 |
for my $k ( keys %$element ) { |
|
3985 |
$new_data->{$k} = _convert($element->{$k}, $spec, $to_version); |
|
3986 |
} |
|
3987 |
return $new_data; |
|
3988 |
} |
|
3989 |
|
|
3990 |
sub _convert { |
|
3991 |
my ($data, $spec, $to_version) = @_; |
|
3992 |
|
|
3993 |
my $new_data = {}; |
|
3994 |
for my $key ( keys %$spec ) { |
|
3995 |
next if $key eq ':custom' || $key eq ':drop'; |
|
3996 |
next unless my $fcn = $spec->{$key}; |
|
3997 |
die "spec for '$key' is not a coderef" |
|
3998 |
unless ref $fcn && ref $fcn eq 'CODE'; |
|
3999 |
my $new_value = $fcn->($data->{$key}, $key, $data, $to_version); |
|
4000 |
$new_data->{$key} = $new_value if defined $new_value; |
|
4001 |
} |
|
4002 |
|
|
4003 |
my $drop_list = $spec->{':drop'}; |
|
4004 |
my $customizer = $spec->{':custom'} || \&_keep; |
|
4005 |
|
|
4006 |
for my $key ( keys %$data ) { |
|
4007 |
next if $drop_list && grep { $key eq $_ } @$drop_list; |
|
4008 |
next if exists $spec->{$key}; # we handled it |
|
4009 |
$new_data->{ $customizer->($key) } = $data->{$key}; |
|
4010 |
} |
|
4011 |
|
|
4012 |
return $new_data; |
|
4013 |
} |
|
4014 |
|
|
4015 |
#--------------------------------------------------------------------------# |
|
4016 |
# define converters for each conversion |
|
4017 |
#--------------------------------------------------------------------------# |
|
4018 |
|
|
4019 |
# each converts from prior version |
|
4020 |
# special ":custom" field is used for keys not recognized in spec |
|
4021 |
my %up_convert = ( |
|
4022 |
'2-from-1.4' => { |
|
4023 |
# PRIOR MANDATORY |
|
4024 |
'abstract' => \&_keep_or_unknown, |
|
4025 |
'author' => \&_author_list, |
|
4026 |
'generated_by' => \&_generated_by, |
|
4027 |
'license' => \&_license_2, |
|
4028 |
'meta-spec' => \&_change_meta_spec, |
|
4029 |
'name' => \&_keep, |
|
4030 |
'version' => \&_keep, |
|
4031 |
# CHANGED TO MANDATORY |
|
4032 |
'dynamic_config' => \&_keep_or_one, |
|
4033 |
# ADDED MANDATORY |
|
4034 |
'release_status' => \&_release_status_from_version, |
|
4035 |
# PRIOR OPTIONAL |
|
4036 |
'keywords' => \&_keep, |
|
4037 |
'no_index' => \&_no_index_directory, |
|
4038 |
'optional_features' => \&_upgrade_optional_features, |
|
4039 |
'provides' => \&_provides, |
|
4040 |
'resources' => \&_upgrade_resources_2, |
|
4041 |
# ADDED OPTIONAL |
|
4042 |
'description' => \&_keep, |
|
4043 |
'prereqs' => \&_prereqs_from_1, |
|
4044 |
|
|
4045 |
# drop these deprecated fields, but only after we convert |
|
4046 |
':drop' => [ qw( |
|
4047 |
build_requires |
|
4048 |
configure_requires |
|
4049 |
conflicts |
|
4050 |
distribution_type |
|
4051 |
license_url |
|
4052 |
private |
|
4053 |
recommends |
|
4054 |
requires |
|
4055 |
) ], |
|
4056 |
|
|
4057 |
# other random keys need x_ prefixing |
|
4058 |
':custom' => \&_prefix_custom, |
|
4059 |
}, |
|
4060 |
'1.4-from-1.3' => { |
|
4061 |
# PRIOR MANDATORY |
|
4062 |
'abstract' => \&_keep_or_unknown, |
|
4063 |
'author' => \&_author_list, |
|
4064 |
'generated_by' => \&_generated_by, |
|
4065 |
'license' => \&_license_1, |
|
4066 |
'meta-spec' => \&_change_meta_spec, |
|
4067 |
'name' => \&_keep, |
|
4068 |
'version' => \&_keep, |
|
4069 |
# PRIOR OPTIONAL |
|
4070 |
'build_requires' => \&_version_map, |
|
4071 |
'conflicts' => \&_version_map, |
|
4072 |
'distribution_type' => \&_keep, |
|
4073 |
'dynamic_config' => \&_keep_or_one, |
|
4074 |
'keywords' => \&_keep, |
|
4075 |
'no_index' => \&_no_index_directory, |
|
4076 |
'optional_features' => \&_optional_features_1_4, |
|
4077 |
'provides' => \&_provides, |
|
4078 |
'recommends' => \&_version_map, |
|
4079 |
'requires' => \&_version_map, |
|
4080 |
'resources' => \&_resources_1_4, |
|
4081 |
# ADDED OPTIONAL |
|
4082 |
'configure_requires' => \&_keep, |
|
4083 |
|
|
4084 |
# drop these deprecated fields, but only after we convert |
|
4085 |
':drop' => [ qw( |
|
4086 |
license_url |
|
4087 |
private |
|
4088 |
)], |
|
4089 |
|
|
4090 |
# other random keys are OK if already valid |
|
4091 |
':custom' => \&_keep |
|
4092 |
}, |
|
4093 |
'1.3-from-1.2' => { |
|
4094 |
# PRIOR MANDATORY |
|
4095 |
'abstract' => \&_keep_or_unknown, |
|
4096 |
'author' => \&_author_list, |
|
4097 |
'generated_by' => \&_generated_by, |
|
4098 |
'license' => \&_license_1, |
|
4099 |
'meta-spec' => \&_change_meta_spec, |
|
4100 |
'name' => \&_keep, |
|
4101 |
'version' => \&_keep, |
|
4102 |
# PRIOR OPTIONAL |
|
4103 |
'build_requires' => \&_version_map, |
|
4104 |
'conflicts' => \&_version_map, |
|
4105 |
'distribution_type' => \&_keep, |
|
4106 |
'dynamic_config' => \&_keep_or_one, |
|
4107 |
'keywords' => \&_keep, |
|
4108 |
'no_index' => \&_no_index_directory, |
|
4109 |
'optional_features' => \&_optional_features_as_map, |
|
4110 |
'provides' => \&_provides, |
|
4111 |
'recommends' => \&_version_map, |
|
4112 |
'requires' => \&_version_map, |
|
4113 |
'resources' => \&_resources_1_3, |
|
4114 |
|
|
4115 |
# drop these deprecated fields, but only after we convert |
|
4116 |
':drop' => [ qw( |
|
4117 |
license_url |
|
4118 |
private |
|
4119 |
)], |
|
4120 |
|
|
4121 |
# other random keys are OK if already valid |
|
4122 |
':custom' => \&_keep |
|
4123 |
}, |
|
4124 |
'1.2-from-1.1' => { |
|
4125 |
# PRIOR MANDATORY |
|
4126 |
'version' => \&_keep, |
|
4127 |
# CHANGED TO MANDATORY |
|
4128 |
'license' => \&_license_1, |
|
4129 |
'name' => \&_keep, |
|
4130 |
'generated_by' => \&_generated_by, |
|
4131 |
# ADDED MANDATORY |
|
4132 |
'abstract' => \&_keep_or_unknown, |
|
4133 |
'author' => \&_author_list, |
|
4134 |
'meta-spec' => \&_change_meta_spec, |
|
4135 |
# PRIOR OPTIONAL |
|
4136 |
'build_requires' => \&_version_map, |
|
4137 |
'conflicts' => \&_version_map, |
|
4138 |
'distribution_type' => \&_keep, |
|
4139 |
'dynamic_config' => \&_keep_or_one, |
|
4140 |
'recommends' => \&_version_map, |
|
4141 |
'requires' => \&_version_map, |
|
4142 |
# ADDED OPTIONAL |
|
4143 |
'keywords' => \&_keep, |
|
4144 |
'no_index' => \&_no_index_1_2, |
|
4145 |
'optional_features' => \&_optional_features_as_map, |
|
4146 |
'provides' => \&_provides, |
|
4147 |
'resources' => \&_resources_1_2, |
|
4148 |
|
|
4149 |
# drop these deprecated fields, but only after we convert |
|
4150 |
':drop' => [ qw( |
|
4151 |
license_url |
|
4152 |
private |
|
4153 |
)], |
|
4154 |
|
|
4155 |
# other random keys are OK if already valid |
|
4156 |
':custom' => \&_keep |
|
4157 |
}, |
|
4158 |
'1.1-from-1.0' => { |
|
4159 |
# CHANGED TO MANDATORY |
|
4160 |
'version' => \&_keep, |
|
4161 |
# IMPLIED MANDATORY |
|
4162 |
'name' => \&_keep, |
|
4163 |
# PRIOR OPTIONAL |
|
4164 |
'build_requires' => \&_version_map, |
|
4165 |
'conflicts' => \&_version_map, |
|
4166 |
'distribution_type' => \&_keep, |
|
4167 |
'dynamic_config' => \&_keep_or_one, |
|
4168 |
'generated_by' => \&_generated_by, |
|
4169 |
'license' => \&_license_1, |
|
4170 |
'recommends' => \&_version_map, |
|
4171 |
'requires' => \&_version_map, |
|
4172 |
# ADDED OPTIONAL |
|
4173 |
'license_url' => \&_url_or_drop, |
|
4174 |
'private' => \&_keep, |
|
4175 |
|
|
4176 |
# other random keys are OK if already valid |
|
4177 |
':custom' => \&_keep |
|
4178 |
}, |
|
4179 |
); |
|
4180 |
|
|
4181 |
my %down_convert = ( |
|
4182 |
'1.4-from-2' => { |
|
4183 |
# MANDATORY |
|
4184 |
'abstract' => \&_keep_or_unknown, |
|
4185 |
'author' => \&_author_list, |
|
4186 |
'generated_by' => \&_generated_by, |
|
4187 |
'license' => \&_downgrade_license, |
|
4188 |
'meta-spec' => \&_change_meta_spec, |
|
4189 |
'name' => \&_keep, |
|
4190 |
'version' => \&_keep, |
|
4191 |
# OPTIONAL |
|
4192 |
'build_requires' => \&_get_build_requires, |
|
4193 |
'configure_requires' => \&_get_configure_requires, |
|
4194 |
'conflicts' => \&_get_conflicts, |
|
4195 |
'distribution_type' => \&_keep, |
|
4196 |
'dynamic_config' => \&_keep_or_one, |
|
4197 |
'keywords' => \&_keep, |
|
4198 |
'no_index' => \&_no_index_directory, |
|
4199 |
'optional_features' => \&_downgrade_optional_features, |
|
4200 |
'provides' => \&_provides, |
|
4201 |
'recommends' => \&_get_recommends, |
|
4202 |
'requires' => \&_get_requires, |
|
4203 |
'resources' => \&_downgrade_resources, |
|
4204 |
|
|
4205 |
# drop these unsupported fields (after conversion) |
|
4206 |
':drop' => [ qw( |
|
4207 |
description |
|
4208 |
prereqs |
|
4209 |
release_status |
|
4210 |
)], |
|
4211 |
|
|
4212 |
# custom keys will be left unchanged |
|
4213 |
':custom' => \&_keep |
|
4214 |
}, |
|
4215 |
'1.3-from-1.4' => { |
|
4216 |
# MANDATORY |
|
4217 |
'abstract' => \&_keep_or_unknown, |
|
4218 |
'author' => \&_author_list, |
|
4219 |
'generated_by' => \&_generated_by, |
|
4220 |
'license' => \&_license_1, |
|
4221 |
'meta-spec' => \&_change_meta_spec, |
|
4222 |
'name' => \&_keep, |
|
4223 |
'version' => \&_keep, |
|
4224 |
# OPTIONAL |
|
4225 |
'build_requires' => \&_version_map, |
|
4226 |
'conflicts' => \&_version_map, |
|
4227 |
'distribution_type' => \&_keep, |
|
4228 |
'dynamic_config' => \&_keep_or_one, |
|
4229 |
'keywords' => \&_keep, |
|
4230 |
'no_index' => \&_no_index_directory, |
|
4231 |
'optional_features' => \&_optional_features_as_map, |
|
4232 |
'provides' => \&_provides, |
|
4233 |
'recommends' => \&_version_map, |
|
4234 |
'requires' => \&_version_map, |
|
4235 |
'resources' => \&_resources_1_3, |
|
4236 |
|
|
4237 |
# drop these unsupported fields, but only after we convert |
|
4238 |
':drop' => [ qw( |
|
4239 |
configure_requires |
|
4240 |
)], |
|
4241 |
|
|
4242 |
# other random keys are OK if already valid |
|
4243 |
':custom' => \&_keep, |
|
4244 |
}, |
|
4245 |
'1.2-from-1.3' => { |
|
4246 |
# MANDATORY |
|
4247 |
'abstract' => \&_keep_or_unknown, |
|
4248 |
'author' => \&_author_list, |
|
4249 |
'generated_by' => \&_generated_by, |
|
4250 |
'license' => \&_license_1, |
|
4251 |
'meta-spec' => \&_change_meta_spec, |
|
4252 |
'name' => \&_keep, |
|
4253 |
'version' => \&_keep, |
|
4254 |
# OPTIONAL |
|
4255 |
'build_requires' => \&_version_map, |
|
4256 |
'conflicts' => \&_version_map, |
|
4257 |
'distribution_type' => \&_keep, |
|
4258 |
'dynamic_config' => \&_keep_or_one, |
|
4259 |
'keywords' => \&_keep, |
|
4260 |
'no_index' => \&_no_index_1_2, |
|
4261 |
'optional_features' => \&_optional_features_as_map, |
|
4262 |
'provides' => \&_provides, |
|
4263 |
'recommends' => \&_version_map, |
|
4264 |
'requires' => \&_version_map, |
|
4265 |
'resources' => \&_resources_1_3, |
|
4266 |
|
|
4267 |
# other random keys are OK if already valid |
|
4268 |
':custom' => \&_keep, |
|
4269 |
}, |
|
4270 |
'1.1-from-1.2' => { |
|
4271 |
# MANDATORY |
|
4272 |
'version' => \&_keep, |
|
4273 |
# IMPLIED MANDATORY |
|
4274 |
'name' => \&_keep, |
|
4275 |
'meta-spec' => \&_change_meta_spec, |
|
4276 |
# OPTIONAL |
|
4277 |
'build_requires' => \&_version_map, |
|
4278 |
'conflicts' => \&_version_map, |
|
4279 |
'distribution_type' => \&_keep, |
|
4280 |
'dynamic_config' => \&_keep_or_one, |
|
4281 |
'generated_by' => \&_generated_by, |
|
4282 |
'license' => \&_license_1, |
|
4283 |
'private' => \&_keep, |
|
4284 |
'recommends' => \&_version_map, |
|
4285 |
'requires' => \&_version_map, |
|
4286 |
|
|
4287 |
# drop unsupported fields |
|
4288 |
':drop' => [ qw( |
|
4289 |
abstract |
|
4290 |
author |
|
4291 |
provides |
|
4292 |
no_index |
|
4293 |
keywords |
|
4294 |
resources |
|
4295 |
)], |
|
4296 |
|
|
4297 |
# other random keys are OK if already valid |
|
4298 |
':custom' => \&_keep, |
|
4299 |
}, |
|
4300 |
'1.0-from-1.1' => { |
|
4301 |
# IMPLIED MANDATORY |
|
4302 |
'name' => \&_keep, |
|
4303 |
'meta-spec' => \&_change_meta_spec, |
|
4304 |
'version' => \&_keep, |
|
4305 |
# PRIOR OPTIONAL |
|
4306 |
'build_requires' => \&_version_map, |
|
4307 |
'conflicts' => \&_version_map, |
|
4308 |
'distribution_type' => \&_keep, |
|
4309 |
'dynamic_config' => \&_keep_or_one, |
|
4310 |
'generated_by' => \&_generated_by, |
|
4311 |
'license' => \&_license_1, |
|
4312 |
'recommends' => \&_version_map, |
|
4313 |
'requires' => \&_version_map, |
|
4314 |
|
|
4315 |
# other random keys are OK if already valid |
|
4316 |
':custom' => \&_keep, |
|
4317 |
}, |
|
4318 |
); |
|
4319 |
|
|
4320 |
my %cleanup = ( |
|
4321 |
'2' => { |
|
4322 |
# PRIOR MANDATORY |
|
4323 |
'abstract' => \&_keep_or_unknown, |
|
4324 |
'author' => \&_author_list, |
|
4325 |
'generated_by' => \&_generated_by, |
|
4326 |
'license' => \&_license_2, |
|
4327 |
'meta-spec' => \&_change_meta_spec, |
|
4328 |
'name' => \&_keep, |
|
4329 |
'version' => \&_keep, |
|
4330 |
# CHANGED TO MANDATORY |
|
4331 |
'dynamic_config' => \&_keep_or_one, |
|
4332 |
# ADDED MANDATORY |
|
4333 |
'release_status' => \&_release_status, |
|
4334 |
# PRIOR OPTIONAL |
|
4335 |
'keywords' => \&_keep, |
|
4336 |
'no_index' => \&_no_index_directory, |
|
4337 |
'optional_features' => \&_cleanup_optional_features_2, |
|
4338 |
'provides' => \&_provides, |
|
4339 |
'resources' => \&_cleanup_resources_2, |
|
4340 |
# ADDED OPTIONAL |
|
4341 |
'description' => \&_keep, |
|
4342 |
'prereqs' => \&_cleanup_prereqs, |
|
4343 |
|
|
4344 |
# drop these deprecated fields, but only after we convert |
|
4345 |
':drop' => [ qw( |
|
4346 |
build_requires |
|
4347 |
configure_requires |
|
4348 |
conflicts |
|
4349 |
distribution_type |
|
4350 |
license_url |
|
4351 |
private |
|
4352 |
recommends |
|
4353 |
requires |
|
4354 |
) ], |
|
4355 |
|
|
4356 |
# other random keys need x_ prefixing |
|
4357 |
':custom' => \&_prefix_custom, |
|
4358 |
}, |
|
4359 |
'1.4' => { |
|
4360 |
# PRIOR MANDATORY |
|
4361 |
'abstract' => \&_keep_or_unknown, |
|
4362 |
'author' => \&_author_list, |
|
4363 |
'generated_by' => \&_generated_by, |
|
4364 |
'license' => \&_license_1, |
|
4365 |
'meta-spec' => \&_change_meta_spec, |
|
4366 |
'name' => \&_keep, |
|
4367 |
'version' => \&_keep, |
|
4368 |
# PRIOR OPTIONAL |
|
4369 |
'build_requires' => \&_version_map, |
|
4370 |
'conflicts' => \&_version_map, |
|
4371 |
'distribution_type' => \&_keep, |
|
4372 |
'dynamic_config' => \&_keep_or_one, |
|
4373 |
'keywords' => \&_keep, |
|
4374 |
'no_index' => \&_no_index_directory, |
|
4375 |
'optional_features' => \&_optional_features_1_4, |
|
4376 |
'provides' => \&_provides, |
|
4377 |
'recommends' => \&_version_map, |
|
4378 |
'requires' => \&_version_map, |
|
4379 |
'resources' => \&_resources_1_4, |
|
4380 |
# ADDED OPTIONAL |
|
4381 |
'configure_requires' => \&_keep, |
|
4382 |
|
|
4383 |
# other random keys are OK if already valid |
|
4384 |
':custom' => \&_keep |
|
4385 |
}, |
|
4386 |
'1.3' => { |
|
4387 |
# PRIOR MANDATORY |
|
4388 |
'abstract' => \&_keep_or_unknown, |
|
4389 |
'author' => \&_author_list, |
|
4390 |
'generated_by' => \&_generated_by, |
|
4391 |
'license' => \&_license_1, |
|
4392 |
'meta-spec' => \&_change_meta_spec, |
|
4393 |
'name' => \&_keep, |
|
4394 |
'version' => \&_keep, |
|
4395 |
# PRIOR OPTIONAL |
|
4396 |
'build_requires' => \&_version_map, |
|
4397 |
'conflicts' => \&_version_map, |
|
4398 |
'distribution_type' => \&_keep, |
|
4399 |
'dynamic_config' => \&_keep_or_one, |
|
4400 |
'keywords' => \&_keep, |
|
4401 |
'no_index' => \&_no_index_directory, |
|
4402 |
'optional_features' => \&_optional_features_as_map, |
|
4403 |
'provides' => \&_provides, |
|
4404 |
'recommends' => \&_version_map, |
|
4405 |
'requires' => \&_version_map, |
|
4406 |
'resources' => \&_resources_1_3, |
|
4407 |
|
|
4408 |
# other random keys are OK if already valid |
|
4409 |
':custom' => \&_keep |
|
4410 |
}, |
|
4411 |
'1.2' => { |
|
4412 |
# PRIOR MANDATORY |
|
4413 |
'version' => \&_keep, |
|
4414 |
# CHANGED TO MANDATORY |
|
4415 |
'license' => \&_license_1, |
|
4416 |
'name' => \&_keep, |
|
4417 |
'generated_by' => \&_generated_by, |
|
4418 |
# ADDED MANDATORY |
|
4419 |
'abstract' => \&_keep_or_unknown, |
|
4420 |
'author' => \&_author_list, |
|
4421 |
'meta-spec' => \&_change_meta_spec, |
|
4422 |
# PRIOR OPTIONAL |
|
4423 |
'build_requires' => \&_version_map, |
|
4424 |
'conflicts' => \&_version_map, |
|
4425 |
'distribution_type' => \&_keep, |
|
4426 |
'dynamic_config' => \&_keep_or_one, |
|
4427 |
'recommends' => \&_version_map, |
|
4428 |
'requires' => \&_version_map, |
|
4429 |
# ADDED OPTIONAL |
|
4430 |
'keywords' => \&_keep, |
|
4431 |
'no_index' => \&_no_index_1_2, |
|
4432 |
'optional_features' => \&_optional_features_as_map, |
|
4433 |
'provides' => \&_provides, |
|
4434 |
'resources' => \&_resources_1_2, |
|
4435 |
|
|
4436 |
# other random keys are OK if already valid |
|
4437 |
':custom' => \&_keep |
|
4438 |
}, |
|
4439 |
'1.1' => { |
|
4440 |
# CHANGED TO MANDATORY |
|
4441 |
'version' => \&_keep, |
|
4442 |
# IMPLIED MANDATORY |
|
4443 |
'name' => \&_keep, |
|
4444 |
'meta-spec' => \&_change_meta_spec, |
|
4445 |
# PRIOR OPTIONAL |
|
4446 |
'build_requires' => \&_version_map, |
|
4447 |
'conflicts' => \&_version_map, |
|
4448 |
'distribution_type' => \&_keep, |
|
4449 |
'dynamic_config' => \&_keep_or_one, |
|
4450 |
'generated_by' => \&_generated_by, |
|
4451 |
'license' => \&_license_1, |
|
4452 |
'recommends' => \&_version_map, |
|
4453 |
'requires' => \&_version_map, |
|
4454 |
# ADDED OPTIONAL |
|
4455 |
'license_url' => \&_url_or_drop, |
|
4456 |
'private' => \&_keep, |
|
4457 |
|
|
4458 |
# other random keys are OK if already valid |
|
4459 |
':custom' => \&_keep |
|
4460 |
}, |
|
4461 |
'1.0' => { |
|
4462 |
# IMPLIED MANDATORY |
|
4463 |
'name' => \&_keep, |
|
4464 |
'meta-spec' => \&_change_meta_spec, |
|
4465 |
'version' => \&_keep, |
|
4466 |
# IMPLIED OPTIONAL |
|
4467 |
'build_requires' => \&_version_map, |
|
4468 |
'conflicts' => \&_version_map, |
|
4469 |
'distribution_type' => \&_keep, |
|
4470 |
'dynamic_config' => \&_keep_or_one, |
|
4471 |
'generated_by' => \&_generated_by, |
|
4472 |
'license' => \&_license_1, |
|
4473 |
'recommends' => \&_version_map, |
|
4474 |
'requires' => \&_version_map, |
|
4475 |
|
|
4476 |
# other random keys are OK if already valid |
|
4477 |
':custom' => \&_keep, |
|
4478 |
}, |
|
4479 |
); |
|
4480 |
|
|
4481 |
#--------------------------------------------------------------------------# |
|
4482 |
# Code |
|
4483 |
#--------------------------------------------------------------------------# |
|
4484 |
|
|
4485 |
|
|
4486 |
sub new { |
|
4487 |
my ($class,$data) = @_; |
|
4488 |
|
|
4489 |
# create an attributes hash |
|
4490 |
my $self = { |
|
4491 |
'data' => $data, |
|
4492 |
'spec' => $data->{'meta-spec'}{'version'} || "1.0", |
|
4493 |
}; |
|
4494 |
|
|
4495 |
# create the object |
|
4496 |
return bless $self, $class; |
|
4497 |
} |
|
4498 |
|
|
4499 |
|
|
4500 |
sub convert { |
|
4501 |
my ($self, %args) = @_; |
|
4502 |
my $args = { %args }; |
|
4503 |
|
|
4504 |
my $new_version = $args->{version} || $HIGHEST; |
|
4505 |
|
|
4506 |
my ($old_version) = $self->{spec}; |
|
4507 |
my $converted = _dclone($self->{data}); |
|
4508 |
|
|
4509 |
if ( $old_version == $new_version ) { |
|
4510 |
$converted = _convert( $converted, $cleanup{$old_version}, $old_version ); |
|
4511 |
my $cmv = CPAN::Meta::Validator->new( $converted ); |
|
4512 |
unless ( $cmv->is_valid ) { |
|
4513 |
my $errs = join("\n", $cmv->errors); |
|
4514 |
die "Failed to clean-up $old_version metadata. Errors:\n$errs\n"; |
|
4515 |
} |
|
4516 |
return $converted; |
|
4517 |
} |
|
4518 |
elsif ( $old_version > $new_version ) { |
|
4519 |
my @vers = sort { $b <=> $a } keys %known_specs; |
|
4520 |
for my $i ( 0 .. $#vers-1 ) { |
|
4521 |
next if $vers[$i] > $old_version; |
|
4522 |
last if $vers[$i+1] < $new_version; |
|
4523 |
my $spec_string = "$vers[$i+1]-from-$vers[$i]"; |
|
4524 |
$converted = _convert( $converted, $down_convert{$spec_string}, $vers[$i+1] ); |
|
4525 |
my $cmv = CPAN::Meta::Validator->new( $converted ); |
|
4526 |
unless ( $cmv->is_valid ) { |
|
4527 |
my $errs = join("\n", $cmv->errors); |
|
4528 |
die "Failed to downconvert metadata to $vers[$i+1]. Errors:\n$errs\n"; |
|
4529 |
} |
|
4530 |
} |
|
4531 |
return $converted; |
|
4532 |
} |
|
4533 |
else { |
|
4534 |
my @vers = sort { $a <=> $b } keys %known_specs; |
|
4535 |
for my $i ( 0 .. $#vers-1 ) { |
|
4536 |
next if $vers[$i] < $old_version; |
|
4537 |
last if $vers[$i+1] > $new_version; |
|
4538 |
my $spec_string = "$vers[$i+1]-from-$vers[$i]"; |
|
4539 |
$converted = _convert( $converted, $up_convert{$spec_string}, $vers[$i+1] ); |
|
4540 |
my $cmv = CPAN::Meta::Validator->new( $converted ); |
|
4541 |
unless ( $cmv->is_valid ) { |
|
4542 |
my $errs = join("\n", $cmv->errors); |
|
4543 |
die "Failed to upconvert metadata to $vers[$i+1]. Errors:\n$errs\n"; |
|
4544 |
} |
|
4545 |
} |
|
4546 |
return $converted; |
|
4547 |
} |
|
4548 |
} |
|
4549 |
|
|
4550 |
1; |
|
4551 |
|
|
4552 |
# ABSTRACT: Convert CPAN distribution metadata structures |
|
4553 |
|
|
4554 |
|
|
4555 |
|
|
4556 |
|
|
4557 |
__END__ |
|
4558 |
|
|
4559 |
|
|
4560 |
CPAN_META_CONVERTER |
|
4561 | ||
4562 |
$fatpacked{"CPAN/Meta/Feature.pm"} = <<'CPAN_META_FEATURE'; |
|
4563 |
use 5.006; |
|
4564 |
use strict; |
|
4565 |
use warnings; |
|
4566 |
package CPAN::Meta::Feature; |
|
4567 |
our $VERSION = '2.120921'; # VERSION |
|
4568 |
|
|
4569 |
use CPAN::Meta::Prereqs; |
|
4570 |
|
|
4571 |
|
|
4572 |
sub new { |
|
4573 |
my ($class, $identifier, $spec) = @_; |
|
4574 |
|
|
4575 |
my %guts = ( |
|
4576 |
identifier => $identifier, |
|
4577 |
description => $spec->{description}, |
|
4578 |
prereqs => CPAN::Meta::Prereqs->new($spec->{prereqs}), |
|
4579 |
); |
|
4580 |
|
|
4581 |
bless \%guts => $class; |
|
4582 |
} |
|
4583 |
|
|
4584 |
|
|
4585 |
sub identifier { $_[0]{identifier} } |
|
4586 |
|
|
4587 |
|
|
4588 |
sub description { $_[0]{description} } |
|
4589 |
|
|
4590 |
|
|
4591 |
sub prereqs { $_[0]{prereqs} } |
|
4592 |
|
|
4593 |
1; |
|
4594 |
|
|
4595 |
# ABSTRACT: an optional feature provided by a CPAN distribution |
|
4596 |
|
|
4597 |
|
|
4598 |
|
|
4599 |
|
|
4600 |
__END__ |
|
4601 |
|
|
4602 |
|
|
4603 |
|
|
4604 |
CPAN_META_FEATURE |
|
4605 | ||
4606 |
$fatpacked{"CPAN/Meta/History.pm"} = <<'CPAN_META_HISTORY'; |
|
4607 |
# vi:tw=72 |
|
4608 |
use 5.006; |
|
4609 |
use strict; |
|
4610 |
use warnings; |
|
4611 |
package CPAN::Meta::History; |
|
4612 |
our $VERSION = '2.120921'; # VERSION |
|
4613 |
|
|
4614 |
1; |
|
4615 |
|
|
4616 |
# ABSTRACT: history of CPAN Meta Spec changes |
|
4617 |
|
|
4618 |
|
|
4619 |
|
|
4620 |
__END__ |
|
4621 |
=pod |
|
4622 |
|
|
4623 |
CPAN_META_HISTORY |
|
4624 | ||
4625 |
$fatpacked{"CPAN/Meta/Prereqs.pm"} = <<'CPAN_META_PREREQS'; |
|
4626 |
use 5.006; |
|
4627 |
use strict; |
|
4628 |
use warnings; |
|
4629 |
package CPAN::Meta::Prereqs; |
|
4630 |
our $VERSION = '2.120921'; # VERSION |
|
4631 |
|
|
4632 |
|
|
4633 |
use Carp qw(confess); |
|
4634 |
use Scalar::Util qw(blessed); |
|
4635 |
use CPAN::Meta::Requirements 2.121; |
|
4636 |
|
|
4637 |
|
|
4638 |
sub __legal_phases { qw(configure build test runtime develop) } |
|
4639 |
sub __legal_types { qw(requires recommends suggests conflicts) } |
|
4640 |
|
|
4641 |
# expect a prereq spec from META.json -- rjbs, 2010-04-11 |
|
4642 |
sub new { |
|
4643 |
my ($class, $prereq_spec) = @_; |
|
4644 |
$prereq_spec ||= {}; |
|
4645 |
|
|
4646 |
my %is_legal_phase = map {; $_ => 1 } $class->__legal_phases; |
|
4647 |
my %is_legal_type = map {; $_ => 1 } $class->__legal_types; |
|
4648 |
|
|
4649 |
my %guts; |
|
4650 |
PHASE: for my $phase (keys %$prereq_spec) { |
|
4651 |
next PHASE unless $phase =~ /\Ax_/i or $is_legal_phase{$phase}; |
|
4652 |
|
|
4653 |
my $phase_spec = $prereq_spec->{ $phase }; |
|
4654 |
next PHASE unless keys %$phase_spec; |
|
4655 |
|
|
4656 |
TYPE: for my $type (keys %$phase_spec) { |
|
4657 |
next TYPE unless $type =~ /\Ax_/i or $is_legal_type{$type}; |
|
4658 |
|
|
4659 |
my $spec = $phase_spec->{ $type }; |
|
4660 |
|
|
4661 |
next TYPE unless keys %$spec; |
|
4662 |
|
|
4663 |
$guts{prereqs}{$phase}{$type} = CPAN::Meta::Requirements->from_string_hash( |
|
4664 |
$spec |
|
4665 |
); |
|
4666 |
} |
|
4667 |
} |
|
4668 |
|
|
4669 |
return bless \%guts => $class; |
|
4670 |
} |
|
4671 |
|
|
4672 |
|
|
4673 |
sub requirements_for { |
|
4674 |
my ($self, $phase, $type) = @_; |
|
4675 |
|
|
4676 |
confess "requirements_for called without phase" unless defined $phase; |
|
4677 |
confess "requirements_for called without type" unless defined $type; |
|
4678 |
|
|
4679 |
unless ($phase =~ /\Ax_/i or grep { $phase eq $_ } $self->__legal_phases) { |
|
4680 |
confess "requested requirements for unknown phase: $phase"; |
|
4681 |
} |
|
4682 |
|
|
4683 |
unless ($type =~ /\Ax_/i or grep { $type eq $_ } $self->__legal_types) { |
|
4684 |
confess "requested requirements for unknown type: $type"; |
|
4685 |
} |
|
4686 |
|
|
4687 |
my $req = ($self->{prereqs}{$phase}{$type} ||= CPAN::Meta::Requirements->new); |
|
4688 |
|
|
4689 |
$req->finalize if $self->is_finalized; |
|
4690 |
|
|
4691 |
return $req; |
|
4692 |
} |
|
4693 |
|
|
4694 |
|
|
4695 |
sub with_merged_prereqs { |
|
4696 |
my ($self, $other) = @_; |
|
4697 |
|
|
4698 |
my @other = blessed($other) ? $other : @$other; |
|
4699 |
|
|
4700 |
my @prereq_objs = ($self, @other); |
|
4701 |
|
|
4702 |
my %new_arg; |
|
4703 |
|
|
4704 |
for my $phase ($self->__legal_phases) { |
|
4705 |
for my $type ($self->__legal_types) { |
|
4706 |
my $req = CPAN::Meta::Requirements->new; |
|
4707 |
|
|
4708 |
for my $prereq (@prereq_objs) { |
|
4709 |
my $this_req = $prereq->requirements_for($phase, $type); |
|
4710 |
next unless $this_req->required_modules; |
|
4711 |
|
|
4712 |
$req->add_requirements($this_req); |
|
4713 |
} |
|
4714 |
|
|
4715 |
next unless $req->required_modules; |
|
4716 |
|
|
4717 |
$new_arg{ $phase }{ $type } = $req->as_string_hash; |
|
4718 |
} |
|
4719 |
} |
|
4720 |
|
|
4721 |
return (ref $self)->new(\%new_arg); |
|
4722 |
} |
|
4723 |
|
|
4724 |
|
|
4725 |
sub as_string_hash { |
|
4726 |
my ($self) = @_; |
|
4727 |
|
|
4728 |
my %hash; |
|
4729 |
|
|
4730 |
for my $phase ($self->__legal_phases) { |
|
4731 |
for my $type ($self->__legal_types) { |
|
4732 |
my $req = $self->requirements_for($phase, $type); |
|
4733 |
next unless $req->required_modules; |
|
4734 |
|
|
4735 |
$hash{ $phase }{ $type } = $req->as_string_hash; |
|
4736 |
} |
|
4737 |
} |
|
4738 |
|
|
4739 |
return \%hash; |
|
4740 |
} |
|
4741 |
|
|
4742 |
|
|
4743 |
sub is_finalized { $_[0]{finalized} } |
|
4744 |
|
|
4745 |
|
|
4746 |
sub finalize { |
|
4747 |
my ($self) = @_; |
|
4748 |
|
|
4749 |
$self->{finalized} = 1; |
|
4750 |
|
|
4751 |
for my $phase (keys %{ $self->{prereqs} }) { |
|
4752 |
$_->finalize for values %{ $self->{prereqs}{$phase} }; |
|
4753 |
} |
|
4754 |
} |
|
4755 |
|
|
4756 |
|
|
4757 |
sub clone { |
|
4758 |
my ($self) = @_; |
|
4759 |
|
|
4760 |
my $clone = (ref $self)->new( $self->as_string_hash ); |
|
4761 |
} |
|
4762 |
|
|
4763 |
1; |
|
4764 |
|
|
4765 |
# ABSTRACT: a set of distribution prerequisites by phase and type |
|
4766 |
|
|
4767 |
|
|
4768 |
|
|
4769 |
|
|
4770 |
__END__ |
|
4771 |
|
|
4772 |
|
|
4773 |
|
|
4774 |
CPAN_META_PREREQS |
|
4775 | ||
4776 |
$fatpacked{"CPAN/Meta/Requirements.pm"} = <<'CPAN_META_REQUIREMENTS'; |
|
4777 |
use strict; |
|
4778 |
use warnings; |
|
4779 |
package CPAN::Meta::Requirements; |
|
4780 |
our $VERSION = '2.122'; # VERSION |
|
4781 |
# ABSTRACT: a set of version requirements for a CPAN dist |
|
4782 |
|
|
4783 |
|
|
4784 |
use Carp (); |
|
4785 |
use Scalar::Util (); |
|
4786 |
use version 0.77 (); # the ->parse method |
|
4787 |
|
|
4788 |
|
|
4789 |
my @valid_options = qw( bad_version_hook ); |
|
4790 |
|
|
4791 |
sub new { |
|
4792 |
my ($class, $options) = @_; |
|
4793 |
$options ||= {}; |
|
4794 |
Carp::croak "Argument to $class\->new() must be a hash reference" |
|
4795 |
unless ref $options eq 'HASH'; |
|
4796 |
my %self = map {; $_ => $options->{$_}} @valid_options; |
|
4797 |
|
|
4798 |
return bless \%self => $class; |
|
4799 |
} |
|
4800 |
|
|
4801 |
sub _version_object { |
|
4802 |
my ($self, $version) = @_; |
|
4803 |
|
|
4804 |
my $vobj; |
|
4805 |
|
|
4806 |
eval { |
|
4807 |
$vobj = (! defined $version) ? version->parse(0) |
|
4808 |
: (! Scalar::Util::blessed($version)) ? version->parse($version) |
|
4809 |
: $version; |
|
4810 |
}; |
|
4811 |
|
|
4812 |
if ( my $err = $@ ) { |
|
4813 |
my $hook = $self->{bad_version_hook}; |
|
4814 |
$vobj = eval { $hook->($version) } |
|
4815 |
if ref $hook eq 'CODE'; |
|
4816 |
unless (Scalar::Util::blessed($vobj) && $vobj->isa("version")) { |
|
4817 |
$err =~ s{ at .* line \d+.*$}{}; |
|
4818 |
die "Can't convert '$version': $err"; |
|
4819 |
} |
|
4820 |
} |
|
4821 |
|
|
4822 |
# ensure no leading '.' |
|
4823 |
if ( $vobj =~ m{\A\.} ) { |
|
4824 |
$vobj = version->parse("0$vobj"); |
|
4825 |
} |
|
4826 |
|
|
4827 |
# ensure normal v-string form |
|
4828 |
if ( $vobj->is_qv ) { |
|
4829 |
$vobj = version->parse($vobj->normal); |
|
4830 |
} |
|
4831 |
|
|
4832 |
return $vobj; |
|
4833 |
} |
|
4834 |
|
|
4835 |
|
|
4836 |
BEGIN { |
|
4837 |
for my $type (qw(minimum maximum exclusion exact_version)) { |
|
4838 |
my $method = "with_$type"; |
|
4839 |
my $to_add = $type eq 'exact_version' ? $type : "add_$type"; |
|
4840 |
|
|
4841 |
my $code = sub { |
|
4842 |
my ($self, $name, $version) = @_; |
|
4843 |
|
|
4844 |
$version = $self->_version_object( $version ); |
|
4845 |
|
|
4846 |
$self->__modify_entry_for($name, $method, $version); |
|
4847 |
|
|
4848 |
return $self; |
|
4849 |
}; |
|
4850 |
|
|
4851 |
no strict 'refs'; |
|
4852 |
*$to_add = $code; |
|
4853 |
} |
|
4854 |
} |
|
4855 |
|
|
4856 |
|
|
4857 |
sub add_requirements { |
|
4858 |
my ($self, $req) = @_; |
|
4859 |
|
|
4860 |
for my $module ($req->required_modules) { |
|
4861 |
my $modifiers = $req->__entry_for($module)->as_modifiers; |
|
4862 |
for my $modifier (@$modifiers) { |
|
4863 |
my ($method, @args) = @$modifier; |
|
4864 |
$self->$method($module => @args); |
|
4865 |
}; |
|
4866 |
} |
|
4867 |
|
|
4868 |
return $self; |
|
4869 |
} |
|
4870 |
|
|
4871 |
|
|
4872 |
sub accepts_module { |
|
4873 |
my ($self, $module, $version) = @_; |
|
4874 |
|
|
4875 |
$version = $self->_version_object( $version ); |
|
4876 |
|
|
4877 |
return 1 unless my $range = $self->__entry_for($module); |
|
4878 |
return $range->_accepts($version); |
|
4879 |
} |
|
4880 |
|
|
4881 |
|
|
4882 |
sub clear_requirement { |
|
4883 |
my ($self, $module) = @_; |
|
4884 |
|
|
4885 |
return $self unless $self->__entry_for($module); |
|
4886 |
|
|
4887 |
Carp::confess("can't clear requirements on finalized requirements") |
|
4888 |
if $self->is_finalized; |
|
4889 |
|
|
4890 |
delete $self->{requirements}{ $module }; |
|
4891 |
|
|
4892 |
return $self; |
|
4893 |
} |
|
4894 |
|
|
4895 |
|
|
4896 |
sub requirements_for_module { |
|
4897 |
my ($self, $module) = @_; |
|
4898 |
my $entry = $self->__entry_for($module); |
|
4899 |
return unless $entry; |
|
4900 |
return $entry->as_string; |
|
4901 |
} |
|
4902 |
|
|
4903 |
|
|
4904 |
sub required_modules { keys %{ $_[0]{requirements} } } |
|
4905 |
|
|
4906 |
|
|
4907 |
sub clone { |
|
4908 |
my ($self) = @_; |
|
4909 |
my $new = (ref $self)->new; |
|
4910 |
|
|
4911 |
return $new->add_requirements($self); |
|
4912 |
} |
|
4913 |
|
|
4914 |
sub __entry_for { $_[0]{requirements}{ $_[1] } } |
|
4915 |
|
|
4916 |
sub __modify_entry_for { |
|
4917 |
my ($self, $name, $method, $version) = @_; |
|
4918 |
|
|
4919 |
my $fin = $self->is_finalized; |
|
4920 |
my $old = $self->__entry_for($name); |
|
4921 |
|
|
4922 |
Carp::confess("can't add new requirements to finalized requirements") |
|
4923 |
if $fin and not $old; |
|
4924 |
|
|
4925 |
my $new = ($old || 'CPAN::Meta::Requirements::_Range::Range') |
|
4926 |
->$method($version); |
|
4927 |
|
|
4928 |
Carp::confess("can't modify finalized requirements") |
|
4929 |
if $fin and $old->as_string ne $new->as_string; |
|
4930 |
|
|
4931 |
$self->{requirements}{ $name } = $new; |
|
4932 |
} |
|
4933 |
|
|
4934 |
|
|
4935 |
sub is_simple { |
|
4936 |
my ($self) = @_; |
|
4937 |
for my $module ($self->required_modules) { |
|
4938 |
# XXX: This is a complete hack, but also entirely correct. |
|
4939 |
return if $self->__entry_for($module)->as_string =~ /\s/; |
|
4940 |
} |
|
4941 |
|
|
4942 |
return 1; |
|
4943 |
} |
|
4944 |
|
|
4945 |
|
|
4946 |
sub is_finalized { $_[0]{finalized} } |
|
4947 |
|
|
4948 |
|
|
4949 |
sub finalize { $_[0]{finalized} = 1 } |
|
4950 |
|
|
4951 |
|
|
4952 |
sub as_string_hash { |
|
4953 |
my ($self) = @_; |
|
4954 |
|
|
4955 |
my %hash = map {; $_ => $self->{requirements}{$_}->as_string } |
|
4956 |
$self->required_modules; |
|
4957 |
|
|
4958 |
return \%hash; |
|
4959 |
} |
|
4960 |
|
|
4961 |
|
|
4962 |
my %methods_for_op = ( |
|
4963 |
'==' => [ qw(exact_version) ], |
|
4964 |
'!=' => [ qw(add_exclusion) ], |
|
4965 |
'>=' => [ qw(add_minimum) ], |
|
4966 |
'<=' => [ qw(add_maximum) ], |
|
4967 |
'>' => [ qw(add_minimum add_exclusion) ], |
|
4968 |
'<' => [ qw(add_maximum add_exclusion) ], |
|
4969 |
); |
|
4970 |
|
|
4971 |
sub add_string_requirement { |
|
4972 |
my ($self, $module, $req) = @_; |
|
4973 |
|
|
4974 |
Carp::confess("No requirement string provided for $module") |
|
4975 |
unless defined $req && length $req; |
|
4976 |
|
|
4977 |
my @parts = split qr{\s*,\s*}, $req; |
|
4978 |
|
|
4979 |
|
|
4980 |
for my $part (@parts) { |
|
4981 |
my ($op, $ver) = $part =~ m{\A\s*(==|>=|>|<=|<|!=)\s*(.*)\z}; |
|
4982 |
|
|
4983 |
if (! defined $op) { |
|
4984 |
$self->add_minimum($module => $part); |
|
4985 |
} else { |
|
4986 |
Carp::confess("illegal requirement string: $req") |
|
4987 |
unless my $methods = $methods_for_op{ $op }; |
|
4988 |
|
|
4989 |
$self->$_($module => $ver) for @$methods; |
|
4990 |
} |
|
4991 |
} |
|
4992 |
} |
|
4993 |
|
|
4994 |
|
|
4995 |
sub from_string_hash { |
|
4996 |
my ($class, $hash) = @_; |
|
4997 |
|
|
4998 |
my $self = $class->new; |
|
4999 |
|
|
5000 |
for my $module (keys %$hash) { |
|
5001 |
my $req = $hash->{$module}; |
|
5002 |
unless ( defined $req && length $req ) { |
|
5003 |
$req = 0; |
|
5004 |
Carp::carp("Undefined requirement for $module treated as '0'"); |
|
5005 |
} |
|
5006 |
$self->add_string_requirement($module, $req); |
|
5007 |
} |
|
5008 |
|
|
5009 |
return $self; |
|
5010 |
} |
|
5011 |
|
|
5012 |
############################################################## |
|
5013 |
|
|
5014 |
{ |
|
5015 |
package |
|
5016 |
CPAN::Meta::Requirements::_Range::Exact; |
|
5017 |
sub _new { bless { version => $_[1] } => $_[0] } |
|
5018 |
|
|
5019 |
sub _accepts { return $_[0]{version} == $_[1] } |
|
5020 |
|
|
5021 |
sub as_string { return "== $_[0]{version}" } |
|
5022 |
|
|
5023 |
sub as_modifiers { return [ [ exact_version => $_[0]{version} ] ] } |
|
5024 |
|
|
5025 |
sub _clone { |
|
5026 |
(ref $_[0])->_new( version->new( $_[0]{version} ) ) |
|
5027 |
} |
|
5028 |
|
|
5029 |
sub with_exact_version { |
|
5030 |
my ($self, $version) = @_; |
|
5031 |
|
|
5032 |
return $self->_clone if $self->_accepts($version); |
|
5033 |
|
|
5034 |
Carp::confess("illegal requirements: unequal exact version specified"); |
|
5035 |
} |
|
5036 |
|
|
5037 |
sub with_minimum { |
|
5038 |
my ($self, $minimum) = @_; |
|
5039 |
return $self->_clone if $self->{version} >= $minimum; |
|
5040 |
Carp::confess("illegal requirements: minimum above exact specification"); |
|
5041 |
} |
|
5042 |
|
|
5043 |
sub with_maximum { |
|
5044 |
my ($self, $maximum) = @_; |
|
5045 |
return $self->_clone if $self->{version} <= $maximum; |
|
5046 |
Carp::confess("illegal requirements: maximum below exact specification"); |
|
5047 |
} |
|
5048 |
|
|
5049 |
sub with_exclusion { |
|
5050 |
my ($self, $exclusion) = @_; |
|
5051 |
return $self->_clone unless $exclusion == $self->{version}; |
|
5052 |
Carp::confess("illegal requirements: excluded exact specification"); |
|
5053 |
} |
|
5054 |
} |
|
5055 |
|
|
5056 |
############################################################## |
|
5057 |
|
|
5058 |
{ |
|
5059 |
package |
|
5060 |
CPAN::Meta::Requirements::_Range::Range; |
|
5061 |
|
|
5062 |
sub _self { ref($_[0]) ? $_[0] : (bless { } => $_[0]) } |
|
5063 |
|
|
5064 |
sub _clone { |
|
5065 |
return (bless { } => $_[0]) unless ref $_[0]; |
|
5066 |
|
|
5067 |
my ($s) = @_; |
|
5068 |
my %guts = ( |
|
5069 |
(exists $s->{minimum} ? (minimum => version->new($s->{minimum})) : ()), |
|
5070 |
(exists $s->{maximum} ? (maximum => version->new($s->{maximum})) : ()), |
|
5071 |
|
|
5072 |
(exists $s->{exclusions} |
|
5073 |
? (exclusions => [ map { version->new($_) } @{ $s->{exclusions} } ]) |
|
5074 |
: ()), |
|
5075 |
); |
|
5076 |
|
|
5077 |
bless \%guts => ref($s); |
|
5078 |
} |
|
5079 |
|
|
5080 |
sub as_modifiers { |
|
5081 |
my ($self) = @_; |
|
5082 |
my @mods; |
|
5083 |
push @mods, [ add_minimum => $self->{minimum} ] if exists $self->{minimum}; |
|
5084 |
push @mods, [ add_maximum => $self->{maximum} ] if exists $self->{maximum}; |
|
5085 |
push @mods, map {; [ add_exclusion => $_ ] } @{$self->{exclusions} || []}; |
|
5086 |
return \@mods; |
|
5087 |
} |
|
5088 |
|
|
5089 |
sub as_string { |
|
5090 |
my ($self) = @_; |
|
5091 |
|
|
5092 |
return 0 if ! keys %$self; |
|
5093 |
|
|
5094 |
return "$self->{minimum}" if (keys %$self) == 1 and exists $self->{minimum}; |
|
5095 |
|
|
5096 |
my @exclusions = @{ $self->{exclusions} || [] }; |
|
5097 |
|
|
5098 |
my @parts; |
|
5099 |
|
|
5100 |
for my $pair ( |
|
5101 |
[ qw( >= > minimum ) ], |
|
5102 |
[ qw( <= < maximum ) ], |
|
5103 |
) { |
|
5104 |
my ($op, $e_op, $k) = @$pair; |
|
5105 |
if (exists $self->{$k}) { |
|
5106 |
my @new_exclusions = grep { $_ != $self->{ $k } } @exclusions; |
|
5107 |
if (@new_exclusions == @exclusions) { |
|
5108 |
push @parts, "$op $self->{ $k }"; |
|
5109 |
} else { |
|
5110 |
push @parts, "$e_op $self->{ $k }"; |
|
5111 |
@exclusions = @new_exclusions; |
|
5112 |
} |
|
5113 |
} |
|
5114 |
} |
|
5115 |
|
|
5116 |
push @parts, map {; "!= $_" } @exclusions; |
|
5117 |
|
|
5118 |
return join q{, }, @parts; |
|
5119 |
} |
|
5120 |
|
|
5121 |
sub with_exact_version { |
|
5122 |
my ($self, $version) = @_; |
|
5123 |
$self = $self->_clone; |
|
5124 |
|
|
5125 |
Carp::confess("illegal requirements: exact specification outside of range") |
|
5126 |
unless $self->_accepts($version); |
|
5127 |
|
|
5128 |
return CPAN::Meta::Requirements::_Range::Exact->_new($version); |
|
5129 |
} |
|
5130 |
|
|
5131 |
sub _simplify { |
|
5132 |
my ($self) = @_; |
|
5133 |
|
|
5134 |
if (defined $self->{minimum} and defined $self->{maximum}) { |
|
5135 |
if ($self->{minimum} == $self->{maximum}) { |
|
5136 |
Carp::confess("illegal requirements: excluded all values") |
|
5137 |
if grep { $_ == $self->{minimum} } @{ $self->{exclusions} || [] }; |
|
5138 |
|
|
5139 |
return CPAN::Meta::Requirements::_Range::Exact->_new($self->{minimum}) |
|
5140 |
} |
|
5141 |
|
|
5142 |
Carp::confess("illegal requirements: minimum exceeds maximum") |
|
5143 |
if $self->{minimum} > $self->{maximum}; |
|
5144 |
} |
|
5145 |
|
|
5146 |
# eliminate irrelevant exclusions |
|
5147 |
if ($self->{exclusions}) { |
|
5148 |
my %seen; |
|
5149 |
@{ $self->{exclusions} } = grep { |
|
5150 |
(! defined $self->{minimum} or $_ >= $self->{minimum}) |
|
5151 |
and |
|
5152 |
(! defined $self->{maximum} or $_ <= $self->{maximum}) |
|
5153 |
and |
|
5154 |
! $seen{$_}++ |
|
5155 |
} @{ $self->{exclusions} }; |
|
5156 |
} |
|
5157 |
|
|
5158 |
return $self; |
|
5159 |
} |
|
5160 |
|
|
5161 |
sub with_minimum { |
|
5162 |
my ($self, $minimum) = @_; |
|
5163 |
$self = $self->_clone; |
|
5164 |
|
|
5165 |
if (defined (my $old_min = $self->{minimum})) { |
|
5166 |
$self->{minimum} = (sort { $b cmp $a } ($minimum, $old_min))[0]; |
|
5167 |
} else { |
|
5168 |
$self->{minimum} = $minimum; |
|
5169 |
} |
|
5170 |
|
|
5171 |
return $self->_simplify; |
|
5172 |
} |
|
5173 |
|
|
5174 |
sub with_maximum { |
|
5175 |
my ($self, $maximum) = @_; |
|
5176 |
$self = $self->_clone; |
|
5177 |
|
|
5178 |
if (defined (my $old_max = $self->{maximum})) { |
|
5179 |
$self->{maximum} = (sort { $a cmp $b } ($maximum, $old_max))[0]; |
|
5180 |
} else { |
|
5181 |
$self->{maximum} = $maximum; |
|
5182 |
} |
|
5183 |
|
|
5184 |
return $self->_simplify; |
|
5185 |
} |
|
5186 |
|
|
5187 |
sub with_exclusion { |
|
5188 |
my ($self, $exclusion) = @_; |
|
5189 |
$self = $self->_clone; |
|
5190 |
|
|
5191 |
push @{ $self->{exclusions} ||= [] }, $exclusion; |
|
5192 |
|
|
5193 |
return $self->_simplify; |
|
5194 |
} |
|
5195 |
|
|
5196 |
sub _accepts { |
|
5197 |
my ($self, $version) = @_; |
|
5198 |
|
|
5199 |
return if defined $self->{minimum} and $version < $self->{minimum}; |
|
5200 |
return if defined $self->{maximum} and $version > $self->{maximum}; |
|
5201 |
return if defined $self->{exclusions} |
|
5202 |
and grep { $version == $_ } @{ $self->{exclusions} }; |
|
5203 |
|
|
5204 |
return 1; |
|
5205 |
} |
|
5206 |
} |
|
5207 |
|
|
5208 |
1; |
|
5209 |
# vim: ts=2 sts=2 sw=2 et: |
|
5210 |
|
|
5211 |
__END__ |
|
5212 |
=pod |
|
5213 |
|
|
5214 |
CPAN_META_REQUIREMENTS |
|
5215 | ||
5216 |
$fatpacked{"CPAN/Meta/Spec.pm"} = <<'CPAN_META_SPEC'; |
|
5217 |
# vi:tw=72 |
|
5218 |
use 5.006; |
|
5219 |
use strict; |
|
5220 |
use warnings; |
|
5221 |
package CPAN::Meta::Spec; |
|
5222 |
our $VERSION = '2.120921'; # VERSION |
|
5223 |
|
|
5224 |
1; |
|
5225 |
|
|
5226 |
# ABSTRACT: specification for CPAN distribution metadata |
|
5227 |
|
|
5228 |
|
|
5229 |
|
|
5230 |
__END__ |
|
5231 |
=pod |
|
5232 |
|
|
5233 |
CPAN_META_SPEC |
|
5234 | ||
5235 |
$fatpacked{"CPAN/Meta/Validator.pm"} = <<'CPAN_META_VALIDATOR'; |
|
5236 |
use 5.006; |
|
5237 |
use strict; |
|
5238 |
use warnings; |
|
5239 |
package CPAN::Meta::Validator; |
|
5240 |
our $VERSION = '2.120921'; # VERSION |
|
5241 |
|
|
5242 |
|
|
5243 |
#--------------------------------------------------------------------------# |
|
5244 |
# This code copied and adapted from Test::CPAN::Meta |
|
5245 |
# by Barbie, <barbie@cpan.org> for Miss Barbell Productions, |
|
5246 |
# L<http://www.missbarbell.co.uk> |
|
5247 |
#--------------------------------------------------------------------------# |
|
5248 |
|
|
5249 |
#--------------------------------------------------------------------------# |
|
5250 |
# Specification Definitions |
|
5251 |
#--------------------------------------------------------------------------# |
|
5252 |
|
|
5253 |
my %known_specs = ( |
|
5254 |
'1.4' => 'http://module-build.sourceforge.net/META-spec-v1.4.html', |
|
5255 |
'1.3' => 'http://module-build.sourceforge.net/META-spec-v1.3.html', |
|
5256 |
'1.2' => 'http://module-build.sourceforge.net/META-spec-v1.2.html', |
|
5257 |
'1.1' => 'http://module-build.sourceforge.net/META-spec-v1.1.html', |
|
5258 |
'1.0' => 'http://module-build.sourceforge.net/META-spec-v1.0.html' |
|
5259 |
); |
|
5260 |
my %known_urls = map {$known_specs{$_} => $_} keys %known_specs; |
|
5261 |
|
|
5262 |
my $module_map1 = { 'map' => { ':key' => { name => \&module, value => \&exversion } } }; |
|
5263 |
|
|
5264 |
my $module_map2 = { 'map' => { ':key' => { name => \&module, value => \&version } } }; |
|
5265 |
|
|
5266 |
my $no_index_2 = { |
|
5267 |
'map' => { file => { list => { value => \&string } }, |
|
5268 |
directory => { list => { value => \&string } }, |
|
5269 |
'package' => { list => { value => \&string } }, |
|
5270 |
namespace => { list => { value => \&string } }, |
|
5271 |
':key' => { name => \&custom_2, value => \&anything }, |
|
5272 |
} |
|
5273 |
}; |
|
5274 |
|
|
5275 |
my $no_index_1_3 = { |
|
5276 |
'map' => { file => { list => { value => \&string } }, |
|
5277 |
directory => { list => { value => \&string } }, |
|
5278 |
'package' => { list => { value => \&string } }, |
|
5279 |
namespace => { list => { value => \&string } }, |
|
5280 |
':key' => { name => \&string, value => \&anything }, |
|
5281 |
} |
|
5282 |
}; |
|
5283 |
|
|
5284 |
my $no_index_1_2 = { |
|
5285 |
'map' => { file => { list => { value => \&string } }, |
|
5286 |
dir => { list => { value => \&string } }, |
|
5287 |
'package' => { list => { value => \&string } }, |
|
5288 |
namespace => { list => { value => \&string } }, |
|
5289 |
':key' => { name => \&string, value => \&anything }, |
|
5290 |
} |
|
5291 |
}; |
|
5292 |
|
|
5293 |
my $no_index_1_1 = { |
|
5294 |
'map' => { ':key' => { name => \&string, list => { value => \&string } }, |
|
5295 |
} |
|
5296 |
}; |
|
5297 |
|
|
5298 |
my $prereq_map = { |
|
5299 |
map => { |
|
5300 |
':key' => { |
|
5301 |
name => \&phase, |
|
5302 |
'map' => { |
|
5303 |
':key' => { |
|
5304 |
name => \&relation, |
|
5305 |
%$module_map1, |
|
5306 |
}, |
|
5307 |
}, |
|
5308 |
} |
|
5309 |
}, |
|
5310 |
}; |
|
5311 |
|
|
5312 |
my %definitions = ( |
|
5313 |
'2' => { |
|
5314 |
# REQUIRED |
|
5315 |
'abstract' => { mandatory => 1, value => \&string }, |
|
5316 |
'author' => { mandatory => 1, lazylist => { value => \&string } }, |
|
5317 |
'dynamic_config' => { mandatory => 1, value => \&boolean }, |
|
5318 |
'generated_by' => { mandatory => 1, value => \&string }, |
|
5319 |
'license' => { mandatory => 1, lazylist => { value => \&license } }, |
|
5320 |
'meta-spec' => { |
|
5321 |
mandatory => 1, |
|
5322 |
'map' => { |
|
5323 |
version => { mandatory => 1, value => \&version}, |
|
5324 |
url => { value => \&url }, |
|
5325 |
':key' => { name => \&custom_2, value => \&anything }, |
|
5326 |
} |
|
5327 |
}, |
|
5328 |
'name' => { mandatory => 1, value => \&string }, |
|
5329 |
'release_status' => { mandatory => 1, value => \&release_status }, |
|
5330 |
'version' => { mandatory => 1, value => \&version }, |
|
5331 |
|
|
5332 |
# OPTIONAL |
|
5333 |
'description' => { value => \&string }, |
|
5334 |
'keywords' => { lazylist => { value => \&string } }, |
|
5335 |
'no_index' => $no_index_2, |
|
5336 |
'optional_features' => { |
|
5337 |
'map' => { |
|
5338 |
':key' => { |
|
5339 |
name => \&string, |
|
5340 |
'map' => { |
|
5341 |
description => { value => \&string }, |
|
5342 |
prereqs => $prereq_map, |
|
5343 |
':key' => { name => \&custom_2, value => \&anything }, |
|
5344 |
} |
|
5345 |
} |
|
5346 |
} |
|
5347 |
}, |
|
5348 |
'prereqs' => $prereq_map, |
|
5349 |
'provides' => { |
|
5350 |
'map' => { |
|
5351 |
':key' => { |
|
5352 |
name => \&module, |
|
5353 |
'map' => { |
|
5354 |
file => { mandatory => 1, value => \&file }, |
|
5355 |
version => { value => \&version }, |
|
5356 |
':key' => { name => \&custom_2, value => \&anything }, |
|
5357 |
} |
|
5358 |
} |
|
5359 |
} |
|
5360 |
}, |
|
5361 |
'resources' => { |
|
5362 |
'map' => { |
|
5363 |
license => { lazylist => { value => \&url } }, |
|
5364 |
homepage => { value => \&url }, |
|
5365 |
bugtracker => { |
|
5366 |
'map' => { |
|
5367 |
web => { value => \&url }, |
|
5368 |
mailto => { value => \&string}, |
|
5369 |
':key' => { name => \&custom_2, value => \&anything }, |
|
5370 |
} |
|
5371 |
}, |
|
5372 |
repository => { |
|
5373 |
'map' => { |
|
5374 |
web => { value => \&url }, |
|
5375 |
url => { value => \&url }, |
|
5376 |
type => { value => \&string }, |
|
5377 |
':key' => { name => \&custom_2, value => \&anything }, |
|
5378 |
} |
|
5379 |
}, |
|
5380 |
':key' => { value => \&string, name => \&custom_2 }, |
|
5381 |
} |
|
5382 |
}, |
|
5383 |
|
|
5384 |
# CUSTOM -- additional user defined key/value pairs |
|
5385 |
# note we can only validate the key name, as the structure is user defined |
|
5386 |
':key' => { name => \&custom_2, value => \&anything }, |
|
5387 |
}, |
|
5388 |
|
|
5389 |
'1.4' => { |
|
5390 |
'meta-spec' => { |
|
5391 |
mandatory => 1, |
|
5392 |
'map' => { |
|
5393 |
version => { mandatory => 1, value => \&version}, |
|
5394 |
url => { mandatory => 1, value => \&urlspec }, |
|
5395 |
':key' => { name => \&string, value => \&anything }, |
|
5396 |
}, |
|
5397 |
}, |
|
5398 |
|
|
5399 |
'name' => { mandatory => 1, value => \&string }, |
|
5400 |
'version' => { mandatory => 1, value => \&version }, |
|
5401 |
'abstract' => { mandatory => 1, value => \&string }, |
|
5402 |
'author' => { mandatory => 1, list => { value => \&string } }, |
|
5403 |
'license' => { mandatory => 1, value => \&license }, |
|
5404 |
'generated_by' => { mandatory => 1, value => \&string }, |
|
5405 |
|
|
5406 |
'distribution_type' => { value => \&string }, |
|
5407 |
'dynamic_config' => { value => \&boolean }, |
|
5408 |
|
|
5409 |
'requires' => $module_map1, |
|
5410 |
'recommends' => $module_map1, |
|
5411 |
'build_requires' => $module_map1, |
|
5412 |
'configure_requires' => $module_map1, |
|
5413 |
'conflicts' => $module_map2, |
|
5414 |
|
|
5415 |
'optional_features' => { |
|
5416 |
'map' => { |
|
5417 |
':key' => { name => \&string, |
|
5418 |
'map' => { description => { value => \&string }, |
|
5419 |
requires => $module_map1, |
|
5420 |
recommends => $module_map1, |
|
5421 |
build_requires => $module_map1, |
|
5422 |
conflicts => $module_map2, |
|
5423 |
':key' => { name => \&string, value => \&anything }, |
|
5424 |
} |
|
5425 |
} |
|
5426 |
} |
|
5427 |
}, |
|
5428 |
|
|
5429 |
'provides' => { |
|
5430 |
'map' => { |
|
5431 |
':key' => { name => \&module, |
|
5432 |
'map' => { |
|
5433 |
file => { mandatory => 1, value => \&file }, |
|
5434 |
version => { value => \&version }, |
|
5435 |
':key' => { name => \&string, value => \&anything }, |
|
5436 |
} |
|
5437 |
} |
|
5438 |
} |
|
5439 |
}, |
|
5440 |
|
|
5441 |
'no_index' => $no_index_1_3, |
|
5442 |
'private' => $no_index_1_3, |
|
5443 |
|
|
5444 |
'keywords' => { list => { value => \&string } }, |
|
5445 |
|
|
5446 |
'resources' => { |
|
5447 |
'map' => { license => { value => \&url }, |
|
5448 |
homepage => { value => \&url }, |
|
5449 |
bugtracker => { value => \&url }, |
|
5450 |
repository => { value => \&url }, |
|
5451 |
':key' => { value => \&string, name => \&custom_1 }, |
|
5452 |
} |
|
5453 |
}, |
|
5454 |
|
|
5455 |
# additional user defined key/value pairs |
|
5456 |
# note we can only validate the key name, as the structure is user defined |
|
5457 |
':key' => { name => \&string, value => \&anything }, |
|
5458 |
}, |
|
5459 |
|
|
5460 |
'1.3' => { |
|
5461 |
'meta-spec' => { |
|
5462 |
mandatory => 1, |
|
5463 |
'map' => { |
|
5464 |
version => { mandatory => 1, value => \&version}, |
|
5465 |
url => { mandatory => 1, value => \&urlspec }, |
|
5466 |
':key' => { name => \&string, value => \&anything }, |
|
5467 |
}, |
|
5468 |
}, |
|
5469 |
|
|
5470 |
'name' => { mandatory => 1, value => \&string }, |
|
5471 |
'version' => { mandatory => 1, value => \&version }, |
|
5472 |
'abstract' => { mandatory => 1, value => \&string }, |
|
5473 |
'author' => { mandatory => 1, list => { value => \&string } }, |
|
5474 |
'license' => { mandatory => 1, value => \&license }, |
|
5475 |
'generated_by' => { mandatory => 1, value => \&string }, |
|
5476 |
|
|
5477 |
'distribution_type' => { value => \&string }, |
|
5478 |
'dynamic_config' => { value => \&boolean }, |
|
5479 |
|
|
5480 |
'requires' => $module_map1, |
|
5481 |
'recommends' => $module_map1, |
|
5482 |
'build_requires' => $module_map1, |
|
5483 |
'conflicts' => $module_map2, |
|
5484 |
|
|
5485 |
'optional_features' => { |
|
5486 |
'map' => { |
|
5487 |
':key' => { name => \&string, |
|
5488 |
'map' => { description => { value => \&string }, |
|
5489 |
requires => $module_map1, |
|
5490 |
recommends => $module_map1, |
|
5491 |
build_requires => $module_map1, |
|
5492 |
conflicts => $module_map2, |
|
5493 |
':key' => { name => \&string, value => \&anything }, |
|
5494 |
} |
|
5495 |
} |
|
5496 |
} |
|
5497 |
}, |
|
5498 |
|
|
5499 |
'provides' => { |
|
5500 |
'map' => { |
|
5501 |
':key' => { name => \&module, |
|
5502 |
'map' => { |
|
5503 |
file => { mandatory => 1, value => \&file }, |
|
5504 |
version => { value => \&version }, |
|
5505 |
':key' => { name => \&string, value => \&anything }, |
|
5506 |
} |
|
5507 |
} |
|
5508 |
} |
|
5509 |
}, |
|
5510 |
|
|
5511 |
|
|
5512 |
'no_index' => $no_index_1_3, |
|
5513 |
'private' => $no_index_1_3, |
|
5514 |
|
|
5515 |
'keywords' => { list => { value => \&string } }, |
|
5516 |
|
|
5517 |
'resources' => { |
|
5518 |
'map' => { license => { value => \&url }, |
|
5519 |
homepage => { value => \&url }, |
|
5520 |
bugtracker => { value => \&url }, |
|
5521 |
repository => { value => \&url }, |
|
5522 |
':key' => { value => \&string, name => \&custom_1 }, |
|
5523 |
} |
|
5524 |
}, |
|
5525 |
|
|
5526 |
# additional user defined key/value pairs |
|
5527 |
# note we can only validate the key name, as the structure is user defined |
|
5528 |
':key' => { name => \&string, value => \&anything }, |
|
5529 |
}, |
|
5530 |
|
|
5531 |
# v1.2 is misleading, it seems to assume that a number of fields where created |
|
5532 |
# within v1.1, when they were created within v1.2. This may have been an |
|
5533 |
# original mistake, and that a v1.1 was retro fitted into the timeline, when |
|
5534 |
# v1.2 was originally slated as v1.1. But I could be wrong ;) |
|
5535 |
'1.2' => { |
|
5536 |
'meta-spec' => { |
|
5537 |
mandatory => 1, |
|
5538 |
'map' => { |
|
5539 |
version => { mandatory => 1, value => \&version}, |
|
5540 |
url => { mandatory => 1, value => \&urlspec }, |
|
5541 |
':key' => { name => \&string, value => \&anything }, |
|
5542 |
}, |
|
5543 |
}, |
|
5544 |
|
|
5545 |
|
|
5546 |
'name' => { mandatory => 1, value => \&string }, |
|
5547 |
'version' => { mandatory => 1, value => \&version }, |
|
5548 |
'license' => { mandatory => 1, value => \&license }, |
|
5549 |
'generated_by' => { mandatory => 1, value => \&string }, |
|
5550 |
'author' => { mandatory => 1, list => { value => \&string } }, |
|
5551 |
'abstract' => { mandatory => 1, value => \&string }, |
|
5552 |
|
|
5553 |
'distribution_type' => { value => \&string }, |
|
5554 |
'dynamic_config' => { value => \&boolean }, |
|
5555 |
|
|
5556 |
'keywords' => { list => { value => \&string } }, |
|
5557 |
|
|
5558 |
'private' => $no_index_1_2, |
|
5559 |
'$no_index' => $no_index_1_2, |
|
5560 |
|
|
5561 |
'requires' => $module_map1, |
|
5562 |
'recommends' => $module_map1, |
|
5563 |
'build_requires' => $module_map1, |
|
5564 |
'conflicts' => $module_map2, |
|
5565 |
|
|
5566 |
'optional_features' => { |
|
5567 |
'map' => { |
|
5568 |
':key' => { name => \&string, |
|
5569 |
'map' => { description => { value => \&string }, |
|
5570 |
requires => $module_map1, |
|
5571 |
recommends => $module_map1, |
|
5572 |
build_requires => $module_map1, |
|
5573 |
conflicts => $module_map2, |
|
5574 |
':key' => { name => \&string, value => \&anything }, |
|
5575 |
} |
|
5576 |
} |
|
5577 |
} |
|
5578 |
}, |
|
5579 |
|
|
5580 |
'provides' => { |
|
5581 |
'map' => { |
|
5582 |
':key' => { name => \&module, |
|
5583 |
'map' => { |
|
5584 |
file => { mandatory => 1, value => \&file }, |
|
5585 |
version => { value => \&version }, |
|
5586 |
':key' => { name => \&string, value => \&anything }, |
|
5587 |
} |
|
5588 |
} |
|
5589 |
} |
|
5590 |
}, |
|
5591 |
|
|
5592 |
'resources' => { |
|
5593 |
'map' => { license => { value => \&url }, |
|
5594 |
homepage => { value => \&url }, |
|
5595 |
bugtracker => { value => \&url }, |
|
5596 |
repository => { value => \&url }, |
|
5597 |
':key' => { value => \&string, name => \&custom_1 }, |
|
5598 |
} |
|
5599 |
}, |
|
5600 |
|
|
5601 |
# additional user defined key/value pairs |
|
5602 |
# note we can only validate the key name, as the structure is user defined |
|
5603 |
':key' => { name => \&string, value => \&anything }, |
|
5604 |
}, |
|
5605 |
|
|
5606 |
# note that the 1.1 spec only specifies 'version' as mandatory |
|
5607 |
'1.1' => { |
|
5608 |
'name' => { value => \&string }, |
|
5609 |
'version' => { mandatory => 1, value => \&version }, |
|
5610 |
'license' => { value => \&license }, |
|
5611 |
'generated_by' => { value => \&string }, |
|
5612 |
|
|
5613 |
'license_uri' => { value => \&url }, |
|
5614 |
'distribution_type' => { value => \&string }, |
|
5615 |
'dynamic_config' => { value => \&boolean }, |
|
5616 |
|
|
5617 |
'private' => $no_index_1_1, |
|
5618 |
|
|
5619 |
'requires' => $module_map1, |
|
5620 |
'recommends' => $module_map1, |
|
5621 |
'build_requires' => $module_map1, |
|
5622 |
'conflicts' => $module_map2, |
|
5623 |
|
|
5624 |
# additional user defined key/value pairs |
|
5625 |
# note we can only validate the key name, as the structure is user defined |
|
5626 |
':key' => { name => \&string, value => \&anything }, |
|
5627 |
}, |
|
5628 |
|
|
5629 |
# note that the 1.0 spec doesn't specify optional or mandatory fields |
|
5630 |
# but we will treat version as mandatory since otherwise META 1.0 is |
|
5631 |
# completely arbitrary and pointless |
|
5632 |
'1.0' => { |
|
5633 |
'name' => { value => \&string }, |
|
5634 |
'version' => { mandatory => 1, value => \&version }, |
|
5635 |
'license' => { value => \&license }, |
|
5636 |
'generated_by' => { value => \&string }, |
|
5637 |
|
|
5638 |
'license_uri' => { value => \&url }, |
|
5639 |
'distribution_type' => { value => \&string }, |
|
5640 |
'dynamic_config' => { value => \&boolean }, |
|
5641 |
|
|
5642 |
'requires' => $module_map1, |
|
5643 |
'recommends' => $module_map1, |
|
5644 |
'build_requires' => $module_map1, |
|
5645 |
'conflicts' => $module_map2, |
|
5646 |
|
|
5647 |
# additional user defined key/value pairs |
|
5648 |
# note we can only validate the key name, as the structure is user defined |
|
5649 |
':key' => { name => \&string, value => \&anything }, |
|
5650 |
}, |
|
5651 |
); |
|
5652 |
|
|
5653 |
#--------------------------------------------------------------------------# |
|
5654 |
# Code |
|
5655 |
#--------------------------------------------------------------------------# |
|
5656 |
|
|
5657 |
|
|
5658 |
sub new { |
|
5659 |
my ($class,$data) = @_; |
|
5660 |
|
|
5661 |
# create an attributes hash |
|
5662 |
my $self = { |
|
5663 |
'data' => $data, |
|
5664 |
'spec' => $data->{'meta-spec'}{'version'} || "1.0", |
|
5665 |
'errors' => undef, |
|
5666 |
}; |
|
5667 |
|
|
5668 |
# create the object |
|
5669 |
return bless $self, $class; |
|
5670 |
} |
|
5671 |
|
|
5672 |
|
|
5673 |
sub is_valid { |
|
5674 |
my $self = shift; |
|
5675 |
my $data = $self->{data}; |
|
5676 |
my $spec_version = $self->{spec}; |
|
5677 |
$self->check_map($definitions{$spec_version},$data); |
|
5678 |
return ! $self->errors; |
|
5679 |
} |
|
5680 |
|
|
5681 |
|
|
5682 |
sub errors { |
|
5683 |
my $self = shift; |
|
5684 |
return () unless(defined $self->{errors}); |
|
5685 |
return @{$self->{errors}}; |
|
5686 |
} |
|
5687 |
|
|
5688 |
|
|
5689 |
my $spec_error = "Missing validation action in specification. " |
|
5690 |
. "Must be one of 'map', 'list', 'lazylist', or 'value'"; |
|
5691 |
|
|
5692 |
sub check_map { |
|
5693 |
my ($self,$spec,$data) = @_; |
|
5694 |
|
|
5695 |
if(ref($spec) ne 'HASH') { |
|
5696 |
$self->_error( "Unknown META specification, cannot validate." ); |
|
5697 |
return; |
|
5698 |
} |
|
5699 |
|
|
5700 |
if(ref($data) ne 'HASH') { |
|
5701 |
$self->_error( "Expected a map structure from string or file." ); |
|
5702 |
return; |
|
5703 |
} |
|
5704 |
|
|
5705 |
for my $key (keys %$spec) { |
|
5706 |
next unless($spec->{$key}->{mandatory}); |
|
5707 |
next if(defined $data->{$key}); |
|
5708 |
push @{$self->{stack}}, $key; |
|
5709 |
$self->_error( "Missing mandatory field, '$key'" ); |
|
5710 |
pop @{$self->{stack}}; |
|
5711 |
} |
|
5712 |
|
|
5713 |
for my $key (keys %$data) { |
|
5714 |
push @{$self->{stack}}, $key; |
|
5715 |
if($spec->{$key}) { |
|
5716 |
if($spec->{$key}{value}) { |
|
5717 |
$spec->{$key}{value}->($self,$key,$data->{$key}); |
|
5718 |
} elsif($spec->{$key}{'map'}) { |
|
5719 |
$self->check_map($spec->{$key}{'map'},$data->{$key}); |
|
5720 |
} elsif($spec->{$key}{'list'}) { |
|
5721 |
$self->check_list($spec->{$key}{'list'},$data->{$key}); |
|
5722 |
} elsif($spec->{$key}{'lazylist'}) { |
|
5723 |
$self->check_lazylist($spec->{$key}{'lazylist'},$data->{$key}); |
|
5724 |
} else { |
|
5725 |
$self->_error( "$spec_error for '$key'" ); |
|
5726 |
} |
|
5727 |
|
|
5728 |
} elsif ($spec->{':key'}) { |
|
5729 |
$spec->{':key'}{name}->($self,$key,$key); |
|
5730 |
if($spec->{':key'}{value}) { |
|
5731 |
$spec->{':key'}{value}->($self,$key,$data->{$key}); |
|
5732 |
} elsif($spec->{':key'}{'map'}) { |
|
5733 |
$self->check_map($spec->{':key'}{'map'},$data->{$key}); |
|
5734 |
} elsif($spec->{':key'}{'list'}) { |
|
5735 |
$self->check_list($spec->{':key'}{'list'},$data->{$key}); |
|
5736 |
} elsif($spec->{':key'}{'lazylist'}) { |
|
5737 |
$self->check_lazylist($spec->{':key'}{'lazylist'},$data->{$key}); |
|
5738 |
} else { |
|
5739 |
$self->_error( "$spec_error for ':key'" ); |
|
5740 |
} |
|
5741 |
|
|
5742 |
|
|
5743 |
} else { |
|
5744 |
$self->_error( "Unknown key, '$key', found in map structure" ); |
|
5745 |
} |
|
5746 |
pop @{$self->{stack}}; |
|
5747 |
} |
|
5748 |
} |
|
5749 |
|
|
5750 |
# if it's a string, make it into a list and check the list |
|
5751 |
sub check_lazylist { |
|
5752 |
my ($self,$spec,$data) = @_; |
|
5753 |
|
|
5754 |
if ( defined $data && ! ref($data) ) { |
|
5755 |
$data = [ $data ]; |
|
5756 |
} |
|
5757 |
|
|
5758 |
$self->check_list($spec,$data); |
|
5759 |
} |
|
5760 |
|
|
5761 |
sub check_list { |
|
5762 |
my ($self,$spec,$data) = @_; |
|
5763 |
|
|
5764 |
if(ref($data) ne 'ARRAY') { |
|
5765 |
$self->_error( "Expected a list structure" ); |
|
5766 |
return; |
|
5767 |
} |
|
5768 |
|
|
5769 |
if(defined $spec->{mandatory}) { |
|
5770 |
if(!defined $data->[0]) { |
|
5771 |
$self->_error( "Missing entries from mandatory list" ); |
|
5772 |
} |
|
5773 |
} |
|
5774 |
|
|
5775 |
for my $value (@$data) { |
|
5776 |
push @{$self->{stack}}, $value || "<undef>"; |
|
5777 |
if(defined $spec->{value}) { |
|
5778 |
$spec->{value}->($self,'list',$value); |
|
5779 |
} elsif(defined $spec->{'map'}) { |
|
5780 |
$self->check_map($spec->{'map'},$value); |
|
5781 |
} elsif(defined $spec->{'list'}) { |
|
5782 |
$self->check_list($spec->{'list'},$value); |
|
5783 |
} elsif(defined $spec->{'lazylist'}) { |
|
5784 |
$self->check_lazylist($spec->{'lazylist'},$value); |
|
5785 |
} elsif ($spec->{':key'}) { |
|
5786 |
$self->check_map($spec,$value); |
|
5787 |
} else { |
|
5788 |
$self->_error( "$spec_error associated with '$self->{stack}[-2]'" ); |
|
5789 |
} |
|
5790 |
pop @{$self->{stack}}; |
|
5791 |
} |
|
5792 |
} |
|
5793 |
|
|
5794 |
|
|
5795 |
sub header { |
|
5796 |
my ($self,$key,$value) = @_; |
|
5797 |
if(defined $value) { |
|
5798 |
return 1 if($value && $value =~ /^--- #YAML:1.0/); |
|
5799 |
} |
|
5800 |
$self->_error( "file does not have a valid YAML header." ); |
|
5801 |
return 0; |
|
5802 |
} |
|
5803 |
|
|
5804 |
sub release_status { |
|
5805 |
my ($self,$key,$value) = @_; |
|
5806 |
if(defined $value) { |
|
5807 |
my $version = $self->{data}{version} || ''; |
|
5808 |
if ( $version =~ /_/ ) { |
|
5809 |
return 1 if ( $value =~ /\A(?:testing|unstable)\z/ ); |
|
5810 |
$self->_error( "'$value' for '$key' is invalid for version '$version'" ); |
|
5811 |
} |
|
5812 |
else { |
|
5813 |
return 1 if ( $value =~ /\A(?:stable|testing|unstable)\z/ ); |
|
5814 |
$self->_error( "'$value' for '$key' is invalid" ); |
|
5815 |
} |
|
5816 |
} |
|
5817 |
else { |
|
5818 |
$self->_error( "'$key' is not defined" ); |
|
5819 |
} |
|
5820 |
return 0; |
|
5821 |
} |
|
5822 |
|
|
5823 |
# _uri_split taken from URI::Split by Gisle Aas, Copyright 2003 |
|
5824 |
sub _uri_split { |
|
5825 |
return $_[0] =~ m,(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?,; |
|
5826 |
} |
|
5827 |
|
|
5828 |
sub url { |
|
5829 |
my ($self,$key,$value) = @_; |
|
5830 |
if(defined $value) { |
|
5831 |
my ($scheme, $auth, $path, $query, $frag) = _uri_split($value); |
|
5832 |
unless ( defined $scheme && length $scheme ) { |
|
5833 |
$self->_error( "'$value' for '$key' does not have a URL scheme" ); |
|
5834 |
return 0; |
|
5835 |
} |
|
5836 |
unless ( defined $auth && length $auth ) { |
|
5837 |
$self->_error( "'$value' for '$key' does not have a URL authority" ); |
|
5838 |
return 0; |
|
5839 |
} |
|
5840 |
return 1; |
|
5841 |
} |
|
5842 |
$value ||= ''; |
|
5843 |
$self->_error( "'$value' for '$key' is not a valid URL." ); |
|
5844 |
return 0; |
|
5845 |
} |
|
5846 |
|
|
5847 |
sub urlspec { |
|
5848 |
my ($self,$key,$value) = @_; |
|
5849 |
if(defined $value) { |
|
5850 |
return 1 if($value && $known_specs{$self->{spec}} eq $value); |
|
5851 |
if($value && $known_urls{$value}) { |
|
5852 |
$self->_error( 'META specification URL does not match version' ); |
|
5853 |
return 0; |
|
5854 |
} |
|
5855 |
} |
|
5856 |
$self->_error( 'Unknown META specification' ); |
|
5857 |
return 0; |
|
5858 |
} |
|
5859 |
|
|
5860 |
sub anything { return 1 } |
|
5861 |
|
|
5862 |
sub string { |
|
5863 |
my ($self,$key,$value) = @_; |
|
5864 |
if(defined $value) { |
|
5865 |
return 1 if($value || $value =~ /^0$/); |
|
5866 |
} |
|
5867 |
$self->_error( "value is an undefined string" ); |
|
5868 |
return 0; |
|
5869 |
} |
|
5870 |
|
|
5871 |
sub string_or_undef { |
|
5872 |
my ($self,$key,$value) = @_; |
|
5873 |
return 1 unless(defined $value); |
|
5874 |
return 1 if($value || $value =~ /^0$/); |
|
5875 |
$self->_error( "No string defined for '$key'" ); |
|
5876 |
return 0; |
|
5877 |
} |
|
5878 |
|
|
5879 |
sub file { |
|
5880 |
my ($self,$key,$value) = @_; |
|
5881 |
return 1 if(defined $value); |
|
5882 |
$self->_error( "No file defined for '$key'" ); |
|
5883 |
return 0; |
|
5884 |
} |
|
5885 |
|
|
5886 |
sub exversion { |
|
5887 |
my ($self,$key,$value) = @_; |
|
5888 |
if(defined $value && ($value || $value =~ /0/)) { |
|
5889 |
my $pass = 1; |
|
5890 |
for(split(",",$value)) { $self->version($key,$_) or ($pass = 0); } |
|
5891 |
return $pass; |
|
5892 |
} |
|
5893 |
$value = '<undef>' unless(defined $value); |
|
5894 |
$self->_error( "'$value' for '$key' is not a valid version." ); |
|
5895 |
return 0; |
|
5896 |
} |
|
5897 |
|
|
5898 |
sub version { |
|
5899 |
my ($self,$key,$value) = @_; |
|
5900 |
if(defined $value) { |
|
5901 |
return 0 unless($value || $value =~ /0/); |
|
5902 |
return 1 if($value =~ /^\s*((<|<=|>=|>|!=|==)\s*)?v?\d+((\.\d+((_|\.)\d+)?)?)/); |
|
5903 |
} else { |
|
5904 |
$value = '<undef>'; |
|
5905 |
} |
|
5906 |
$self->_error( "'$value' for '$key' is not a valid version." ); |
|
5907 |
return 0; |
|
5908 |
} |
|
5909 |
|
|
5910 |
sub boolean { |
|
5911 |
my ($self,$key,$value) = @_; |
|
5912 |
if(defined $value) { |
|
5913 |
return 1 if($value =~ /^(0|1|true|false)$/); |
|
5914 |
} else { |
|
5915 |
$value = '<undef>'; |
|
5916 |
} |
|
5917 |
$self->_error( "'$value' for '$key' is not a boolean value." ); |
|
5918 |
return 0; |
|
5919 |
} |
|
5920 |
|
|
5921 |
my %v1_licenses = ( |
|
5922 |
'perl' => 'http://dev.perl.org/licenses/', |
|
5923 |
'gpl' => 'http://www.opensource.org/licenses/gpl-license.php', |
|
5924 |
'apache' => 'http://apache.org/licenses/LICENSE-2.0', |
|
5925 |
'artistic' => 'http://opensource.org/licenses/artistic-license.php', |
|
5926 |
'artistic_2' => 'http://opensource.org/licenses/artistic-license-2.0.php', |
|
5927 |
'lgpl' => 'http://www.opensource.org/licenses/lgpl-license.php', |
|
5928 |
'bsd' => 'http://www.opensource.org/licenses/bsd-license.php', |
|
5929 |
'gpl' => 'http://www.opensource.org/licenses/gpl-license.php', |
|
5930 |
'mit' => 'http://opensource.org/licenses/mit-license.php', |
|
5931 |
'mozilla' => 'http://opensource.org/licenses/mozilla1.1.php', |
|
5932 |
'open_source' => undef, |
|
5933 |
'unrestricted' => undef, |
|
5934 |
'restrictive' => undef, |
|
5935 |
'unknown' => undef, |
|
5936 |
); |
|
5937 |
|
|
5938 |
my %v2_licenses = map { $_ => 1 } qw( |
|
5939 |
agpl_3 |
|
5940 |
apache_1_1 |
|
5941 |
apache_2_0 |
|
5942 |
artistic_1 |
|
5943 |
artistic_2 |
|
5944 |
bsd |
|
5945 |
freebsd |
|
5946 |
gfdl_1_2 |
|
5947 |
gfdl_1_3 |
|
5948 |
gpl_1 |
|
5949 |
gpl_2 |
|
5950 |
gpl_3 |
|
5951 |
lgpl_2_1 |
|
5952 |
lgpl_3_0 |
|
5953 |
mit |
|
5954 |
mozilla_1_0 |
|
5955 |
mozilla_1_1 |
|
5956 |
openssl |
|
5957 |
perl_5 |
|
5958 |
qpl_1_0 |
|
5959 |
ssleay |
|
5960 |
sun |
|
5961 |
zlib |
|
5962 |
open_source |
|
5963 |
restricted |
|
5964 |
unrestricted |
|
5965 |
unknown |
|
5966 |
); |
|
5967 |
|
|
5968 |
sub license { |
|
5969 |
my ($self,$key,$value) = @_; |
|
5970 |
my $licenses = $self->{spec} < 2 ? \%v1_licenses : \%v2_licenses; |
|
5971 |
if(defined $value) { |
|
5972 |
return 1 if($value && exists $licenses->{$value}); |
|
5973 |
} else { |
|
5974 |
$value = '<undef>'; |
|
5975 |
} |
|
5976 |
$self->_error( "License '$value' is invalid" ); |
|
5977 |
return 0; |
|
5978 |
} |
|
5979 |
|
|
5980 |
sub custom_1 { |
|
5981 |
my ($self,$key) = @_; |
|
5982 |
if(defined $key) { |
|
5983 |
# a valid user defined key should be alphabetic |
|
5984 |
# and contain at least one capital case letter. |
|
5985 |
return 1 if($key && $key =~ /^[_a-z]+$/i && $key =~ /[A-Z]/); |
|
5986 |
} else { |
|
5987 |
$key = '<undef>'; |
|
5988 |
} |
|
5989 |
$self->_error( "Custom resource '$key' must be in CamelCase." ); |
|
5990 |
return 0; |
|
5991 |
} |
|
5992 |
|
|
5993 |
sub custom_2 { |
|
5994 |
my ($self,$key) = @_; |
|
5995 |
if(defined $key) { |
|
5996 |
return 1 if($key && $key =~ /^x_/i); # user defined |
|
5997 |
} else { |
|
5998 |
$key = '<undef>'; |
|
5999 |
} |
|
6000 |
$self->_error( "Custom key '$key' must begin with 'x_' or 'X_'." ); |
|
6001 |
return 0; |
|
6002 |
} |
|
6003 |
|
|
6004 |
sub identifier { |
|
6005 |
my ($self,$key) = @_; |
|
6006 |
if(defined $key) { |
|
6007 |
return 1 if($key && $key =~ /^([a-z][_a-z]+)$/i); # spec 2.0 defined |
|
6008 |
} else { |
|
6009 |
$key = '<undef>'; |
|
6010 |
} |
|
6011 |
$self->_error( "Key '$key' is not a legal identifier." ); |
|
6012 |
return 0; |
|
6013 |
} |
|
6014 |
|
|
6015 |
sub module { |
|
6016 |
my ($self,$key) = @_; |
|
6017 |
if(defined $key) { |
|
6018 |
return 1 if($key && $key =~ /^[A-Za-z0-9_]+(::[A-Za-z0-9_]+)*$/); |
|
6019 |
} else { |
|
6020 |
$key = '<undef>'; |
|
6021 |
} |
|
6022 |
$self->_error( "Key '$key' is not a legal module name." ); |
|
6023 |
return 0; |
|
6024 |
} |
|
6025 |
|
|
6026 |
my @valid_phases = qw/ configure build test runtime develop /; |
|
6027 |
sub phase { |
|
6028 |
my ($self,$key) = @_; |
|
6029 |
if(defined $key) { |
|
6030 |
return 1 if( length $key && grep { $key eq $_ } @valid_phases ); |
|
6031 |
return 1 if $key =~ /x_/i; |
|
6032 |
} else { |
|
6033 |
$key = '<undef>'; |
|
6034 |
} |
|
6035 |
$self->_error( "Key '$key' is not a legal phase." ); |
|
6036 |
return 0; |
|
6037 |
} |
|
6038 |
|
|
6039 |
my @valid_relations = qw/ requires recommends suggests conflicts /; |
|
6040 |
sub relation { |
|
6041 |
my ($self,$key) = @_; |
|
6042 |
if(defined $key) { |
|
6043 |
return 1 if( length $key && grep { $key eq $_ } @valid_relations ); |
|
6044 |
return 1 if $key =~ /x_/i; |
|
6045 |
} else { |
|
6046 |
$key = '<undef>'; |
|
6047 |
} |
|
6048 |
$self->_error( "Key '$key' is not a legal prereq relationship." ); |
|
6049 |
return 0; |
|
6050 |
} |
|
6051 |
|
|
6052 |
sub _error { |
|
6053 |
my $self = shift; |
|
6054 |
my $mess = shift; |
|
6055 |
|
|
6056 |
$mess .= ' ('.join(' -> ',@{$self->{stack}}).')' if($self->{stack}); |
|
6057 |
$mess .= " [Validation: $self->{spec}]"; |
|
6058 |
|
|
6059 |
push @{$self->{errors}}, $mess; |
|
6060 |
} |
|
6061 |
|
|
6062 |
1; |
|
6063 |
|
|
6064 |
# ABSTRACT: validate CPAN distribution metadata structures |
|
6065 |
|
|
6066 |
|
|
6067 |
|
|
6068 |
|
|
6069 |
__END__ |
|
6070 |
|
|
6071 |
|
|
6072 |
|
|
6073 |
CPAN_META_VALIDATOR |
|
6074 | ||
6075 |
$fatpacked{"CPAN/Meta/YAML.pm"} = <<'CPAN_META_YAML'; |
|
6076 |
package CPAN::Meta::YAML; |
|
6077 |
{ |
|
6078 |
$CPAN::Meta::YAML::VERSION = '0.008'; |
|
6079 |
} |
|
6080 |
|
|
6081 |
use strict; |
|
6082 |
|
|
6083 |
# UTF Support? |
|
6084 |
sub HAVE_UTF8 () { $] >= 5.007003 } |
|
6085 |
BEGIN { |
|
6086 |
if ( HAVE_UTF8 ) { |
|
6087 |
# The string eval helps hide this from Test::MinimumVersion |
|
6088 |
eval "require utf8;"; |
|
6089 |
die "Failed to load UTF-8 support" if $@; |
|
6090 |
} |
|
6091 |
|
|
6092 |
# Class structure |
|
6093 |
require 5.004; |
|
6094 |
require Exporter; |
|
6095 |
require Carp; |
|
6096 |
@CPAN::Meta::YAML::ISA = qw{ Exporter }; |
|
6097 |
@CPAN::Meta::YAML::EXPORT = qw{ Load Dump }; |
|
6098 |
@CPAN::Meta::YAML::EXPORT_OK = qw{ LoadFile DumpFile freeze thaw }; |
|
6099 |
|
|
6100 |
# Error storage |
|
6101 |
$CPAN::Meta::YAML::errstr = ''; |
|
6102 |
} |
|
6103 |
|
|
6104 |
# The character class of all characters we need to escape |
|
6105 |
# NOTE: Inlined, since it's only used once |
|
6106 |
# my $RE_ESCAPE = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f\"\n]'; |
|
6107 |
|
|
6108 |
# Printed form of the unprintable characters in the lowest range |
|
6109 |
# of ASCII characters, listed by ASCII ordinal position. |
|
6110 |
my @UNPRINTABLE = qw( |
|
6111 |
z x01 x02 x03 x04 x05 x06 a |
|
6112 |
x08 t n v f r x0e x0f |
|
6113 |
x10 x11 x12 x13 x14 x15 x16 x17 |
|
6114 |
x18 x19 x1a e x1c x1d x1e x1f |
|
6115 |
); |
|
6116 |
|
|
6117 |
# Printable characters for escapes |
|
6118 |
my %UNESCAPES = ( |
|
6119 |
z => "\x00", a => "\x07", t => "\x09", |
|
6120 |
n => "\x0a", v => "\x0b", f => "\x0c", |
|
6121 |
r => "\x0d", e => "\x1b", '\\' => '\\', |
|
6122 |
); |
|
6123 |
|
|
6124 |
# Special magic boolean words |
|
6125 |
my %QUOTE = map { $_ => 1 } qw{ |
|
6126 |
null Null NULL |
|
6127 |
y Y yes Yes YES n N no No NO |
|
6128 |
true True TRUE false False FALSE |
|
6129 |
on On ON off Off OFF |
|
6130 |
}; |
|
6131 |
|
|
6132 |
|
|
6133 |
|
|
6134 |
|
|
6135 |
|
|
6136 |
##################################################################### |
|
6137 |
# Implementation |
|
6138 |
|
|
6139 |
# Create an empty CPAN::Meta::YAML object |
|
6140 |
sub new { |
|
6141 |
my $class = shift; |
|
6142 |
bless [ @_ ], $class; |
|
6143 |
} |
|
6144 |
|
|
6145 |
# Create an object from a file |
|
6146 |
sub read { |
|
6147 |
my $class = ref $_[0] ? ref shift : shift; |
|
6148 |
|
|
6149 |
# Check the file |
|
6150 |
my $file = shift or return $class->_error( 'You did not specify a file name' ); |
|
6151 |
return $class->_error( "File '$file' does not exist" ) unless -e $file; |
|
6152 |
return $class->_error( "'$file' is a directory, not a file" ) unless -f _; |
|
6153 |
return $class->_error( "Insufficient permissions to read '$file'" ) unless -r _; |
|
6154 |
|
|
6155 |
# Slurp in the file |
|
6156 |
local $/ = undef; |
|
6157 |
local *CFG; |
|
6158 |
unless ( open(CFG, $file) ) { |
|
6159 |
return $class->_error("Failed to open file '$file': $!"); |
|
6160 |
} |
|
6161 |
my $contents = <CFG>; |
|
6162 |
unless ( close(CFG) ) { |
|
6163 |
return $class->_error("Failed to close file '$file': $!"); |
|
6164 |
} |
|
6165 |
|
|
6166 |
$class->read_string( $contents ); |
|
6167 |
} |
|
6168 |
|
|
6169 |
# Create an object from a string |
|
6170 |
sub read_string { |
|
6171 |
my $class = ref $_[0] ? ref shift : shift; |
|
6172 |
my $self = bless [], $class; |
|
6173 |
my $string = $_[0]; |
|
6174 |
eval { |
|
6175 |
unless ( defined $string ) { |
|
6176 |
die \"Did not provide a string to load"; |
|
6177 |
} |
|
6178 |
|
|
6179 |
# Byte order marks |
|
6180 |
# NOTE: Keeping this here to educate maintainers |
|
6181 |
# my %BOM = ( |
|
6182 |
# "\357\273\277" => 'UTF-8', |
|
6183 |
# "\376\377" => 'UTF-16BE', |
|
6184 |
# "\377\376" => 'UTF-16LE', |
|
6185 |
# "\377\376\0\0" => 'UTF-32LE' |
|
6186 |
# "\0\0\376\377" => 'UTF-32BE', |
|
6187 |
# ); |
|
6188 |
if ( $string =~ /^(?:\376\377|\377\376|\377\376\0\0|\0\0\376\377)/ ) { |
|
6189 |
die \"Stream has a non UTF-8 BOM"; |
|
6190 |
} else { |
|
6191 |
# Strip UTF-8 bom if found, we'll just ignore it |
|
6192 |
$string =~ s/^\357\273\277//; |
|
6193 |
} |
|
6194 |
|
|
6195 |
# Try to decode as utf8 |
|
6196 |
utf8::decode($string) if HAVE_UTF8; |
|
6197 |
|
|
6198 |
# Check for some special cases |
|
6199 |
return $self unless length $string; |
|
6200 |
unless ( $string =~ /[\012\015]+\z/ ) { |
|
6201 |
die \"Stream does not end with newline character"; |
|
6202 |
} |
|
6203 |
|
|
6204 |
# Split the file into lines |
|
6205 |
my @lines = grep { ! /^\s*(?:\#.*)?\z/ } |
|
6206 |
split /(?:\015{1,2}\012|\015|\012)/, $string; |
|
6207 |
|
|
6208 |
# Strip the initial YAML header |
|
6209 |
@lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines; |
|
6210 |
|
|
6211 |
# A nibbling parser |
|
6212 |
while ( @lines ) { |
|
6213 |
# Do we have a document header? |
|
6214 |
if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) { |
|
6215 |
# Handle scalar documents |
|
6216 |
shift @lines; |
|
6217 |
if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) { |
|
6218 |
push @$self, $self->_read_scalar( "$1", [ undef ], \@lines ); |
|
6219 |
next; |
|
6220 |
} |
|
6221 |
} |
|
6222 |
|
|
6223 |
if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) { |
|
6224 |
# A naked document |
|
6225 |
push @$self, undef; |
|
6226 |
while ( @lines and $lines[0] !~ /^---/ ) { |
|
6227 |
shift @lines; |
|
6228 |
} |
|
6229 |
|
|
6230 |
} elsif ( $lines[0] =~ /^\s*\-/ ) { |
|
6231 |
# An array at the root |
|
6232 |
my $document = [ ]; |
|
6233 |
push @$self, $document; |
|
6234 |
$self->_read_array( $document, [ 0 ], \@lines ); |
|
6235 |
|
|
6236 |
} elsif ( $lines[0] =~ /^(\s*)\S/ ) { |
|
6237 |
# A hash at the root |
|
6238 |
my $document = { }; |
|
6239 |
push @$self, $document; |
|
6240 |
$self->_read_hash( $document, [ length($1) ], \@lines ); |
|
6241 |
|
|
6242 |
} else { |
|
6243 |
die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'"; |
|
6244 |
} |
|
6245 |
} |
|
6246 |
}; |
|
6247 |
if ( ref $@ eq 'SCALAR' ) { |
|
6248 |
return $self->_error(${$@}); |
|
6249 |
} elsif ( $@ ) { |
|
6250 |
require Carp; |
|
6251 |
Carp::croak($@); |
|
6252 |
} |
|
6253 |
|
|
6254 |
return $self; |
|
6255 |
} |
|
6256 |
|
|
6257 |
# Deparse a scalar string to the actual scalar |
|
6258 |
sub _read_scalar { |
|
6259 |
my ($self, $string, $indent, $lines) = @_; |
|
6260 |
|
|
6261 |
# Trim trailing whitespace |
|
6262 |
$string =~ s/\s*\z//; |
|
6263 |
|
|
6264 |
# Explitic null/undef |
|
6265 |
return undef if $string eq '~'; |
|
6266 |
|
|
6267 |
# Single quote |
|
6268 |
if ( $string =~ /^\'(.*?)\'(?:\s+\#.*)?\z/ ) { |
|
6269 |
return '' unless defined $1; |
|
6270 |
$string = $1; |
|
6271 |
$string =~ s/\'\'/\'/g; |
|
6272 |
return $string; |
|
6273 |
} |
|
6274 |
|
|
6275 |
# Double quote. |
|
6276 |
# The commented out form is simpler, but overloaded the Perl regex |
|
6277 |
# engine due to recursion and backtracking problems on strings |
|
6278 |
# larger than 32,000ish characters. Keep it for reference purposes. |
|
6279 |
# if ( $string =~ /^\"((?:\\.|[^\"])*)\"\z/ ) { |
|
6280 |
if ( $string =~ /^\"([^\\"]*(?:\\.[^\\"]*)*)\"(?:\s+\#.*)?\z/ ) { |
|
6281 |
# Reusing the variable is a little ugly, |
|
6282 |
# but avoids a new variable and a string copy. |
|
6283 |
$string = $1; |
|
6284 |
$string =~ s/\\"/"/g; |
|
6285 |
$string =~ s/\\([never\\fartz]|x([0-9a-fA-F]{2}))/(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}/gex; |
|
6286 |
return $string; |
|
6287 |
} |
|
6288 |
|
|
6289 |
# Special cases |
|
6290 |
if ( $string =~ /^[\'\"!&]/ ) { |
|
6291 |
die \"CPAN::Meta::YAML does not support a feature in line '$string'"; |
|
6292 |
} |
|
6293 |
return {} if $string =~ /^{}(?:\s+\#.*)?\z/; |
|
6294 |
return [] if $string =~ /^\[\](?:\s+\#.*)?\z/; |
|
6295 |
|
|
6296 |
# Regular unquoted string |
|
6297 |
if ( $string !~ /^[>|]/ ) { |
|
6298 |
if ( |
|
6299 |
$string =~ /^(?:-(?:\s|$)|[\@\%\`])/ |
|
6300 |
or |
|
6301 |
$string =~ /:(?:\s|$)/ |
|
6302 |
) { |
|
6303 |
die \"CPAN::Meta::YAML found illegal characters in plain scalar: '$string'"; |
|
6304 |
} |
|
6305 |
$string =~ s/\s+#.*\z//; |
|
6306 |
return $string; |
|
6307 |
} |
|
6308 |
|
|
6309 |
# Error |
|
6310 |
die \"CPAN::Meta::YAML failed to find multi-line scalar content" unless @$lines; |
|
6311 |
|
|
6312 |
# Check the indent depth |
|
6313 |
$lines->[0] =~ /^(\s*)/; |
|
6314 |
$indent->[-1] = length("$1"); |
|
6315 |
if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) { |
|
6316 |
die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'"; |
|
6317 |
} |
|
6318 |
|
|
6319 |
# Pull the lines |
|
6320 |
my @multiline = (); |
|
6321 |
while ( @$lines ) { |
|
6322 |
$lines->[0] =~ /^(\s*)/; |
|
6323 |
last unless length($1) >= $indent->[-1]; |
|
6324 |
push @multiline, substr(shift(@$lines), length($1)); |
|
6325 |
} |
|
6326 |
|
|
6327 |
my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n"; |
|
6328 |
my $t = (substr($string, 1, 1) eq '-') ? '' : "\n"; |
|
6329 |
return join( $j, @multiline ) . $t; |
|
6330 |
} |
|
6331 |
|
|
6332 |
# Parse an array |
|
6333 |
sub _read_array { |
|
6334 |
my ($self, $array, $indent, $lines) = @_; |
|
6335 |
|
|
6336 |
while ( @$lines ) { |
|
6337 |
# Check for a new document |
|
6338 |
if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) { |
|
6339 |
while ( @$lines and $lines->[0] !~ /^---/ ) { |
|
6340 |
shift @$lines; |
|
6341 |
} |
|
6342 |
return 1; |
|
6343 |
} |
|
6344 |
|
|
6345 |
# Check the indent level |
|
6346 |
$lines->[0] =~ /^(\s*)/; |
|
6347 |
if ( length($1) < $indent->[-1] ) { |
|
6348 |
return 1; |
|
6349 |
} elsif ( length($1) > $indent->[-1] ) { |
|
6350 |
die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'"; |
|
6351 |
} |
|
6352 |
|
|
6353 |
if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) { |
|
6354 |
# Inline nested hash |
|
6355 |
my $indent2 = length("$1"); |
|
6356 |
$lines->[0] =~ s/-/ /; |
|
6357 |
push @$array, { }; |
|
6358 |
$self->_read_hash( $array->[-1], [ @$indent, $indent2 ], $lines ); |
|
6359 |
|
|
6360 |
} elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) { |
|
6361 |
# Array entry with a value |
|
6362 |
shift @$lines; |
|
6363 |
push @$array, $self->_read_scalar( "$2", [ @$indent, undef ], $lines ); |
|
6364 |
|
|
6365 |
} elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) { |
|
6366 |
shift @$lines; |
|
6367 |
unless ( @$lines ) { |
|
6368 |
push @$array, undef; |
|
6369 |
return 1; |
|
6370 |
} |
|
6371 |
if ( $lines->[0] =~ /^(\s*)\-/ ) { |
|
6372 |
my $indent2 = length("$1"); |
|
6373 |
if ( $indent->[-1] == $indent2 ) { |
|
6374 |
# Null array entry |
|
6375 |
push @$array, undef; |
|
6376 |
} else { |
|
6377 |
# Naked indenter |
|
6378 |
push @$array, [ ]; |
|
6379 |
$self->_read_array( $array->[-1], [ @$indent, $indent2 ], $lines ); |
|
6380 |
} |
|
6381 |
|
|
6382 |
} elsif ( $lines->[0] =~ /^(\s*)\S/ ) { |
|
6383 |
push @$array, { }; |
|
6384 |
$self->_read_hash( $array->[-1], [ @$indent, length("$1") ], $lines ); |
|
6385 |
|
|
6386 |
} else { |
|
6387 |
die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'"; |
|
6388 |
} |
|
6389 |
|
|
6390 |
} elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) { |
|
6391 |
# This is probably a structure like the following... |
|
6392 |
# --- |
|
6393 |
# foo: |
|
6394 |
# - list |
|
6395 |
# bar: value |
|
6396 |
# |
|
6397 |
# ... so lets return and let the hash parser handle it |
|
6398 |
return 1; |
|
6399 |
|
|
6400 |
} else { |
|
6401 |
die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'"; |
|
6402 |
} |
|
6403 |
} |
|
6404 |
|
|
6405 |
return 1; |
|
6406 |
} |
|
6407 |
|
|
6408 |
# Parse an array |
|
6409 |
sub _read_hash { |
|
6410 |
my ($self, $hash, $indent, $lines) = @_; |
|
6411 |
|
|
6412 |
while ( @$lines ) { |
|
6413 |
# Check for a new document |
|
6414 |
if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) { |
|
6415 |
while ( @$lines and $lines->[0] !~ /^---/ ) { |
|
6416 |
shift @$lines; |
|
6417 |
} |
|
6418 |
return 1; |
|
6419 |
} |
|
6420 |
|
|
6421 |
# Check the indent level |
|
6422 |
$lines->[0] =~ /^(\s*)/; |
|
6423 |
if ( length($1) < $indent->[-1] ) { |
|
6424 |
return 1; |
|
6425 |
} elsif ( length($1) > $indent->[-1] ) { |
|
6426 |
die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'"; |
|
6427 |
} |
|
6428 |
|
|
6429 |
# Get the key |
|
6430 |
unless ( $lines->[0] =~ s/^\s*([^\'\" ][^\n]*?)\s*:(\s+(?:\#.*)?|$)// ) { |
|
6431 |
if ( $lines->[0] =~ /^\s*[?\'\"]/ ) { |
|
6432 |
die \"CPAN::Meta::YAML does not support a feature in line '$lines->[0]'"; |
|
6433 |
} |
|
6434 |
die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'"; |
|
6435 |
} |
|
6436 |
my $key = $1; |
|
6437 |
|
|
6438 |
# Do we have a value? |
|
6439 |
if ( length $lines->[0] ) { |
|
6440 |
# Yes |
|
6441 |
$hash->{$key} = $self->_read_scalar( shift(@$lines), [ @$indent, undef ], $lines ); |
|
6442 |
} else { |
|
6443 |
# An indent |
|
6444 |
shift @$lines; |
|
6445 |
unless ( @$lines ) { |
|
6446 |
$hash->{$key} = undef; |
|
6447 |
return 1; |
|
6448 |
} |
|
6449 |
if ( $lines->[0] =~ /^(\s*)-/ ) { |
|
6450 |
$hash->{$key} = []; |
|
6451 |
$self->_read_array( $hash->{$key}, [ @$indent, length($1) ], $lines ); |
|
6452 |
} elsif ( $lines->[0] =~ /^(\s*)./ ) { |
|
6453 |
my $indent2 = length("$1"); |
|
6454 |
if ( $indent->[-1] >= $indent2 ) { |
|
6455 |
# Null hash entry |
|
6456 |
$hash->{$key} = undef; |
|
6457 |
} else { |
|
6458 |
$hash->{$key} = {}; |
|
6459 |
$self->_read_hash( $hash->{$key}, [ @$indent, length($1) ], $lines ); |
|
6460 |
} |
|
6461 |
} |
|
6462 |
} |
|
6463 |
} |
|
6464 |
|
|
6465 |
return 1; |
|
6466 |
} |
|
6467 |
|
|
6468 |
# Save an object to a file |
|
6469 |
sub write { |
|
6470 |
my $self = shift; |
|
6471 |
my $file = shift or return $self->_error('No file name provided'); |
|
6472 |
|
|
6473 |
# Write it to the file |
|
6474 |
open( CFG, '>' . $file ) or return $self->_error( |
|
6475 |
"Failed to open file '$file' for writing: $!" |
|
6476 |
); |
|
6477 |
print CFG $self->write_string; |
|
6478 |
close CFG; |
|
6479 |
|
|
6480 |
return 1; |
|
6481 |
} |
|
6482 |
|
|
6483 |
# Save an object to a string |
|
6484 |
sub write_string { |
|
6485 |
my $self = shift; |
|
6486 |
return '' unless @$self; |
|
6487 |
|
|
6488 |
# Iterate over the documents |
|
6489 |
my $indent = 0; |
|
6490 |
my @lines = (); |
|
6491 |
foreach my $cursor ( @$self ) { |
|
6492 |
push @lines, '---'; |
|
6493 |
|
|
6494 |
# An empty document |
|
6495 |
if ( ! defined $cursor ) { |
|
6496 |
# Do nothing |
|
6497 |
|
|
6498 |
# A scalar document |
|
6499 |
} elsif ( ! ref $cursor ) { |
|
6500 |
$lines[-1] .= ' ' . $self->_write_scalar( $cursor, $indent ); |
|
6501 |
|
|
6502 |
# A list at the root |
|
6503 |
} elsif ( ref $cursor eq 'ARRAY' ) { |
|
6504 |
unless ( @$cursor ) { |
|
6505 |
$lines[-1] .= ' []'; |
|
6506 |
next; |
|
6507 |
} |
|
6508 |
push @lines, $self->_write_array( $cursor, $indent, {} ); |
|
6509 |
|
|
6510 |
# A hash at the root |
|
6511 |
} elsif ( ref $cursor eq 'HASH' ) { |
|
6512 |
unless ( %$cursor ) { |
|
6513 |
$lines[-1] .= ' {}'; |
|
6514 |
next; |
|
6515 |
} |
|
6516 |
push @lines, $self->_write_hash( $cursor, $indent, {} ); |
|
6517 |
|
|
6518 |
} else { |
|
6519 |
Carp::croak("Cannot serialize " . ref($cursor)); |
|
6520 |
} |
|
6521 |
} |
|
6522 |
|
|
6523 |
join '', map { "$_\n" } @lines; |
|
6524 |
} |
|
6525 |
|
|
6526 |
sub _write_scalar { |
|
6527 |
my $string = $_[1]; |
|
6528 |
return '~' unless defined $string; |
|
6529 |
return "''" unless length $string; |
|
6530 |
if ( $string =~ /[\x00-\x08\x0b-\x0d\x0e-\x1f\"\'\n]/ ) { |
|
6531 |
$string =~ s/\\/\\\\/g; |
|
6532 |
$string =~ s/"/\\"/g; |
|
6533 |
$string =~ s/\n/\\n/g; |
|
6534 |
$string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g; |
|
6535 |
return qq|"$string"|; |
|
6536 |
} |
|
6537 |
if ( $string =~ /(?:^\W|\s|:\z)/ or $QUOTE{$string} ) { |
|
6538 |
return "'$string'"; |
|
6539 |
} |
|
6540 |
return $string; |
|
6541 |
} |
|
6542 |
|
|
6543 |
sub _write_array { |
|
6544 |
my ($self, $array, $indent, $seen) = @_; |
|
6545 |
if ( $seen->{refaddr($array)}++ ) { |
|
6546 |
die "CPAN::Meta::YAML does not support circular references"; |
|
6547 |
} |
|
6548 |
my @lines = (); |
|
6549 |
foreach my $el ( @$array ) { |
|
6550 |
my $line = (' ' x $indent) . '-'; |
|
6551 |
my $type = ref $el; |
|
6552 |
if ( ! $type ) { |
|
6553 |
$line .= ' ' . $self->_write_scalar( $el, $indent + 1 ); |
|
6554 |
push @lines, $line; |
|
6555 |
|
|
6556 |
} elsif ( $type eq 'ARRAY' ) { |
|
6557 |
if ( @$el ) { |
|
6558 |
push @lines, $line; |
|
6559 |
push @lines, $self->_write_array( $el, $indent + 1, $seen ); |
|
6560 |
} else { |
|
6561 |
$line .= ' []'; |
|
6562 |
push @lines, $line; |
|
6563 |
} |
|
6564 |
|
|
6565 |
} elsif ( $type eq 'HASH' ) { |
|
6566 |
if ( keys %$el ) { |
|
6567 |
push @lines, $line; |
|
6568 |
push @lines, $self->_write_hash( $el, $indent + 1, $seen ); |
|
6569 |
} else { |
|
6570 |
$line .= ' {}'; |
|
6571 |
push @lines, $line; |
|
6572 |
} |
|
6573 |
|
|
6574 |
} else { |
|
6575 |
die "CPAN::Meta::YAML does not support $type references"; |
|
6576 |
} |
|
6577 |
} |
|
6578 |
|
|
6579 |
@lines; |
|
6580 |
} |
|
6581 |
|
|
6582 |
sub _write_hash { |
|
6583 |
my ($self, $hash, $indent, $seen) = @_; |
|
6584 |
if ( $seen->{refaddr($hash)}++ ) { |
|
6585 |
die "CPAN::Meta::YAML does not support circular references"; |
|
6586 |
} |
|
6587 |
my @lines = (); |
|
6588 |
foreach my $name ( sort keys %$hash ) { |
|
6589 |
my $el = $hash->{$name}; |
|
6590 |
my $line = (' ' x $indent) . "$name:"; |
|
6591 |
my $type = ref $el; |
|
6592 |
if ( ! $type ) { |
|
6593 |
$line .= ' ' . $self->_write_scalar( $el, $indent + 1 ); |
|
6594 |
push @lines, $line; |
|
6595 |
|
|
6596 |
} elsif ( $type eq 'ARRAY' ) { |
|
6597 |
if ( @$el ) { |
|
6598 |
push @lines, $line; |
|
6599 |
push @lines, $self->_write_array( $el, $indent + 1, $seen ); |
|
6600 |
} else { |
|
6601 |
$line .= ' []'; |
|
6602 |
push @lines, $line; |
|
6603 |
} |
|
6604 |
|
|
6605 |
} elsif ( $type eq 'HASH' ) { |
|
6606 |
if ( keys %$el ) { |
|
6607 |
push @lines, $line; |
|
6608 |
push @lines, $self->_write_hash( $el, $indent + 1, $seen ); |
|
6609 |
} else { |
|
6610 |
$line .= ' {}'; |
|
6611 |
push @lines, $line; |
|
6612 |
} |
|
6613 |
|
|
6614 |
} else { |
|
6615 |
die "CPAN::Meta::YAML does not support $type references"; |
|
6616 |
} |
|
6617 |
} |
|
6618 |
|
|
6619 |
@lines; |
|
6620 |
} |
|
6621 |
|
|
6622 |
# Set error |
|
6623 |
sub _error { |
|
6624 |
$CPAN::Meta::YAML::errstr = $_[1]; |
|
6625 |
undef; |
|
6626 |
} |
|
6627 |
|
|
6628 |
# Retrieve error |
|
6629 |
sub errstr { |
|
6630 |
$CPAN::Meta::YAML::errstr; |
|
6631 |
} |
|
6632 |
|
|
6633 |
|
|
6634 |
|
|
6635 |
|
|
6636 |
|
|
6637 |
##################################################################### |
|
6638 |
# YAML Compatibility |
|
6639 |
|
|
6640 |
sub Dump { |
|
6641 |
CPAN::Meta::YAML->new(@_)->write_string; |
|
6642 |
} |
|
6643 |
|
|
6644 |
sub Load { |
|
6645 |
my $self = CPAN::Meta::YAML->read_string(@_); |
|
6646 |
unless ( $self ) { |
|
6647 |
Carp::croak("Failed to load YAML document from string"); |
|
6648 |
} |
|
6649 |
if ( wantarray ) { |
|
6650 |
return @$self; |
|
6651 |
} else { |
|
6652 |
# To match YAML.pm, return the last document |
|
6653 |
return $self->[-1]; |
|
6654 |
} |
|
6655 |
} |
|
6656 |
|
|
6657 |
BEGIN { |
|
6658 |
*freeze = *Dump; |
|
6659 |
*thaw = *Load; |
|
6660 |
} |
|
6661 |
|
|
6662 |
sub DumpFile { |
|
6663 |
my $file = shift; |
|
6664 |
CPAN::Meta::YAML->new(@_)->write($file); |
|
6665 |
} |
|
6666 |
|
|
6667 |
sub LoadFile { |
|
6668 |
my $self = CPAN::Meta::YAML->read($_[0]); |
|
6669 |
unless ( $self ) { |
|
6670 |
Carp::croak("Failed to load YAML document from '" . ($_[0] || '') . "'"); |
|
6671 |
} |
|
6672 |
if ( wantarray ) { |
|
6673 |
return @$self; |
|
6674 |
} else { |
|
6675 |
# Return only the last document to match YAML.pm, |
|
6676 |
return $self->[-1]; |
|
6677 |
} |
|
6678 |
} |
|
6679 |
|
|
6680 |
|
|
6681 |
|
|
6682 |
|
|
6683 |
|
|
6684 |
##################################################################### |
|
6685 |
# Use Scalar::Util if possible, otherwise emulate it |
|
6686 |
|
|
6687 |
BEGIN { |
|
6688 |
local $@; |
|
6689 |
eval { |
|
6690 |
require Scalar::Util; |
|
6691 |
}; |
|
6692 |
my $v = eval("$Scalar::Util::VERSION") || 0; |
|
6693 |
if ( $@ or $v < 1.18 ) { |
|
6694 |
eval <<'END_PERL'; |
|
6695 |
# Scalar::Util failed to load or too old |
|
6696 |
sub refaddr { |
|
6697 |
my $pkg = ref($_[0]) or return undef; |
|
6698 |
if ( !! UNIVERSAL::can($_[0], 'can') ) { |
|
6699 |
bless $_[0], 'Scalar::Util::Fake'; |
|
6700 |
} else { |
|
6701 |
$pkg = undef; |
|
6702 |
} |
|
6703 |
"$_[0]" =~ /0x(\w+)/; |
|
6704 |
my $i = do { local $^W; hex $1 }; |
|
6705 |
bless $_[0], $pkg if defined $pkg; |
|
6706 |
$i; |
|
6707 |
} |
|
6708 |
END_PERL |
|
6709 |
} else { |
|
6710 |
*refaddr = *Scalar::Util::refaddr; |
|
6711 |
} |
|
6712 |
} |
|
6713 |
|
|
6714 |
1; |
|
6715 |
|
|
6716 |
|
|
6717 |
|
|
6718 |
|
|
6719 |
__END__ |
|
6720 |
|
|
6721 |
|
|
6722 |
# ABSTRACT: Read and write a subset of YAML for CPAN Meta files |
|
6723 |
|
|
6724 |
|
|
6725 |
CPAN_META_YAML |
|
6726 | ||
6727 |
$fatpacked{"File/pushd.pm"} = <<'FILE_PUSHD'; |
|
6728 |
use strict; |
|
6729 |
use warnings; |
|
6730 |
package File::pushd; |
|
6731 |
# ABSTRACT: change directory temporarily for a limited scope |
|
6732 |
our $VERSION = '1.004'; # VERSION |
|
6733 |
|
|
6734 |
our @EXPORT = qw( pushd tempd ); |
|
6735 |
our @ISA = qw( Exporter ); |
|
6736 |
|
|
6737 |
use Exporter; |
|
6738 |
use Carp; |
|
6739 |
use Cwd qw( cwd abs_path ); |
|
6740 |
use File::Path qw( rmtree ); |
|
6741 |
use File::Temp qw(); |
|
6742 |
use File::Spec; |
|
6743 |
|
|
6744 |
use overload |
|
6745 |
q{""} => sub { File::Spec->canonpath( $_[0]->{_pushd} ) }, |
|
6746 |
fallback => 1; |
|
6747 |
|
|
6748 |
#--------------------------------------------------------------------------# |
|
6749 |
# pushd() |
|
6750 |
#--------------------------------------------------------------------------# |
|
6751 |
|
|
6752 |
sub pushd { |
|
6753 |
my ($target_dir, $options) = @_; |
|
6754 |
$options->{untaint_pattern} ||= qr{^([-+@\w./]+)$}; |
|
6755 |
|
|
6756 |
my $tainted_orig = cwd; |
|
6757 |
my $orig; |
|
6758 |
if ( $tainted_orig =~ $options->{untaint_pattern} ) { |
|
6759 |
$orig = $1; |
|
6760 |
} |
|
6761 |
else { |
|
6762 |
$orig = $tainted_orig; |
|
6763 |
} |
|
6764 |
|
|
6765 |
my $tainted_dest; |
|
6766 |
eval { $tainted_dest = $target_dir ? abs_path( $target_dir ) : $orig }; |
|
6767 |
croak "Can't locate directory $target_dir: $@" if $@; |
|
6768 |
|
|
6769 |
my $dest; |
|
6770 |
if ( $tainted_dest =~ $options->{untaint_pattern} ) { |
|
6771 |
$dest = $1; |
|
6772 |
} |
|
6773 |
else { |
|
6774 |
$dest = $tainted_dest; |
|
6775 |
} |
|
6776 |
|
|
6777 |
if ($dest ne $orig) { |
|
6778 |
chdir $dest or croak "Can't chdir to $dest\: $!"; |
|
6779 |
} |
|
6780 |
|
|
6781 |
my $self = bless { |
|
6782 |
_pushd => $dest, |
|
6783 |
_original => $orig |
|
6784 |
}, __PACKAGE__; |
|
6785 |
|
|
6786 |
return $self; |
|
6787 |
} |
|
6788 |
|
|
6789 |
#--------------------------------------------------------------------------# |
|
6790 |
# tempd() |
|
6791 |
#--------------------------------------------------------------------------# |
|
6792 |
|
|
6793 |
sub tempd { |
|
6794 |
my ($options) = @_; |
|
6795 |
my $dir; |
|
6796 |
eval { $dir = pushd( File::Temp::tempdir( CLEANUP => 0 ), $options ) }; |
|
6797 |
croak $@ if $@; |
|
6798 |
$dir->{_tempd} = 1; |
|
6799 |
return $dir; |
|
6800 |
} |
|
6801 |
|
|
6802 |
#--------------------------------------------------------------------------# |
|
6803 |
# preserve() |
|
6804 |
#--------------------------------------------------------------------------# |
|
6805 |
|
|
6806 |
sub preserve { |
|
6807 |
my $self = shift; |
|
6808 |
return 1 if ! $self->{"_tempd"}; |
|
6809 |
if ( @_ == 0 ) { |
|
6810 |
return $self->{_preserve} = 1; |
|
6811 |
} |
|
6812 |
else { |
|
6813 |
return $self->{_preserve} = $_[0] ? 1 : 0; |
|
6814 |
} |
|
6815 |
} |
|
6816 |
|
|
6817 |
#--------------------------------------------------------------------------# |
|
6818 |
# DESTROY() |
|
6819 |
# Revert to original directory as object is destroyed and cleanup |
|
6820 |
# if necessary |
|
6821 |
#--------------------------------------------------------------------------# |
|
6822 |
|
|
6823 |
sub DESTROY { |
|
6824 |
my ($self) = @_; |
|
6825 |
my $orig = $self->{_original}; |
|
6826 |
chdir $orig if $orig; # should always be so, but just in case... |
|
6827 |
if ( $self->{_tempd} && |
|
6828 |
!$self->{_preserve} ) { |
|
6829 |
# don't destroy existing $@ if there is no error. |
|
6830 |
my $err = do { |
|
6831 |
local $@; |
|
6832 |
eval { rmtree( $self->{_pushd} ) }; |
|
6833 |
$@; |
|
6834 |
}; |
|
6835 |
carp $err if $err; |
|
6836 |
} |
|
6837 |
} |
|
6838 |
|
|
6839 |
1; |
|
6840 |
|
|
6841 |
__END__ |
|
6842 |
|
|
6843 |
FILE_PUSHD |
|
6844 | ||
6845 |
$fatpacked{"HTTP/Tiny.pm"} = <<'HTTP_TINY'; |
|
6846 |
# vim: ts=4 sts=4 sw=4 et: |
|
6847 |
package HTTP::Tiny; |
|
6848 |
use strict; |
|
6849 |
use warnings; |
|
6850 |
# ABSTRACT: A small, simple, correct HTTP/1.1 client |
|
6851 |
our $VERSION = '0.028'; # VERSION |
|
6852 |
|
|
6853 |
use Carp (); |
|
6854 |
|
|
6855 |
|
|
6856 |
my @attributes; |
|
6857 |
BEGIN { |
|
6858 |
@attributes = qw(agent cookie_jar default_headers local_address max_redirect max_size proxy timeout SSL_options verify_SSL); |
|
6859 |
no strict 'refs'; |
|
6860 |
for my $accessor ( @attributes ) { |
|
6861 |
*{$accessor} = sub { |
|
6862 |
@_ > 1 ? $_[0]->{$accessor} = $_[1] : $_[0]->{$accessor}; |
|
6863 |
}; |
|
6864 |
} |
|
6865 |
} |
|
6866 |
|
|
6867 |
sub new { |
|
6868 |
my($class, %args) = @_; |
|
6869 |
|
|
6870 |
(my $default_agent = $class) =~ s{::}{-}g; |
|
6871 |
$default_agent .= "/" . ($class->VERSION || 0); |
|
6872 |
|
|
6873 |
my $self = { |
|
6874 |
agent => $default_agent, |
|
6875 |
max_redirect => 5, |
|
6876 |
timeout => 60, |
|
6877 |
verify_SSL => $args{verify_SSL} || $args{verify_ssl} || 0, # no verification by default |
|
6878 |
}; |
|
6879 |
|
|
6880 |
$args{agent} .= $default_agent |
|
6881 |
if defined $args{agent} && $args{agent} =~ / $/; |
|
6882 |
|
|
6883 |
$class->_validate_cookie_jar( $args{cookie_jar} ) if $args{cookie_jar}; |
|
6884 |
|
|
6885 |
for my $key ( @attributes ) { |
|
6886 |
$self->{$key} = $args{$key} if exists $args{$key} |
|
6887 |
} |
|
6888 |
|
|
6889 |
# Never override proxy argument as this breaks backwards compat. |
|
6890 |
if (!exists $self->{proxy} && (my $http_proxy = $ENV{http_proxy})) { |
|
6891 |
if ($http_proxy =~ m{\Ahttp://[^/?#:@]+:\d+/?\z}) { |
|
6892 |
$self->{proxy} = $http_proxy; |
|
6893 |
} |
|
6894 |
else { |
|
6895 |
Carp::croak(qq{Environment 'http_proxy' must be in format http://<host>:<port>/\n}); |
|
6896 |
} |
|
6897 |
} |
|
6898 |
|
|
6899 |
return bless $self, $class; |
|
6900 |
} |
|
6901 |
|
|
6902 |
|
|
6903 |
for my $sub_name ( qw/get head put post delete/ ) { |
|
6904 |
my $req_method = uc $sub_name; |
|
6905 |
no strict 'refs'; |
|
6906 |
eval <<"HERE"; ## no critic |
|
6907 |
sub $sub_name { |
|
6908 |
my (\$self, \$url, \$args) = \@_; |
|
6909 |
\@_ == 2 || (\@_ == 3 && ref \$args eq 'HASH') |
|
6910 |
or Carp::croak(q/Usage: \$http->$sub_name(URL, [HASHREF])/ . "\n"); |
|
6911 |
return \$self->request('$req_method', \$url, \$args || {}); |
|
6912 |
} |
|
6913 |
HERE |
|
6914 |
} |
|
6915 |
|
|
6916 |
|
|
6917 |
sub post_form { |
|
6918 |
my ($self, $url, $data, $args) = @_; |
|
6919 |
(@_ == 3 || @_ == 4 && ref $args eq 'HASH') |
|
6920 |
or Carp::croak(q/Usage: $http->post_form(URL, DATAREF, [HASHREF])/ . "\n"); |
|
6921 |
|
|
6922 |
my $headers = {}; |
|
6923 |
while ( my ($key, $value) = each %{$args->{headers} || {}} ) { |
|
6924 |
$headers->{lc $key} = $value; |
|
6925 |
} |
|
6926 |
delete $args->{headers}; |
|
6927 |
|
|
6928 |
return $self->request('POST', $url, { |
|
6929 |
%$args, |
|
6930 |
content => $self->www_form_urlencode($data), |
|
6931 |
headers => { |
|
6932 |
%$headers, |
|
6933 |
'content-type' => 'application/x-www-form-urlencoded' |
|
6934 |
}, |
|
6935 |
} |
|
6936 |
); |
|
6937 |
} |
|
6938 |
|
|
6939 |
|
|
6940 |
sub mirror { |
|
6941 |
my ($self, $url, $file, $args) = @_; |
|
6942 |
@_ == 3 || (@_ == 4 && ref $args eq 'HASH') |
|
6943 |
or Carp::croak(q/Usage: $http->mirror(URL, FILE, [HASHREF])/ . "\n"); |
|
6944 |
if ( -e $file and my $mtime = (stat($file))[9] ) { |
|
6945 |
$args->{headers}{'if-modified-since'} ||= $self->_http_date($mtime); |
|
6946 |
} |
|
6947 |
my $tempfile = $file . int(rand(2**31)); |
|
6948 |
open my $fh, ">", $tempfile |
|
6949 |
or Carp::croak(qq/Error: Could not open temporary file $tempfile for downloading: $!\n/); |
|
6950 |
binmode $fh; |
|
6951 |
$args->{data_callback} = sub { print {$fh} $_[0] }; |
|
6952 |
my $response = $self->request('GET', $url, $args); |
|
6953 |
close $fh |
|
6954 |
or Carp::croak(qq/Error: Could not close temporary file $tempfile: $!\n/); |
|
6955 |
if ( $response->{success} ) { |
|
6956 |
rename $tempfile, $file |
|
6957 |
or Carp::croak(qq/Error replacing $file with $tempfile: $!\n/); |
|
6958 |
my $lm = $response->{headers}{'last-modified'}; |
|
6959 |
if ( $lm and my $mtime = $self->_parse_http_date($lm) ) { |
|
6960 |
utime $mtime, $mtime, $file; |
|
6961 |
} |
|
6962 |
} |
|
6963 |
$response->{success} ||= $response->{status} eq '304'; |
|
6964 |
unlink $tempfile; |
|
6965 |
return $response; |
|
6966 |
} |
|
6967 |
|
|
6968 |
|
|
6969 |
my %idempotent = map { $_ => 1 } qw/GET HEAD PUT DELETE OPTIONS TRACE/; |
|
6970 |
|
|
6971 |
sub request { |
|
6972 |
my ($self, $method, $url, $args) = @_; |
|
6973 |
@_ == 3 || (@_ == 4 && ref $args eq 'HASH') |
|
6974 |
or Carp::croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/ . "\n"); |
|
6975 |
$args ||= {}; # we keep some state in this during _request |
|
6976 |
|
|
6977 |
# RFC 2616 Section 8.1.4 mandates a single retry on broken socket |
|
6978 |
my $response; |
|
6979 |
for ( 0 .. 1 ) { |
|
6980 |
$response = eval { $self->_request($method, $url, $args) }; |
|
6981 |
last unless $@ && $idempotent{$method} |
|
6982 |
&& $@ =~ m{^(?:Socket closed|Unexpected end)}; |
|
6983 |
} |
|
6984 |
|
|
6985 |
if (my $e = "$@") { |
|
6986 |
$response = { |
|
6987 |
url => $url, |
|
6988 |
success => q{}, |
|
6989 |
status => 599, |
|
6990 |
reason => 'Internal Exception', |
|
6991 |
content => $e, |
|
6992 |
headers => { |
|
6993 |
'content-type' => 'text/plain', |
|
6994 |
'content-length' => length $e, |
|
6995 |
} |
|
6996 |
}; |
|
6997 |
} |
|
6998 |
return $response; |
|
6999 |
} |
|
7000 |
|
|
7001 |
|
|
7002 |
sub www_form_urlencode { |
|
7003 |
my ($self, $data) = @_; |
|
7004 |
(@_ == 2 && ref $data) |
|
7005 |
or Carp::croak(q/Usage: $http->www_form_urlencode(DATAREF)/ . "\n"); |
|
7006 |
(ref $data eq 'HASH' || ref $data eq 'ARRAY') |
|
7007 |
or Carp::croak("form data must be a hash or array reference\n"); |
|
7008 |
|
|
7009 |
my @params = ref $data eq 'HASH' ? %$data : @$data; |
|
7010 |
@params % 2 == 0 |
|
7011 |
or Carp::croak("form data reference must have an even number of terms\n"); |
|
7012 |
|
|
7013 |
my @terms; |
|
7014 |
while( @params ) { |
|
7015 |
my ($key, $value) = splice(@params, 0, 2); |
|
7016 |
if ( ref $value eq 'ARRAY' ) { |
|
7017 |
unshift @params, map { $key => $_ } @$value; |
|
7018 |
} |
|
7019 |
else { |
|
7020 |
push @terms, join("=", map { $self->_uri_escape($_) } $key, $value); |
|
7021 |
} |
|
7022 |
} |
|
7023 |
|
|
7024 |
return join("&", sort @terms); |
|
7025 |
} |
|
7026 |
|
|
7027 |
#--------------------------------------------------------------------------# |
|
7028 |
# private methods |
|
7029 |
#--------------------------------------------------------------------------# |
|
7030 |
|
|
7031 |
my %DefaultPort = ( |
|
7032 |
http => 80, |
|
7033 |
https => 443, |
|
7034 |
); |
|
7035 |
|
|
7036 |
sub _request { |
|
7037 |
my ($self, $method, $url, $args) = @_; |
|
7038 |
|
|
7039 |
my ($scheme, $host, $port, $path_query) = $self->_split_url($url); |
|
7040 |
|
|
7041 |
my $request = { |
|
7042 |
method => $method, |
|
7043 |
scheme => $scheme, |
|
7044 |
host_port => ($port == $DefaultPort{$scheme} ? $host : "$host:$port"), |
|
7045 |
uri => $path_query, |
|
7046 |
headers => {}, |
|
7047 |
}; |
|
7048 |
|
|
7049 |
my $handle = HTTP::Tiny::Handle->new( |
|
7050 |
timeout => $self->{timeout}, |
|
7051 |
SSL_options => $self->{SSL_options}, |
|
7052 |
verify_SSL => $self->{verify_SSL}, |
|
7053 |
local_address => $self->{local_address}, |
|
7054 |
); |
|
7055 |
|
|
7056 |
if ($self->{proxy}) { |
|
7057 |
$request->{uri} = "$scheme://$request->{host_port}$path_query"; |
|
7058 |
die(qq/HTTPS via proxy is not supported\n/) |
|
7059 |
if $request->{scheme} eq 'https'; |
|
7060 |
$handle->connect(($self->_split_url($self->{proxy}))[0..2]); |
|
7061 |
} |
|
7062 |
else { |
|
7063 |
$handle->connect($scheme, $host, $port); |
|
7064 |
} |
|
7065 |
|
|
7066 |
$self->_prepare_headers_and_cb($request, $args, $url); |
|
7067 |
$handle->write_request($request); |
|
7068 |
|
|
7069 |
my $response; |
|
7070 |
do { $response = $handle->read_response_header } |
|
7071 |
until (substr($response->{status},0,1) ne '1'); |
|
7072 |
|
|
7073 |
$self->_update_cookie_jar( $url, $response ) if $self->{cookie_jar}; |
|
7074 |
|
|
7075 |
if ( my @redir_args = $self->_maybe_redirect($request, $response, $args) ) { |
|
7076 |
$handle->close; |
|
7077 |
return $self->_request(@redir_args, $args); |
|
7078 |
} |
|
7079 |
|
|
7080 |
if ($method eq 'HEAD' || $response->{status} =~ /^[23]04/) { |
|
7081 |
# response has no message body |
|
7082 |
} |
|
7083 |
else { |
|
7084 |
my $data_cb = $self->_prepare_data_cb($response, $args); |
|
7085 |
$handle->read_body($data_cb, $response); |
|
7086 |
} |
|
7087 |
|
|
7088 |
$handle->close; |
|
7089 |
$response->{success} = substr($response->{status},0,1) eq '2'; |
|
7090 |
$response->{url} = $url; |
|
7091 |
return $response; |
|
7092 |
} |
|
7093 |
|
|
7094 |
sub _prepare_headers_and_cb { |
|
7095 |
my ($self, $request, $args, $url) = @_; |
|
7096 |
|
|
7097 |
for ($self->{default_headers}, $args->{headers}) { |
|
7098 |
next unless defined; |
|
7099 |
while (my ($k, $v) = each %$_) { |
|
7100 |
$request->{headers}{lc $k} = $v; |
|
7101 |
} |
|
7102 |
} |
|
7103 |
$request->{headers}{'host'} = $request->{host_port}; |
|
7104 |
$request->{headers}{'connection'} = "close"; |
|
7105 |
$request->{headers}{'user-agent'} ||= $self->{agent}; |
|
7106 |
|
|
7107 |
if (defined $args->{content}) { |
|
7108 |
$request->{headers}{'content-type'} ||= "application/octet-stream"; |
|
7109 |
if (ref $args->{content} eq 'CODE') { |
|
7110 |
$request->{headers}{'transfer-encoding'} = 'chunked' |
|
7111 |
unless $request->{headers}{'content-length'} |
|
7112 |
|| $request->{headers}{'transfer-encoding'}; |
|
7113 |
$request->{cb} = $args->{content}; |
|
7114 |
} |
|
7115 |
else { |
|
7116 |
my $content = $args->{content}; |
|
7117 |
if ( $] ge '5.008' ) { |
|
7118 |
utf8::downgrade($content, 1) |
|
7119 |
or die(qq/Wide character in request message body\n/); |
|
7120 |
} |
|
7121 |
$request->{headers}{'content-length'} = length $content |
|
7122 |
unless $request->{headers}{'content-length'} |
|
7123 |
|| $request->{headers}{'transfer-encoding'}; |
|
7124 |
$request->{cb} = sub { substr $content, 0, length $content, '' }; |
|
7125 |
} |
|
7126 |
$request->{trailer_cb} = $args->{trailer_callback} |
|
7127 |
if ref $args->{trailer_callback} eq 'CODE'; |
|
7128 |
} |
|
7129 |
|
|
7130 |
### If we have a cookie jar, then maybe add relevant cookies |
|
7131 |
if ( $self->{cookie_jar} ) { |
|
7132 |
my $cookies = $self->cookie_jar->cookie_header( $url ); |
|
7133 |
$request->{headers}{cookie} = $cookies if length $cookies; |
|
7134 |
} |
|
7135 |
|
|
7136 |
return; |
|
7137 |
} |
|
7138 |
|
|
7139 |
sub _prepare_data_cb { |
|
7140 |
my ($self, $response, $args) = @_; |
|
7141 |
my $data_cb = $args->{data_callback}; |
|
7142 |
$response->{content} = ''; |
|
7143 |
|
|
7144 |
if (!$data_cb || $response->{status} !~ /^2/) { |
|
7145 |
if (defined $self->{max_size}) { |
|
7146 |
$data_cb = sub { |
|
7147 |
$_[1]->{content} .= $_[0]; |
|
7148 |
die(qq/Size of response body exceeds the maximum allowed of $self->{max_size}\n/) |
|
7149 |
if length $_[1]->{content} > $self->{max_size}; |
|
7150 |
}; |
|
7151 |
} |
|
7152 |
else { |
|
7153 |
$data_cb = sub { $_[1]->{content} .= $_[0] }; |
|
7154 |
} |
|
7155 |
} |
|
7156 |
return $data_cb; |
|
7157 |
} |
|
7158 |
|
|
7159 |
sub _update_cookie_jar { |
|
7160 |
my ($self, $url, $response) = @_; |
|
7161 |
|
|
7162 |
my $cookies = $response->{headers}->{'set-cookie'}; |
|
7163 |
return unless defined $cookies; |
|
7164 |
|
|
7165 |
my @cookies = ref $cookies ? @$cookies : $cookies; |
|
7166 |
|
|
7167 |
$self->cookie_jar->add( $url, $_ ) for @cookies; |
|
7168 |
|
|
7169 |
return; |
|
7170 |
} |
|
7171 |
|
|
7172 |
sub _validate_cookie_jar { |
|
7173 |
my ($class, $jar) = @_; |
|
7174 |
|
|
7175 |
# duck typing |
|
7176 |
for my $method ( qw/add cookie_header/ ) { |
|
7177 |
Carp::croak(qq/Cookie jar must provide the '$method' method\n/) |
|
7178 |
unless ref($jar) && ref($jar)->can($method); |
|
7179 |
} |
|
7180 |
|
|
7181 |
return; |
|
7182 |
} |
|
7183 |
|
|
7184 |
sub _maybe_redirect { |
|
7185 |
my ($self, $request, $response, $args) = @_; |
|
7186 |
my $headers = $response->{headers}; |
|
7187 |
my ($status, $method) = ($response->{status}, $request->{method}); |
|
7188 |
if (($status eq '303' or ($status =~ /^30[127]/ && $method =~ /^GET|HEAD$/)) |
|
7189 |
and $headers->{location} |
|
7190 |
and ++$args->{redirects} <= $self->{max_redirect} |
|
7191 |
) { |
|
7192 |
my $location = ($headers->{location} =~ /^\//) |
|
7193 |
? "$request->{scheme}://$request->{host_port}$headers->{location}" |
|
7194 |
: $headers->{location} ; |
|
7195 |
return (($status eq '303' ? 'GET' : $method), $location); |
|
7196 |
} |
|
7197 |
return; |
|
7198 |
} |
|
7199 |
|
|
7200 |
sub _split_url { |
|
7201 |
my $url = pop; |
|
7202 |
|
|
7203 |
# URI regex adapted from the URI module |
|
7204 |
my ($scheme, $authority, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)> |
|
7205 |
or die(qq/Cannot parse URL: '$url'\n/); |
|
7206 |
|
|
7207 |
$scheme = lc $scheme; |
|
7208 |
$path_query = "/$path_query" unless $path_query =~ m<\A/>; |
|
7209 |
|
|
7210 |
my $host = (length($authority)) ? lc $authority : 'localhost'; |
|
7211 |
$host =~ s/\A[^@]*@//; # userinfo |
|
7212 |
my $port = do { |
|
7213 |
$host =~ s/:([0-9]*)\z// && length $1 |
|
7214 |
? $1 |
|
7215 |
: ($scheme eq 'http' ? 80 : $scheme eq 'https' ? 443 : undef); |
|
7216 |
}; |
|
7217 |
|
|
7218 |
return ($scheme, $host, $port, $path_query); |
|
7219 |
} |
|
7220 |
|
|
7221 |
# Date conversions adapted from HTTP::Date |
|
7222 |
my $DoW = "Sun|Mon|Tue|Wed|Thu|Fri|Sat"; |
|
7223 |
my $MoY = "Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec"; |
|
7224 |
sub _http_date { |
|
7225 |
my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($_[1]); |
|
7226 |
return sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT", |
|
7227 |
substr($DoW,$wday*4,3), |
|
7228 |
$mday, substr($MoY,$mon*4,3), $year+1900, |
|
7229 |
$hour, $min, $sec |
|
7230 |
); |
|
7231 |
} |
|
7232 |
|
|
7233 |
sub _parse_http_date { |
|
7234 |
my ($self, $str) = @_; |
|
7235 |
require Time::Local; |
|
7236 |
my @tl_parts; |
|
7237 |
if ($str =~ /^[SMTWF][a-z]+, +(\d{1,2}) ($MoY) +(\d\d\d\d) +(\d\d):(\d\d):(\d\d) +GMT$/) { |
|
7238 |
@tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3); |
|
7239 |
} |
|
7240 |
elsif ($str =~ /^[SMTWF][a-z]+, +(\d\d)-($MoY)-(\d{2,4}) +(\d\d):(\d\d):(\d\d) +GMT$/ ) { |
|
7241 |
@tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3); |
|
7242 |
} |
|
7243 |
elsif ($str =~ /^[SMTWF][a-z]+ +($MoY) +(\d{1,2}) +(\d\d):(\d\d):(\d\d) +(?:[^0-9]+ +)?(\d\d\d\d)$/ ) { |
|
7244 |
@tl_parts = ($5, $4, $3, $2, (index($MoY,$1)/4), $6); |
|
7245 |
} |
|
7246 |
return eval { |
|
7247 |
my $t = @tl_parts ? Time::Local::timegm(@tl_parts) : -1; |
|
7248 |
$t < 0 ? undef : $t; |
|
7249 |
}; |
|
7250 |
} |
|
7251 |
|
|
7252 |
# URI escaping adapted from URI::Escape |
|
7253 |
# c.f. http://www.w3.org/TR/html4/interact/forms.html#h-17.13.4.1 |
|
7254 |
# perl 5.6 ready UTF-8 encoding adapted from JSON::PP |
|
7255 |
my %escapes = map { chr($_) => sprintf("%%%02X", $_) } 0..255; |
|
7256 |
$escapes{' '}="+"; |
|
7257 |
my $unsafe_char = qr/[^A-Za-z0-9\-\._~]/; |
|
7258 |
|
|
7259 |
sub _uri_escape { |
|
7260 |
my ($self, $str) = @_; |
|
7261 |
if ( $] ge '5.008' ) { |
|
7262 |
utf8::encode($str); |
|
7263 |
} |
|
7264 |
else { |
|
7265 |
$str = pack("U*", unpack("C*", $str)) # UTF-8 encode a byte string |
|
7266 |
if ( length $str == do { use bytes; length $str } ); |
|
7267 |
$str = pack("C*", unpack("C*", $str)); # clear UTF-8 flag |
|
7268 |
} |
|
7269 |
$str =~ s/($unsafe_char)/$escapes{$1}/ge; |
|
7270 |
return $str; |
|
7271 |
} |
|
7272 |
|
|
7273 |
package |
|
7274 |
HTTP::Tiny::Handle; # hide from PAUSE/indexers |
|
7275 |
use strict; |
|
7276 |
use warnings; |
|
7277 |
|
|
7278 |
use Errno qw[EINTR EPIPE]; |
|
7279 |
use IO::Socket qw[SOCK_STREAM]; |
|
7280 |
|
|
7281 |
sub BUFSIZE () { 32768 } ## no critic |
|
7282 |
|
|
7283 |
my $Printable = sub { |
|
7284 |
local $_ = shift; |
|
7285 |
s/\r/\\r/g; |
|
7286 |
s/\n/\\n/g; |
|
7287 |
s/\t/\\t/g; |
|
7288 |
s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge; |
|
7289 |
$_; |
|
7290 |
}; |
|
7291 |
|
|
7292 |
my $Token = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/; |
|
7293 |
|
|
7294 |
sub new { |
|
7295 |
my ($class, %args) = @_; |
|
7296 |
return bless { |
|
7297 |
rbuf => '', |
|
7298 |
timeout => 60, |
|
7299 |
max_line_size => 16384, |
|
7300 |
max_header_lines => 64, |
|
7301 |
verify_SSL => 0, |
|
7302 |
SSL_options => {}, |
|
7303 |
%args |
|
7304 |
}, $class; |
|
7305 |
} |
|
7306 |
|
|
7307 |
sub connect { |
|
7308 |
@_ == 4 || die(q/Usage: $handle->connect(scheme, host, port)/ . "\n"); |
|
7309 |
my ($self, $scheme, $host, $port) = @_; |
|
7310 |
|
|
7311 |
if ( $scheme eq 'https' ) { |
|
7312 |
die(qq/IO::Socket::SSL 1.56 must be installed for https support\n/) |
|
7313 |
unless eval {require IO::Socket::SSL; IO::Socket::SSL->VERSION(1.56)}; |
|
7314 |
die(qq/Net::SSLeay 1.49 must be installed for https support\n/) |
|
7315 |
unless eval {require Net::SSLeay; Net::SSLeay->VERSION(1.49)}; |
|
7316 |
} |
|
7317 |
elsif ( $scheme ne 'http' ) { |
|
7318 |
die(qq/Unsupported URL scheme '$scheme'\n/); |
|
7319 |
} |
|
7320 |
$self->{fh} = 'IO::Socket::INET'->new( |
|
7321 |
PeerHost => $host, |
|
7322 |
PeerPort => $port, |
|
7323 |
$self->{local_address} ? |
|
7324 |
( LocalAddr => $self->{local_address} ) : (), |
|
7325 |
Proto => 'tcp', |
|
7326 |
Type => SOCK_STREAM, |
|
7327 |
Timeout => $self->{timeout} |
|
7328 |
) or die(qq/Could not connect to '$host:$port': $@\n/); |
|
7329 |
|
|
7330 |
binmode($self->{fh}) |
|
7331 |
or die(qq/Could not binmode() socket: '$!'\n/); |
|
7332 |
|
|
7333 |
if ( $scheme eq 'https') { |
|
7334 |
my $ssl_args = $self->_ssl_args($host); |
|
7335 |
IO::Socket::SSL->start_SSL( |
|
7336 |
$self->{fh}, |
|
7337 |
%$ssl_args, |
|
7338 |
SSL_create_ctx_callback => sub { |
|
7339 |
my $ctx = shift; |
|
7340 |
Net::SSLeay::CTX_set_mode($ctx, Net::SSLeay::MODE_AUTO_RETRY()); |
|
7341 |
}, |
|
7342 |
); |
|
7343 |
|
|
7344 |
unless ( ref($self->{fh}) eq 'IO::Socket::SSL' ) { |
|
7345 |
my $ssl_err = IO::Socket::SSL->errstr; |
|
7346 |
die(qq/SSL connection failed for $host: $ssl_err\n/); |
|
7347 |
} |
|
7348 |
} |
|
7349 |
|
|
7350 |
$self->{host} = $host; |
|
7351 |
$self->{port} = $port; |
|
7352 |
|
|
7353 |
return $self; |
|
7354 |
} |
|
7355 |
|
|
7356 |
sub close { |
|
7357 |
@_ == 1 || die(q/Usage: $handle->close()/ . "\n"); |
|
7358 |
my ($self) = @_; |
|
7359 |
CORE::close($self->{fh}) |
|
7360 |
or die(qq/Could not close socket: '$!'\n/); |
|
7361 |
} |
|
7362 |
|
|
7363 |
sub write { |
|
7364 |
@_ == 2 || die(q/Usage: $handle->write(buf)/ . "\n"); |
|
7365 |
my ($self, $buf) = @_; |
|
7366 |
|
|
7367 |
if ( $] ge '5.008' ) { |
|
7368 |
utf8::downgrade($buf, 1) |
|
7369 |
or die(qq/Wide character in write()\n/); |
|
7370 |
} |
|
7371 |
|
|
7372 |
my $len = length $buf; |
|
7373 |
my $off = 0; |
|
7374 |
|
|
7375 |
local $SIG{PIPE} = 'IGNORE'; |
|
7376 |
|
|
7377 |
while () { |
|
7378 |
$self->can_write |
|
7379 |
or die(qq/Timed out while waiting for socket to become ready for writing\n/); |
|
7380 |
my $r = syswrite($self->{fh}, $buf, $len, $off); |
|
7381 |
if (defined $r) { |
|
7382 |
$len -= $r; |
|
7383 |
$off += $r; |
|
7384 |
last unless $len > 0; |
|
7385 |
} |
|
7386 |
elsif ($! == EPIPE) { |
|
7387 |
die(qq/Socket closed by remote server: $!\n/); |
|
7388 |
} |
|
7389 |
elsif ($! != EINTR) { |
|
7390 |
if ($self->{fh}->can('errstr')){ |
|
7391 |
my $err = $self->{fh}->errstr(); |
|
7392 |
die (qq/Could not write to SSL socket: '$err'\n /); |
|
7393 |
} |
|
7394 |
else { |
|
7395 |
die(qq/Could not write to socket: '$!'\n/); |
|
7396 |
} |
|
7397 |
|
|
7398 |
} |
|
7399 |
} |
|
7400 |
return $off; |
|
7401 |
} |
|
7402 |
|
|
7403 |
sub read { |
|
7404 |
@_ == 2 || @_ == 3 || die(q/Usage: $handle->read(len [, allow_partial])/ . "\n"); |
|
7405 |
my ($self, $len, $allow_partial) = @_; |
|
7406 |
|
|
7407 |
my $buf = ''; |
|
7408 |
my $got = length $self->{rbuf}; |
|
7409 |
|
|
7410 |
if ($got) { |
|
7411 |
my $take = ($got < $len) ? $got : $len; |
|
7412 |
$buf = substr($self->{rbuf}, 0, $take, ''); |
|
7413 |
$len -= $take; |
|
7414 |
} |
|
7415 |
|
|
7416 |
while ($len > 0) { |
|
7417 |
$self->can_read |
|
7418 |
or die(q/Timed out while waiting for socket to become ready for reading/ . "\n"); |
|
7419 |
my $r = sysread($self->{fh}, $buf, $len, length $buf); |
|
7420 |
if (defined $r) { |
|
7421 |
last unless $r; |
|
7422 |
$len -= $r; |
|
7423 |
} |
|
7424 |
elsif ($! != EINTR) { |
|
7425 |
if ($self->{fh}->can('errstr')){ |
|
7426 |
my $err = $self->{fh}->errstr(); |
|
7427 |
die (qq/Could not read from SSL socket: '$err'\n /); |
|
7428 |
} |
|
7429 |
else { |
|
7430 |
die(qq/Could not read from socket: '$!'\n/); |
|
7431 |
} |
|
7432 |
} |
|
7433 |
} |
|
7434 |
if ($len && !$allow_partial) { |
|
7435 |
die(qq/Unexpected end of stream\n/); |
|
7436 |
} |
|
7437 |
return $buf; |
|
7438 |
} |
|
7439 |
|
|
7440 |
sub readline { |
|
7441 |
@_ == 1 || die(q/Usage: $handle->readline()/ . "\n"); |
|
7442 |
my ($self) = @_; |
|
7443 |
|
|
7444 |
while () { |
|
7445 |
if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) { |
|
7446 |
return $1; |
|
7447 |
} |
|
7448 |
if (length $self->{rbuf} >= $self->{max_line_size}) { |
|
7449 |
die(qq/Line size exceeds the maximum allowed size of $self->{max_line_size}\n/); |
|
7450 |
} |
|
7451 |
$self->can_read |
|
7452 |
or die(qq/Timed out while waiting for socket to become ready for reading\n/); |
|
7453 |
my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf}); |
|
7454 |
if (defined $r) { |
|
7455 |
last unless $r; |
|
7456 |
} |
|
7457 |
elsif ($! != EINTR) { |
|
7458 |
if ($self->{fh}->can('errstr')){ |
|
7459 |
my $err = $self->{fh}->errstr(); |
|
7460 |
die (qq/Could not read from SSL socket: '$err'\n /); |
|
7461 |
} |
|
7462 |
else { |
|
7463 |
die(qq/Could not read from socket: '$!'\n/); |
|
7464 |
} |
|
7465 |
} |
|
7466 |
} |
|
7467 |
die(qq/Unexpected end of stream while looking for line\n/); |
|
7468 |
} |
|
7469 |
|
|
7470 |
sub read_header_lines { |
|
7471 |
@_ == 1 || @_ == 2 || die(q/Usage: $handle->read_header_lines([headers])/ . "\n"); |
|
7472 |
my ($self, $headers) = @_; |
|
7473 |
$headers ||= {}; |
|
7474 |
my $lines = 0; |
|
7475 |
my $val; |
|
7476 |
|
|
7477 |
while () { |
|
7478 |
my $line = $self->readline; |
|
7479 |
|
|
7480 |
if (++$lines >= $self->{max_header_lines}) { |
|
7481 |
die(qq/Header lines exceeds maximum number allowed of $self->{max_header_lines}\n/); |
|
7482 |
} |
|
7483 |
elsif ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) { |
|
7484 |
my ($field_name) = lc $1; |
|
7485 |
if (exists $headers->{$field_name}) { |
|
7486 |
for ($headers->{$field_name}) { |
|
7487 |
$_ = [$_] unless ref $_ eq "ARRAY"; |
|
7488 |
push @$_, $2; |
|
7489 |
$val = \$_->[-1]; |
|
7490 |
} |
|
7491 |
} |
|
7492 |
else { |
|
7493 |
$val = \($headers->{$field_name} = $2); |
|
7494 |
} |
|
7495 |
} |
|
7496 |
elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) { |
|
7497 |
$val |
|
7498 |
or die(qq/Unexpected header continuation line\n/); |
|
7499 |
next unless length $1; |
|
7500 |
$$val .= ' ' if length $$val; |
|
7501 |
$$val .= $1; |
|
7502 |
} |
|
7503 |
elsif ($line =~ /\A \x0D?\x0A \z/x) { |
|
7504 |
last; |
|
7505 |
} |
|
7506 |
else { |
|
7507 |
die(q/Malformed header line: / . $Printable->($line) . "\n"); |
|
7508 |
} |
|
7509 |
} |
|
7510 |
return $headers; |
|
7511 |
} |
|
7512 |
|
|
7513 |
sub write_request { |
|
7514 |
@_ == 2 || die(q/Usage: $handle->write_request(request)/ . "\n"); |
|
7515 |
my($self, $request) = @_; |
|
7516 |
$self->write_request_header(@{$request}{qw/method uri headers/}); |
|
7517 |
$self->write_body($request) if $request->{cb}; |
|
7518 |
return; |
|
7519 |
} |
|
7520 |
|
|
7521 |
my %HeaderCase = ( |
|
7522 |
'content-md5' => 'Content-MD5', |
|
7523 |
'etag' => 'ETag', |
|
7524 |
'te' => 'TE', |
|
7525 |
'www-authenticate' => 'WWW-Authenticate', |
|
7526 |
'x-xss-protection' => 'X-XSS-Protection', |
|
7527 |
); |
|
7528 |
|
|
7529 |
sub write_header_lines { |
|
7530 |
(@_ == 2 && ref $_[1] eq 'HASH') || die(q/Usage: $handle->write_header_lines(headers)/ . "\n"); |
|
7531 |
my($self, $headers) = @_; |
|
7532 |
|
|
7533 |
my $buf = ''; |
|
7534 |
while (my ($k, $v) = each %$headers) { |
|
7535 |
my $field_name = lc $k; |
|
7536 |
if (exists $HeaderCase{$field_name}) { |
|
7537 |
$field_name = $HeaderCase{$field_name}; |
|
7538 |
} |
|
7539 |
else { |
|
7540 |
$field_name =~ /\A $Token+ \z/xo |
|
7541 |
or die(q/Invalid HTTP header field name: / . $Printable->($field_name) . "\n"); |
|
7542 |
$field_name =~ s/\b(\w)/\u$1/g; |
|
7543 |
$HeaderCase{lc $field_name} = $field_name; |
|
7544 |
} |
|
7545 |
for (ref $v eq 'ARRAY' ? @$v : $v) { |
|
7546 |
/[^\x0D\x0A]/ |
|
7547 |
or die(qq/Invalid HTTP header field value ($field_name): / . $Printable->($_). "\n"); |
|
7548 |
$buf .= "$field_name: $_\x0D\x0A"; |
|
7549 |
} |
|
7550 |
} |
|
7551 |
$buf .= "\x0D\x0A"; |
|
7552 |
return $self->write($buf); |
|
7553 |
} |
|
7554 |
|
|
7555 |
sub read_body { |
|
7556 |
@_ == 3 || die(q/Usage: $handle->read_body(callback, response)/ . "\n"); |
|
7557 |
my ($self, $cb, $response) = @_; |
|
7558 |
my $te = $response->{headers}{'transfer-encoding'} || ''; |
|
7559 |
if ( grep { /chunked/i } ( ref $te eq 'ARRAY' ? @$te : $te ) ) { |
|
7560 |
$self->read_chunked_body($cb, $response); |
|
7561 |
} |
|
7562 |
else { |
|
7563 |
$self->read_content_body($cb, $response); |
|
7564 |
} |
|
7565 |
return; |
|
7566 |
} |
|
7567 |
|
|
7568 |
sub write_body { |
|
7569 |
@_ == 2 || die(q/Usage: $handle->write_body(request)/ . "\n"); |
|
7570 |
my ($self, $request) = @_; |
|
7571 |
if ($request->{headers}{'content-length'}) { |
|
7572 |
return $self->write_content_body($request); |
|
7573 |
} |
|
7574 |
else { |
|
7575 |
return $self->write_chunked_body($request); |
|
7576 |
} |
|
7577 |
} |
|
7578 |
|
|
7579 |
sub read_content_body { |
|
7580 |
@_ == 3 || @_ == 4 || die(q/Usage: $handle->read_content_body(callback, response, [read_length])/ . "\n"); |
|
7581 |
my ($self, $cb, $response, $content_length) = @_; |
|
7582 |
$content_length ||= $response->{headers}{'content-length'}; |
|
7583 |
|
|
7584 |
if ( $content_length ) { |
|
7585 |
my $len = $content_length; |
|
7586 |
while ($len > 0) { |
|
7587 |
my $read = ($len > BUFSIZE) ? BUFSIZE : $len; |
|
7588 |
$cb->($self->read($read, 0), $response); |
|
7589 |
$len -= $read; |
|
7590 |
} |
|
7591 |
} |
|
7592 |
else { |
|
7593 |
my $chunk; |
|
7594 |
$cb->($chunk, $response) while length( $chunk = $self->read(BUFSIZE, 1) ); |
|
7595 |
} |
|
7596 |
|
|
7597 |
return; |
|
7598 |
} |
|
7599 |
|
|
7600 |
sub write_content_body { |
|
7601 |
@_ == 2 || die(q/Usage: $handle->write_content_body(request)/ . "\n"); |
|
7602 |
my ($self, $request) = @_; |
|
7603 |
|
|
7604 |
my ($len, $content_length) = (0, $request->{headers}{'content-length'}); |
|
7605 |
while () { |
|
7606 |
my $data = $request->{cb}->(); |
|
7607 |
|
|
7608 |
defined $data && length $data |
|
7609 |
or last; |
|
7610 |
|
|
7611 |
if ( $] ge '5.008' ) { |
|
7612 |
utf8::downgrade($data, 1) |
|
7613 |
or die(qq/Wide character in write_content()\n/); |
|
7614 |
} |
|
7615 |
|
|
7616 |
$len += $self->write($data); |
|
7617 |
} |
|
7618 |
|
|
7619 |
$len == $content_length |
|
7620 |
or die(qq/Content-Length missmatch (got: $len expected: $content_length)\n/); |
|
7621 |
|
|
7622 |
return $len; |
|
7623 |
} |
|
7624 |
|
|
7625 |
sub read_chunked_body { |
|
7626 |
@_ == 3 || die(q/Usage: $handle->read_chunked_body(callback, $response)/ . "\n"); |
|
7627 |
my ($self, $cb, $response) = @_; |
|
7628 |
|
|
7629 |
while () { |
|
7630 |
my $head = $self->readline; |
|
7631 |
|
|
7632 |
$head =~ /\A ([A-Fa-f0-9]+)/x |
|
7633 |
or die(q/Malformed chunk head: / . $Printable->($head) . "\n"); |
|
7634 |
|
|
7635 |
my $len = hex($1) |
|
7636 |
or last; |
|
7637 |
|
|
7638 |
$self->read_content_body($cb, $response, $len); |
|
7639 |
|
|
7640 |
$self->read(2) eq "\x0D\x0A" |
|
7641 |
or die(qq/Malformed chunk: missing CRLF after chunk data\n/); |
|
7642 |
} |
|
7643 |
$self->read_header_lines($response->{headers}); |
|
7644 |
return; |
|
7645 |
} |
|
7646 |
|
|
7647 |
sub write_chunked_body { |
|
7648 |
@_ == 2 || die(q/Usage: $handle->write_chunked_body(request)/ . "\n"); |
|
7649 |
my ($self, $request) = @_; |
|
7650 |
|
|
7651 |
my $len = 0; |
|
7652 |
while () { |
|
7653 |
my $data = $request->{cb}->(); |
|
7654 |
|
|
7655 |
defined $data && length $data |
|
7656 |
or last; |
|
7657 |
|
|
7658 |
if ( $] ge '5.008' ) { |
|
7659 |
utf8::downgrade($data, 1) |
|
7660 |
or die(qq/Wide character in write_chunked_body()\n/); |
|
7661 |
} |
|
7662 |
|
|
7663 |
$len += length $data; |
|
7664 |
|
|
7665 |
my $chunk = sprintf '%X', length $data; |
|
7666 |
$chunk .= "\x0D\x0A"; |
|
7667 |
$chunk .= $data; |
|
7668 |
$chunk .= "\x0D\x0A"; |
|
7669 |
|
|
7670 |
$self->write($chunk); |
|
7671 |
} |
|
7672 |
$self->write("0\x0D\x0A"); |
|
7673 |
$self->write_header_lines($request->{trailer_cb}->()) |
|
7674 |
if ref $request->{trailer_cb} eq 'CODE'; |
|
7675 |
return $len; |
|
7676 |
} |
|
7677 |
|
|
7678 |
sub read_response_header { |
|
7679 |
@_ == 1 || die(q/Usage: $handle->read_response_header()/ . "\n"); |
|
7680 |
my ($self) = @_; |
|
7681 |
|
|
7682 |
my $line = $self->readline; |
|
7683 |
|
|
7684 |
$line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x |
|
7685 |
or die(q/Malformed Status-Line: / . $Printable->($line). "\n"); |
|
7686 |
|
|
7687 |
my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4); |
|
7688 |
|
|
7689 |
die (qq/Unsupported HTTP protocol: $protocol\n/) |
|
7690 |
unless $version =~ /0*1\.0*[01]/; |
|
7691 |
|
|
7692 |
return { |
|
7693 |
status => $status, |
|
7694 |
reason => $reason, |
|
7695 |
headers => $self->read_header_lines, |
|
7696 |
protocol => $protocol, |
|
7697 |
}; |
|
7698 |
} |
|
7699 |
|
|
7700 |
sub write_request_header { |
|
7701 |
@_ == 4 || die(q/Usage: $handle->write_request_header(method, request_uri, headers)/ . "\n"); |
|
7702 |
my ($self, $method, $request_uri, $headers) = @_; |
|
7703 |
|
|
7704 |
return $self->write("$method $request_uri HTTP/1.1\x0D\x0A") |
|
7705 |
+ $self->write_header_lines($headers); |
|
7706 |
} |
|
7707 |
|
|
7708 |
sub _do_timeout { |
|
7709 |
my ($self, $type, $timeout) = @_; |
|
7710 |
$timeout = $self->{timeout} |
|
7711 |
unless defined $timeout && $timeout >= 0; |
|
7712 |
|
|
7713 |
my $fd = fileno $self->{fh}; |
|
7714 |
defined $fd && $fd >= 0 |
|
7715 |
or die(qq/select(2): 'Bad file descriptor'\n/); |
|
7716 |
|
|
7717 |
my $initial = time; |
|
7718 |
my $pending = $timeout; |
|
7719 |
my $nfound; |
|
7720 |
|
|
7721 |
vec(my $fdset = '', $fd, 1) = 1; |
|
7722 |
|
|
7723 |
while () { |
|
7724 |
$nfound = ($type eq 'read') |
|
7725 |
? select($fdset, undef, undef, $pending) |
|
7726 |
: select(undef, $fdset, undef, $pending) ; |
|
7727 |
if ($nfound == -1) { |
|
7728 |
$! == EINTR |
|
7729 |
or die(qq/select(2): '$!'\n/); |
|
7730 |
redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0; |
|
7731 |
$nfound = 0; |
|
7732 |
} |
|
7733 |
last; |
|
7734 |
} |
|
7735 |
$! = 0; |
|
7736 |
return $nfound; |
|
7737 |
} |
|
7738 |
|
|
7739 |
sub can_read { |
|
7740 |
@_ == 1 || @_ == 2 || die(q/Usage: $handle->can_read([timeout])/ . "\n"); |
|
7741 |
my $self = shift; |
|
7742 |
return $self->_do_timeout('read', @_) |
|
7743 |
} |
|
7744 |
|
|
7745 |
sub can_write { |
|
7746 |
@_ == 1 || @_ == 2 || die(q/Usage: $handle->can_write([timeout])/ . "\n"); |
|
7747 |
my $self = shift; |
|
7748 |
return $self->_do_timeout('write', @_) |
|
7749 |
} |
|
7750 |
|
|
7751 |
# Try to find a CA bundle to validate the SSL cert, |
|
7752 |
# prefer Mozilla::CA or fallback to a system file |
|
7753 |
sub _find_CA_file { |
|
7754 |
my $self = shift(); |
|
7755 |
|
|
7756 |
return $self->{SSL_options}->{SSL_ca_file} |
|
7757 |
if $self->{SSL_options}->{SSL_ca_file} and -e $self->{SSL_options}->{SSL_ca_file}; |
|
7758 |
|
|
7759 |
return Mozilla::CA::SSL_ca_file() |
|
7760 |
if eval { require Mozilla::CA }; |
|
7761 |
|
|
7762 |
foreach my $ca_bundle (qw{ |
|
7763 |
/etc/ssl/certs/ca-certificates.crt |
|
7764 |
/etc/pki/tls/certs/ca-bundle.crt |
|
7765 |
/etc/ssl/ca-bundle.pem |
|
7766 |
} |
|
7767 |
) { |
|
7768 |
return $ca_bundle if -e $ca_bundle; |
|
7769 |
} |
|
7770 |
|
|
7771 |
die qq/Couldn't find a CA bundle with which to verify the SSL certificate.\n/ |
|
7772 |
. qq/Try installing Mozilla::CA from CPAN\n/; |
|
7773 |
} |
|
7774 |
|
|
7775 |
sub _ssl_args { |
|
7776 |
my ($self, $host) = @_; |
|
7777 |
|
|
7778 |
my %ssl_args = ( |
|
7779 |
SSL_hostname => $host, # SNI |
|
7780 |
); |
|
7781 |
|
|
7782 |
if ($self->{verify_SSL}) { |
|
7783 |
$ssl_args{SSL_verifycn_scheme} = 'http'; # enable CN validation |
|
7784 |
$ssl_args{SSL_verifycn_name} = $host; # set validation hostname |
|
7785 |
$ssl_args{SSL_verify_mode} = 0x01; # enable cert validation |
|
7786 |
$ssl_args{SSL_ca_file} = $self->_find_CA_file; |
|
7787 |
} |
|
7788 |
else { |
|
7789 |
$ssl_args{SSL_verifycn_scheme} = 'none'; # disable CN validation |
|
7790 |
$ssl_args{SSL_verify_mode} = 0x00; # disable cert validation |
|
7791 |
} |
|
7792 |
|
|
7793 |
# user options override settings from verify_SSL |
|
7794 |
for my $k ( keys %{$self->{SSL_options}} ) { |
|
7795 |
$ssl_args{$k} = $self->{SSL_options}{$k} if $k =~ m/^SSL_/; |
|
7796 |
} |
|
7797 |
|
|
7798 |
return \%ssl_args; |
|
7799 |
} |
|
7800 |
|
|
7801 |
1; |
|
7802 |
|
|
7803 |
__END__ |
|
7804 |
|
|
7805 |
HTTP_TINY |
|
7806 | ||
7807 |
$fatpacked{"JSON/PP.pm"} = <<'JSON_PP'; |
|
7808 |
package JSON::PP; |
|
7809 |
|
|
7810 |
# JSON-2.0 |
|
7811 |
|
|
7812 |
use 5.005; |
|
7813 |
use strict; |
|
7814 |
use base qw(Exporter); |
|
7815 |
use overload (); |
|
7816 |
|
|
7817 |
use Carp (); |
|
7818 |
use B (); |
|
7819 |
#use Devel::Peek; |
|
7820 |
|
|
7821 |
$JSON::PP::VERSION = '2.27200'; |
|
7822 |
|
|
7823 |
@JSON::PP::EXPORT = qw(encode_json decode_json from_json to_json); |
|
7824 |
|
|
7825 |
# instead of hash-access, i tried index-access for speed. |
|
7826 |
# but this method is not faster than what i expected. so it will be changed. |
|
7827 |
|
|
7828 |
use constant P_ASCII => 0; |
|
7829 |
use constant P_LATIN1 => 1; |
|
7830 |
use constant P_UTF8 => 2; |
|
7831 |
use constant P_INDENT => 3; |
|
7832 |
use constant P_CANONICAL => 4; |
|
7833 |
use constant P_SPACE_BEFORE => 5; |
|
7834 |
use constant P_SPACE_AFTER => 6; |
|
7835 |
use constant P_ALLOW_NONREF => 7; |
|
7836 |
use constant P_SHRINK => 8; |
|
7837 |
use constant P_ALLOW_BLESSED => 9; |
|
7838 |
use constant P_CONVERT_BLESSED => 10; |
|
7839 |
use constant P_RELAXED => 11; |
|
7840 |
|
|
7841 |
use constant P_LOOSE => 12; |
|
7842 |
use constant P_ALLOW_BIGNUM => 13; |
|
7843 |
use constant P_ALLOW_BAREKEY => 14; |
|
7844 |
use constant P_ALLOW_SINGLEQUOTE => 15; |
|
7845 |
use constant P_ESCAPE_SLASH => 16; |
|
7846 |
use constant P_AS_NONBLESSED => 17; |
|
7847 |
|
|
7848 |
use constant P_ALLOW_UNKNOWN => 18; |
|
7849 |
|
|
7850 |
use constant OLD_PERL => $] < 5.008 ? 1 : 0; |
|
7851 |
|
|
7852 |
BEGIN { |
|
7853 |
my @xs_compati_bit_properties = qw( |
|
7854 |
latin1 ascii utf8 indent canonical space_before space_after allow_nonref shrink |
|
7855 |
allow_blessed convert_blessed relaxed allow_unknown |
|
7856 |
); |
|
7857 |
my @pp_bit_properties = qw( |
|
7858 |
allow_singlequote allow_bignum loose |
|
7859 |
allow_barekey escape_slash as_nonblessed |
|
7860 |
); |
|
7861 |
|
|
7862 |
# Perl version check, Unicode handling is enable? |
|
7863 |
# Helper module sets @JSON::PP::_properties. |
|
7864 |
if ($] < 5.008 ) { |
|
7865 |
my $helper = $] >= 5.006 ? 'JSON::PP::Compat5006' : 'JSON::PP::Compat5005'; |
|
7866 |
eval qq| require $helper |; |
|
7867 |
if ($@) { Carp::croak $@; } |
|
7868 |
} |
|
7869 |
|
|
7870 |
for my $name (@xs_compati_bit_properties, @pp_bit_properties) { |
|
7871 |
my $flag_name = 'P_' . uc($name); |
|
7872 |
|
|
7873 |
eval qq/ |
|
7874 |
sub $name { |
|
7875 |
my \$enable = defined \$_[1] ? \$_[1] : 1; |
|
7876 |
|
|
7877 |
if (\$enable) { |
|
7878 |
\$_[0]->{PROPS}->[$flag_name] = 1; |
|
7879 |
} |
|
7880 |
else { |
|
7881 |
\$_[0]->{PROPS}->[$flag_name] = 0; |
|
7882 |
} |
|
7883 |
|
|
7884 |
\$_[0]; |
|
7885 |
} |
|
7886 |
|
|
7887 |
sub get_$name { |
|
7888 |
\$_[0]->{PROPS}->[$flag_name] ? 1 : ''; |
|
7889 |
} |
|
7890 |
/; |
|
7891 |
} |
|
7892 |
|
|
7893 |
} |
|
7894 |
|
|
7895 |
|
|
7896 |
|
|
7897 |
# Functions |
|
7898 |
|
|
7899 |
my %encode_allow_method |
|
7900 |
= map {($_ => 1)} qw/utf8 pretty allow_nonref latin1 self_encode escape_slash |
|
7901 |
allow_blessed convert_blessed indent indent_length allow_bignum |
|
7902 |
as_nonblessed |
|
7903 |
/; |
|
7904 |
my %decode_allow_method |
|
7905 |
= map {($_ => 1)} qw/utf8 allow_nonref loose allow_singlequote allow_bignum |
|
7906 |
allow_barekey max_size relaxed/; |
|
7907 |
|
|
7908 |
|
|
7909 |
my $JSON; # cache |
|
7910 |
|
|
7911 |
sub encode_json ($) { # encode |
|
7912 |
($JSON ||= __PACKAGE__->new->utf8)->encode(@_); |
|
7913 |
} |
|
7914 |
|
|
7915 |
|
|
7916 |
sub decode_json { # decode |
|
7917 |
($JSON ||= __PACKAGE__->new->utf8)->decode(@_); |
|
7918 |
} |
|
7919 |
|
|
7920 |
# Obsoleted |
|
7921 |
|
|
7922 |
sub to_json($) { |
|
7923 |
Carp::croak ("JSON::PP::to_json has been renamed to encode_json."); |
|
7924 |
} |
|
7925 |
|
|
7926 |
|
|
7927 |
sub from_json($) { |
|
7928 |
Carp::croak ("JSON::PP::from_json has been renamed to decode_json."); |
|
7929 |
} |
|
7930 |
|
|
7931 |
|
|
7932 |
# Methods |
|
7933 |
|
|
7934 |
sub new { |
|
7935 |
my $class = shift; |
|
7936 |
my $self = { |
|
7937 |
max_depth => 512, |
|
7938 |
max_size => 0, |
|
7939 |
indent => 0, |
|
7940 |
FLAGS => 0, |
|
7941 |
fallback => sub { encode_error('Invalid value. JSON can only reference.') }, |
|
7942 |
indent_length => 3, |
|
7943 |
}; |
|
7944 |
|
|
7945 |
bless $self, $class; |
|
7946 |
} |
|
7947 |
|
|
7948 |
|
|
7949 |
sub encode { |
|
7950 |
return $_[0]->PP_encode_json($_[1]); |
|
7951 |
} |
|
7952 |
|
|
7953 |
|
|
7954 |
sub decode { |
|
7955 |
return $_[0]->PP_decode_json($_[1], 0x00000000); |
|
7956 |
} |
|
7957 |
|
|
7958 |
|
|
7959 |
sub decode_prefix { |
|
7960 |
return $_[0]->PP_decode_json($_[1], 0x00000001); |
|
7961 |
} |
|
7962 |
|
|
7963 |
|
|
7964 |
# accessor |
|
7965 |
|
|
7966 |
|
|
7967 |
# pretty printing |
|
7968 |
|
|
7969 |
sub pretty { |
|
7970 |
my ($self, $v) = @_; |
|
7971 |
my $enable = defined $v ? $v : 1; |
|
7972 |
|
|
7973 |
if ($enable) { # indent_length(3) for JSON::XS compatibility |
|
7974 |
$self->indent(1)->indent_length(3)->space_before(1)->space_after(1); |
|
7975 |
} |
|
7976 |
else { |
|
7977 |
$self->indent(0)->space_before(0)->space_after(0); |
|
7978 |
} |
|
7979 |
|
|
7980 |
$self; |
|
7981 |
} |
|
7982 |
|
|
7983 |
# etc |
|
7984 |
|
|
7985 |
sub max_depth { |
|
7986 |
my $max = defined $_[1] ? $_[1] : 0x80000000; |
|
7987 |
$_[0]->{max_depth} = $max; |
|
7988 |
$_[0]; |
|
7989 |
} |
|
7990 |
|
|
7991 |
|
|
7992 |
sub get_max_depth { $_[0]->{max_depth}; } |
|
7993 |
|
|
7994 |
|
|
7995 |
sub max_size { |
|
7996 |
my $max = defined $_[1] ? $_[1] : 0; |
|
7997 |
$_[0]->{max_size} = $max; |
|
7998 |
$_[0]; |
|
7999 |
} |
|
8000 |
|
|
8001 |
|
|
8002 |
sub get_max_size { $_[0]->{max_size}; } |
|
8003 |
|
|
8004 |
|
|
8005 |
sub filter_json_object { |
|
8006 |
$_[0]->{cb_object} = defined $_[1] ? $_[1] : 0; |
|
8007 |
$_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0; |
|
8008 |
$_[0]; |
|
8009 |
} |
|
8010 |
|
|
8011 |
sub filter_json_single_key_object { |
|
8012 |
if (@_ > 1) { |
|
8013 |
$_[0]->{cb_sk_object}->{$_[1]} = $_[2]; |
|
8014 |
} |
|
8015 |
$_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0; |
|
8016 |
$_[0]; |
|
8017 |
} |
|
8018 |
|
|
8019 |
sub indent_length { |
|
8020 |
if (!defined $_[1] or $_[1] > 15 or $_[1] < 0) { |
|
8021 |
Carp::carp "The acceptable range of indent_length() is 0 to 15."; |
|
8022 |
} |
|
8023 |
else { |
|
8024 |
$_[0]->{indent_length} = $_[1]; |
|
8025 |
} |
|
8026 |
$_[0]; |
|
8027 |
} |
|
8028 |
|
|
8029 |
sub get_indent_length { |
|
8030 |
$_[0]->{indent_length}; |
|
8031 |
} |
|
8032 |
|
|
8033 |
sub sort_by { |
|
8034 |
$_[0]->{sort_by} = defined $_[1] ? $_[1] : 1; |
|
8035 |
$_[0]; |
|
8036 |
} |
|
8037 |
|
|
8038 |
sub allow_bigint { |
|
8039 |
Carp::carp("allow_bigint() is obsoleted. use allow_bignum() insted."); |
|
8040 |
} |
|
8041 |
|
|
8042 |
############################### |
|
8043 |
|
|
8044 |
### |
|
8045 |
### Perl => JSON |
|
8046 |
### |
|
8047 |
|
|
8048 |
|
|
8049 |
{ # Convert |
|
8050 |
|
|
8051 |
my $max_depth; |
|
8052 |
my $indent; |
|
8053 |
my $ascii; |
|
8054 |
my $latin1; |
|
8055 |
my $utf8; |
|
8056 |
my $space_before; |
|
8057 |
my $space_after; |
|
8058 |
my $canonical; |
|
8059 |
my $allow_blessed; |
|
8060 |
my $convert_blessed; |
|
8061 |
|
|
8062 |
my $indent_length; |
|
8063 |
my $escape_slash; |
|
8064 |
my $bignum; |
|
8065 |
my $as_nonblessed; |
|
8066 |
|
|
8067 |
my $depth; |
|
8068 |
my $indent_count; |
|
8069 |
my $keysort; |
|
8070 |
|
|
8071 |
|
|
8072 |
sub PP_encode_json { |
|
8073 |
my $self = shift; |
|
8074 |
my $obj = shift; |
|
8075 |
|
|
8076 |
$indent_count = 0; |
|
8077 |
$depth = 0; |
|
8078 |
|
|
8079 |
my $idx = $self->{PROPS}; |
|
8080 |
|
|
8081 |
($ascii, $latin1, $utf8, $indent, $canonical, $space_before, $space_after, $allow_blessed, |
|
8082 |
$convert_blessed, $escape_slash, $bignum, $as_nonblessed) |
|
8083 |
= @{$idx}[P_ASCII .. P_SPACE_AFTER, P_ALLOW_BLESSED, P_CONVERT_BLESSED, |
|
8084 |
P_ESCAPE_SLASH, P_ALLOW_BIGNUM, P_AS_NONBLESSED]; |
|
8085 |
|
|
8086 |
($max_depth, $indent_length) = @{$self}{qw/max_depth indent_length/}; |
|
8087 |
|
|
8088 |
$keysort = $canonical ? sub { $a cmp $b } : undef; |
|
8089 |
|
|
8090 |
if ($self->{sort_by}) { |
|
8091 |
$keysort = ref($self->{sort_by}) eq 'CODE' ? $self->{sort_by} |
|
8092 |
: $self->{sort_by} =~ /\D+/ ? $self->{sort_by} |
|
8093 |
: sub { $a cmp $b }; |
|
8094 |
} |
|
8095 |
|
|
8096 |
encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)") |
|
8097 |
if(!ref $obj and !$idx->[ P_ALLOW_NONREF ]); |
|
8098 |
|
|
8099 |
my $str = $self->object_to_json($obj); |
|
8100 |
|
|
8101 |
$str .= "\n" if ( $indent ); # JSON::XS 2.26 compatible |
|
8102 |
|
|
8103 |
unless ($ascii or $latin1 or $utf8) { |
|
8104 |
utf8::upgrade($str); |
|
8105 |
} |
|
8106 |
|
|
8107 |
if ($idx->[ P_SHRINK ]) { |
|
8108 |
utf8::downgrade($str, 1); |
|
8109 |
} |
|
8110 |
|
|
8111 |
return $str; |
|
8112 |
} |
|
8113 |
|
|
8114 |
|
|
8115 |
sub object_to_json { |
|
8116 |
my ($self, $obj) = @_; |
|
8117 |
my $type = ref($obj); |
|
8118 |
|
|
8119 |
if($type eq 'HASH'){ |
|
8120 |
return $self->hash_to_json($obj); |
|
8121 |
} |
|
8122 |
elsif($type eq 'ARRAY'){ |
|
8123 |
return $self->array_to_json($obj); |
|
8124 |
} |
|
8125 |
elsif ($type) { # blessed object? |
|
8126 |
if (blessed($obj)) { |
|
8127 |
|
|
8128 |
return $self->value_to_json($obj) if ( $obj->isa('JSON::PP::Boolean') ); |
|
8129 |
|
|
8130 |
if ( $convert_blessed and $obj->can('TO_JSON') ) { |
|
8131 |
my $result = $obj->TO_JSON(); |
|
8132 |
if ( defined $result and ref( $result ) ) { |
|
8133 |
if ( refaddr( $obj ) eq refaddr( $result ) ) { |
|
8134 |
encode_error( sprintf( |
|
8135 |
"%s::TO_JSON method returned same object as was passed instead of a new one", |
|
8136 |
ref $obj |
|
8137 |
) ); |
|
8138 |
} |
|
8139 |
} |
|
8140 |
|
|
8141 |
return $self->object_to_json( $result ); |
|
8142 |
} |
|
8143 |
|
|
8144 |
return "$obj" if ( $bignum and _is_bignum($obj) ); |
|
8145 |
return $self->blessed_to_json($obj) if ($allow_blessed and $as_nonblessed); # will be removed. |
|
8146 |
|
|
8147 |
encode_error( sprintf("encountered object '%s', but neither allow_blessed " |
|
8148 |
. "nor convert_blessed settings are enabled", $obj) |
|
8149 |
) unless ($allow_blessed); |
|
8150 |
|
|
8151 |
return 'null'; |
|
8152 |
} |
|
8153 |
else { |
|
8154 |
return $self->value_to_json($obj); |
|
8155 |
} |
|
8156 |
} |
|
8157 |
else{ |
|
8158 |
return $self->value_to_json($obj); |
|
8159 |
} |
|
8160 |
} |
|
8161 |
|
|
8162 |
|
|
8163 |
sub hash_to_json { |
|
8164 |
my ($self, $obj) = @_; |
|
8165 |
my @res; |
|
8166 |
|
|
8167 |
encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)") |
|
8168 |
if (++$depth > $max_depth); |
|
8169 |
|
|
8170 |
my ($pre, $post) = $indent ? $self->_up_indent() : ('', ''); |
|
8171 |
my $del = ($space_before ? ' ' : '') . ':' . ($space_after ? ' ' : ''); |
|
8172 |
|
|
8173 |
for my $k ( _sort( $obj ) ) { |
|
8174 |
if ( OLD_PERL ) { utf8::decode($k) } # key for Perl 5.6 / be optimized |
|
8175 |
push @res, string_to_json( $self, $k ) |
|
8176 |
. $del |
|
8177 |
. ( $self->object_to_json( $obj->{$k} ) || $self->value_to_json( $obj->{$k} ) ); |
|
8178 |
} |
|
8179 |
|
|
8180 |
--$depth; |
|
8181 |
$self->_down_indent() if ($indent); |
|
8182 |
|
|
8183 |
return '{' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . '}'; |
|
8184 |
} |
|
8185 |
|
|
8186 |
|
|
8187 |
sub array_to_json { |
|
8188 |
my ($self, $obj) = @_; |
|
8189 |
my @res; |
|
8190 |
|
|
8191 |
encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)") |
|
8192 |
if (++$depth > $max_depth); |
|
8193 |
|
|
8194 |
my ($pre, $post) = $indent ? $self->_up_indent() : ('', ''); |
|
8195 |
|
|
8196 |
for my $v (@$obj){ |
|
8197 |
push @res, $self->object_to_json($v) || $self->value_to_json($v); |
|
8198 |
} |
|
8199 |
|
|
8200 |
--$depth; |
|
8201 |
$self->_down_indent() if ($indent); |
|
8202 |
|
|
8203 |
return '[' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . ']'; |
|
8204 |
} |
|
8205 |
|
|
8206 |
|
|
8207 |
sub value_to_json { |
|
8208 |
my ($self, $value) = @_; |
|
8209 |
|
|
8210 |
return 'null' if(!defined $value); |
|
8211 |
|
|
8212 |
my $b_obj = B::svref_2object(\$value); # for round trip problem |
|
8213 |
my $flags = $b_obj->FLAGS; |
|
8214 |
|
|
8215 |
return $value # as is |
|
8216 |
if $flags & ( B::SVp_IOK | B::SVp_NOK ) and !( $flags & B::SVp_POK ); # SvTYPE is IV or NV? |
|
8217 |
|
|
8218 |
my $type = ref($value); |
|
8219 |
|
|
8220 |
if(!$type){ |
|
8221 |
return string_to_json($self, $value); |
|
8222 |
} |
|
8223 |
elsif( blessed($value) and $value->isa('JSON::PP::Boolean') ){ |
|
8224 |
return $$value == 1 ? 'true' : 'false'; |
|
8225 |
} |
|
8226 |
elsif ($type) { |
|
8227 |
if ((overload::StrVal($value) =~ /=(\w+)/)[0]) { |
|
8228 |
return $self->value_to_json("$value"); |
|
8229 |
} |
|
8230 |
|
|
8231 |
if ($type eq 'SCALAR' and defined $$value) { |
|
8232 |
return $$value eq '1' ? 'true' |
|
8233 |
: $$value eq '0' ? 'false' |
|
8234 |
: $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ? 'null' |
|
8235 |
: encode_error("cannot encode reference to scalar"); |
|
8236 |
} |
|
8237 |
|
|
8238 |
if ( $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ) { |
|
8239 |
return 'null'; |
|
8240 |
} |
|
8241 |
else { |
|
8242 |
if ( $type eq 'SCALAR' or $type eq 'REF' ) { |
|
8243 |
encode_error("cannot encode reference to scalar"); |
|
8244 |
} |
|
8245 |
else { |
|
8246 |
encode_error("encountered $value, but JSON can only represent references to arrays or hashes"); |
|
8247 |
} |
|
8248 |
} |
|
8249 |
|
|
8250 |
} |
|
8251 |
else { |
|
8252 |
return $self->{fallback}->($value) |
|
8253 |
if ($self->{fallback} and ref($self->{fallback}) eq 'CODE'); |
|
8254 |
return 'null'; |
|
8255 |
} |
|
8256 |
|
|
8257 |
} |
|
8258 |
|
|
8259 |
|
|
8260 |
my %esc = ( |
|
8261 |
"\n" => '\n', |
|
8262 |
"\r" => '\r', |
|
8263 |
"\t" => '\t', |
|
8264 |
"\f" => '\f', |
|
8265 |
"\b" => '\b', |
|
8266 |
"\"" => '\"', |
|
8267 |
"\\" => '\\\\', |
|
8268 |
"\'" => '\\\'', |
|
8269 |
); |
|
8270 |
|
|
8271 |
|
|
8272 |
sub string_to_json { |
|
8273 |
my ($self, $arg) = @_; |
|
8274 |
|
|
8275 |
$arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g; |
|
8276 |
$arg =~ s/\//\\\//g if ($escape_slash); |
|
8277 |
$arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg; |
|
8278 |
|
|
8279 |
if ($ascii) { |
|
8280 |
$arg = JSON_PP_encode_ascii($arg); |
|
8281 |
} |
|
8282 |
|
|
8283 |
if ($latin1) { |
|
8284 |
$arg = JSON_PP_encode_latin1($arg); |
|
8285 |
} |
|
8286 |
|
|
8287 |
if ($utf8) { |
|
8288 |
utf8::encode($arg); |
|
8289 |
} |
|
8290 |
|
|
8291 |
return '"' . $arg . '"'; |
|
8292 |
} |
|
8293 |
|
|
8294 |
|
|
8295 |
sub blessed_to_json { |
|
8296 |
my $reftype = reftype($_[1]) || ''; |
|
8297 |
if ($reftype eq 'HASH') { |
|
8298 |
return $_[0]->hash_to_json($_[1]); |
|
8299 |
} |
|
8300 |
elsif ($reftype eq 'ARRAY') { |
|
8301 |
return $_[0]->array_to_json($_[1]); |
|
8302 |
} |
|
8303 |
else { |
|
8304 |
return 'null'; |
|
8305 |
} |
|
8306 |
} |
|
8307 |
|
|
8308 |
|
|
8309 |
sub encode_error { |
|
8310 |
my $error = shift; |
|
8311 |
Carp::croak "$error"; |
|
8312 |
} |
|
8313 |
|
|
8314 |
|
|
8315 |
sub _sort { |
|
8316 |
defined $keysort ? (sort $keysort (keys %{$_[0]})) : keys %{$_[0]}; |
|
8317 |
} |
|
8318 |
|
|
8319 |
|
|
8320 |
sub _up_indent { |
|
8321 |
my $self = shift; |
|
8322 |
my $space = ' ' x $indent_length; |
|
8323 |
|
|
8324 |
my ($pre,$post) = ('',''); |
|
8325 |
|
|
8326 |
$post = "\n" . $space x $indent_count; |
|
8327 |
|
|
8328 |
$indent_count++; |
|
8329 |
|
|
8330 |
$pre = "\n" . $space x $indent_count; |
|
8331 |
|
|
8332 |
return ($pre,$post); |
|
8333 |
} |
|
8334 |
|
|
8335 |
|
|
8336 |
sub _down_indent { $indent_count--; } |
|
8337 |
|
|
8338 |
|
|
8339 |
sub PP_encode_box { |
|
8340 |
{ |
|
8341 |
depth => $depth, |
|
8342 |
indent_count => $indent_count, |
|
8343 |
}; |
|
8344 |
} |
|
8345 |
|
|
8346 |
} # Convert |
|
8347 |
|
|
8348 |
|
|
8349 |
sub _encode_ascii { |
|
8350 |
join('', |
|
8351 |
map { |
|
8352 |
$_ <= 127 ? |
|
8353 |
chr($_) : |
|
8354 |
$_ <= 65535 ? |
|
8355 |
sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_)); |
|
8356 |
} unpack('U*', $_[0]) |
|
8357 |
); |
|
8358 |
} |
|
8359 |
|
|
8360 |
|
|
8361 |
sub _encode_latin1 { |
|
8362 |
join('', |
|
8363 |
map { |
|
8364 |
$_ <= 255 ? |
|
8365 |
chr($_) : |
|
8366 |
$_ <= 65535 ? |
|
8367 |
sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_)); |
|
8368 |
} unpack('U*', $_[0]) |
|
8369 |
); |
|
8370 |
} |
|
8371 |
|
|
8372 |
|
|
8373 |
sub _encode_surrogates { # from perlunicode |
|
8374 |
my $uni = $_[0] - 0x10000; |
|
8375 |
return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00); |
|
8376 |
} |
|
8377 |
|
|
8378 |
|
|
8379 |
sub _is_bignum { |
|
8380 |
$_[0]->isa('Math::BigInt') or $_[0]->isa('Math::BigFloat'); |
|
8381 |
} |
|
8382 |
|
|
8383 |
|
|
8384 |
|
|
8385 |
# |
|
8386 |
# JSON => Perl |
|
8387 |
# |
|
8388 |
|
|
8389 |
my $max_intsize; |
|
8390 |
|
|
8391 |
BEGIN { |
|
8392 |
my $checkint = 1111; |
|
8393 |
for my $d (5..64) { |
|
8394 |
$checkint .= 1; |
|
8395 |
my $int = eval qq| $checkint |; |
|
8396 |
if ($int =~ /[eE]/) { |
|
8397 |
$max_intsize = $d - 1; |
|
8398 |
last; |
|
8399 |
} |
|
8400 |
} |
|
8401 |
} |
|
8402 |
|
|
8403 |
{ # PARSE |
|
8404 |
|
|
8405 |
my %escapes = ( # by Jeremy Muhlich <jmuhlich [at] bitflood.org> |
|
8406 |
b => "\x8", |
|
8407 |
t => "\x9", |
|
8408 |
n => "\xA", |
|
8409 |
f => "\xC", |
|
8410 |
r => "\xD", |
|
8411 |
'\\' => '\\', |
|
8412 |
'"' => '"', |
|
8413 |
'/' => '/', |
|
8414 |
); |
|
8415 |
|
|
8416 |
my $text; # json data |
|
8417 |
my $at; # offset |
|
8418 |
my $ch; # 1chracter |
|
8419 |
my $len; # text length (changed according to UTF8 or NON UTF8) |
|
8420 |
# INTERNAL |
|
8421 |
my $depth; # nest counter |
|
8422 |
my $encoding; # json text encoding |
|
8423 |
my $is_valid_utf8; # temp variable |
|
8424 |
my $utf8_len; # utf8 byte length |
|
8425 |
# FLAGS |
|
8426 |
my $utf8; # must be utf8 |
|
8427 |
my $max_depth; # max nest nubmer of objects and arrays |
|
8428 |
my $max_size; |
|
8429 |
my $relaxed; |
|
8430 |
my $cb_object; |
|
8431 |
my $cb_sk_object; |
|
8432 |
|
|
8433 |
my $F_HOOK; |
|
8434 |
|
|
8435 |
my $allow_bigint; # using Math::BigInt |
|
8436 |
my $singlequote; # loosely quoting |
|
8437 |
my $loose; # |
|
8438 |
my $allow_barekey; # bareKey |
|
8439 |
|
|
8440 |
# $opt flag |
|
8441 |
# 0x00000001 .... decode_prefix |
|
8442 |
# 0x10000000 .... incr_parse |
|
8443 |
|
|
8444 |
sub PP_decode_json { |
|
8445 |
my ($self, $opt); # $opt is an effective flag during this decode_json. |
|
8446 |
|
|
8447 |
($self, $text, $opt) = @_; |
|
8448 |
|
|
8449 |
($at, $ch, $depth) = (0, '', 0); |
|
8450 |
|
|
8451 |
if ( !defined $text or ref $text ) { |
|
8452 |
decode_error("malformed JSON string, neither array, object, number, string or atom"); |
|
8453 |
} |
|
8454 |
|
|
8455 |
my $idx = $self->{PROPS}; |
|
8456 |
|
|
8457 |
($utf8, $relaxed, $loose, $allow_bigint, $allow_barekey, $singlequote) |
|
8458 |
= @{$idx}[P_UTF8, P_RELAXED, P_LOOSE .. P_ALLOW_SINGLEQUOTE]; |
|
8459 |
|
|
8460 |
if ( $utf8 ) { |
|
8461 |
utf8::downgrade( $text, 1 ) or Carp::croak("Wide character in subroutine entry"); |
|
8462 |
} |
|
8463 |
else { |
|
8464 |
utf8::upgrade( $text ); |
|
8465 |
} |
|
8466 |
|
|
8467 |
$len = length $text; |
|
8468 |
|
|
8469 |
($max_depth, $max_size, $cb_object, $cb_sk_object, $F_HOOK) |
|
8470 |
= @{$self}{qw/max_depth max_size cb_object cb_sk_object F_HOOK/}; |
|
8471 |
|
|
8472 |
if ($max_size > 1) { |
|
8473 |
use bytes; |
|
8474 |
my $bytes = length $text; |
|
8475 |
decode_error( |
|
8476 |
sprintf("attempted decode of JSON text of %s bytes size, but max_size is set to %s" |
|
8477 |
, $bytes, $max_size), 1 |
|
8478 |
) if ($bytes > $max_size); |
|
8479 |
} |
|
8480 |
|
|
8481 |
# Currently no effect |
|
8482 |
# should use regexp |
|
8483 |
my @octets = unpack('C4', $text); |
|
8484 |
$encoding = ( $octets[0] and $octets[1]) ? 'UTF-8' |
|
8485 |
: (!$octets[0] and $octets[1]) ? 'UTF-16BE' |
|
8486 |
: (!$octets[0] and !$octets[1]) ? 'UTF-32BE' |
|
8487 |
: ( $octets[2] ) ? 'UTF-16LE' |
|
8488 |
: (!$octets[2] ) ? 'UTF-32LE' |
|
8489 |
: 'unknown'; |
|
8490 |
|
|
8491 |
white(); # remove head white space |
|
8492 |
|
|
8493 |
my $valid_start = defined $ch; # Is there a first character for JSON structure? |
|
8494 |
|
|
8495 |
my $result = value(); |
|
8496 |
|
|
8497 |
return undef if ( !$result && ( $opt & 0x10000000 ) ); # for incr_parse |
|
8498 |
|
|
8499 |
decode_error("malformed JSON string, neither array, object, number, string or atom") unless $valid_start; |
|
8500 |
|
|
8501 |
if ( !$idx->[ P_ALLOW_NONREF ] and !ref $result ) { |
|
8502 |
decode_error( |
|
8503 |
'JSON text must be an object or array (but found number, string, true, false or null,' |
|
8504 |
. ' use allow_nonref to allow this)', 1); |
|
8505 |
} |
|
8506 |
|
|
8507 |
Carp::croak('something wrong.') if $len < $at; # we won't arrive here. |
|
8508 |
|
|
8509 |
my $consumed = defined $ch ? $at - 1 : $at; # consumed JSON text length |
|
8510 |
|
|
8511 |
white(); # remove tail white space |
|
8512 |
|
|
8513 |
if ( $ch ) { |
|
8514 |
return ( $result, $consumed ) if ($opt & 0x00000001); # all right if decode_prefix |
|
8515 |
decode_error("garbage after JSON object"); |
|
8516 |
} |
|
8517 |
|
|
8518 |
( $opt & 0x00000001 ) ? ( $result, $consumed ) : $result; |
|
8519 |
} |
|
8520 |
|
|
8521 |
|
|
8522 |
sub next_chr { |
|
8523 |
return $ch = undef if($at >= $len); |
|
8524 |
$ch = substr($text, $at++, 1); |
|
8525 |
} |
|
8526 |
|
|
8527 |
|
|
8528 |
sub value { |
|
8529 |
white(); |
|
8530 |
return if(!defined $ch); |
|
8531 |
return object() if($ch eq '{'); |
|
8532 |
return array() if($ch eq '['); |
|
8533 |
return string() if($ch eq '"' or ($singlequote and $ch eq "'")); |
|
8534 |
return number() if($ch =~ /[0-9]/ or $ch eq '-'); |
|
8535 |
return word(); |
|
8536 |
} |
|
8537 |
|
|
8538 |
sub string { |
|
8539 |
my ($i, $s, $t, $u); |
|
8540 |
my $utf16; |
|
8541 |
my $is_utf8; |
|
8542 |
|
|
8543 |
($is_valid_utf8, $utf8_len) = ('', 0); |
|
8544 |
|
|
8545 |
$s = ''; # basically UTF8 flag on |
|
8546 |
|
|
8547 |
if($ch eq '"' or ($singlequote and $ch eq "'")){ |
|
8548 |
my $boundChar = $ch; |
|
8549 |
|
|
8550 |
OUTER: while( defined(next_chr()) ){ |
|
8551 |
|
|
8552 |
if($ch eq $boundChar){ |
|
8553 |
next_chr(); |
|
8554 |
|
|
8555 |
if ($utf16) { |
|
8556 |
decode_error("missing low surrogate character in surrogate pair"); |
|
8557 |
} |
|
8558 |
|
|
8559 |
utf8::decode($s) if($is_utf8); |
|
8560 |
|
|
8561 |
return $s; |
|
8562 |
} |
|
8563 |
elsif($ch eq '\\'){ |
|
8564 |
next_chr(); |
|
8565 |
if(exists $escapes{$ch}){ |
|
8566 |
$s .= $escapes{$ch}; |
|
8567 |
} |
|
8568 |
elsif($ch eq 'u'){ # UNICODE handling |
|
8569 |
my $u = ''; |
|
8570 |
|
|
8571 |
for(1..4){ |
|
8572 |
$ch = next_chr(); |
|
8573 |
last OUTER if($ch !~ /[0-9a-fA-F]/); |
|
8574 |
$u .= $ch; |
|
8575 |
} |
|
8576 |
|
|
8577 |
# U+D800 - U+DBFF |
|
8578 |
if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/) { # UTF-16 high surrogate? |
|
8579 |
$utf16 = $u; |
|
8580 |
} |
|
8581 |
# U+DC00 - U+DFFF |
|
8582 |
elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/) { # UTF-16 low surrogate? |
|
8583 |
unless (defined $utf16) { |
|
8584 |
decode_error("missing high surrogate character in surrogate pair"); |
|
8585 |
} |
|
8586 |
$is_utf8 = 1; |
|
8587 |
$s .= JSON_PP_decode_surrogates($utf16, $u) || next; |
|
8588 |
$utf16 = undef; |
|
8589 |
} |
|
8590 |
else { |
|
8591 |
if (defined $utf16) { |
|
8592 |
decode_error("surrogate pair expected"); |
|
8593 |
} |
|
8594 |
|
|
8595 |
if ( ( my $hex = hex( $u ) ) > 127 ) { |
|
8596 |
$is_utf8 = 1; |
|
8597 |
$s .= JSON_PP_decode_unicode($u) || next; |
|
8598 |
} |
|
8599 |
else { |
|
8600 |
$s .= chr $hex; |
|
8601 |
} |
|
8602 |
} |
|
8603 |
|
|
8604 |
} |
|
8605 |
else{ |
|
8606 |
unless ($loose) { |
|
8607 |
$at -= 2; |
|
8608 |
decode_error('illegal backslash escape sequence in string'); |
|
8609 |
} |
|
8610 |
$s .= $ch; |
|
8611 |
} |
|
8612 |
} |
|
8613 |
else{ |
|
8614 |
|
|
8615 |
if ( ord $ch > 127 ) { |
|
8616 |
if ( $utf8 ) { |
|
8617 |
unless( $ch = is_valid_utf8($ch) ) { |
|
8618 |
$at -= 1; |
|
8619 |
decode_error("malformed UTF-8 character in JSON string"); |
|
8620 |
} |
|
8621 |
else { |
|
8622 |
$at += $utf8_len - 1; |
|
8623 |
} |
|
8624 |
} |
|
8625 |
else { |
|
8626 |
utf8::encode( $ch ); |
|
8627 |
} |
|
8628 |
|
|
8629 |
$is_utf8 = 1; |
|
8630 |
} |
|
8631 |
|
|
8632 |
if (!$loose) { |
|
8633 |
if ($ch =~ /[\x00-\x1f\x22\x5c]/) { # '/' ok |
|
8634 |
$at--; |
|
8635 |
decode_error('invalid character encountered while parsing JSON string'); |
|
8636 |
} |
|
8637 |
} |
|
8638 |
|
|
8639 |
$s .= $ch; |
|
8640 |
} |
|
8641 |
} |
|
8642 |
} |
|
8643 |
|
|
8644 |
decode_error("unexpected end of string while parsing JSON string"); |
|
8645 |
} |
|
8646 |
|
|
8647 |
|
|
8648 |
sub white { |
|
8649 |
while( defined $ch ){ |
|
8650 |
if($ch le ' '){ |
|
8651 |
next_chr(); |
|
8652 |
} |
|
8653 |
elsif($ch eq '/'){ |
|
8654 |
next_chr(); |
|
8655 |
if(defined $ch and $ch eq '/'){ |
|
8656 |
1 while(defined(next_chr()) and $ch ne "\n" and $ch ne "\r"); |
|
8657 |
} |
|
8658 |
elsif(defined $ch and $ch eq '*'){ |
|
8659 |
next_chr(); |
|
8660 |
while(1){ |
|
8661 |
if(defined $ch){ |
|
8662 |
if($ch eq '*'){ |
|
8663 |
if(defined(next_chr()) and $ch eq '/'){ |
|
8664 |
next_chr(); |
|
8665 |
last; |
|
8666 |
} |
|
8667 |
} |
|
8668 |
else{ |
|
8669 |
next_chr(); |
|
8670 |
} |
|
8671 |
} |
|
8672 |
else{ |
|
8673 |
decode_error("Unterminated comment"); |
|
8674 |
} |
|
8675 |
} |
|
8676 |
next; |
|
8677 |
} |
|
8678 |
else{ |
|
8679 |
$at--; |
|
8680 |
decode_error("malformed JSON string, neither array, object, number, string or atom"); |
|
8681 |
} |
|
8682 |
} |
|
8683 |
else{ |
|
8684 |
if ($relaxed and $ch eq '#') { # correctly? |
|
8685 |
pos($text) = $at; |
|
8686 |
$text =~ /\G([^\n]*(?:\r\n|\r|\n|$))/g; |
|
8687 |
$at = pos($text); |
|
8688 |
next_chr; |
|
8689 |
next; |
|
8690 |
} |
|
8691 |
|
|
8692 |
last; |
|
8693 |
} |
|
8694 |
} |
|
8695 |
} |
|
8696 |
|
|
8697 |
|
|
8698 |
sub array { |
|
8699 |
my $a = $_[0] || []; # you can use this code to use another array ref object. |
|
8700 |
|
|
8701 |
decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)') |
|
8702 |
if (++$depth > $max_depth); |
|
8703 |
|
|
8704 |
next_chr(); |
|
8705 |
white(); |
|
8706 |
|
|
8707 |
if(defined $ch and $ch eq ']'){ |
|
8708 |
--$depth; |
|
8709 |
next_chr(); |
|
8710 |
return $a; |
|
8711 |
} |
|
8712 |
else { |
|
8713 |
while(defined($ch)){ |
|
8714 |
push @$a, value(); |
|
8715 |
|
|
8716 |
white(); |
|
8717 |
|
|
8718 |
if (!defined $ch) { |
|
8719 |
last; |
|
8720 |
} |
|
8721 |
|
|
8722 |
if($ch eq ']'){ |
|
8723 |
--$depth; |
|
8724 |
next_chr(); |
|
8725 |
return $a; |
|
8726 |
} |
|
8727 |
|
|
8728 |
if($ch ne ','){ |
|
8729 |
last; |
|
8730 |
} |
|
8731 |
|
|
8732 |
next_chr(); |
|
8733 |
white(); |
|
8734 |
|
|
8735 |
if ($relaxed and $ch eq ']') { |
|
8736 |
--$depth; |
|
8737 |
next_chr(); |
|
8738 |
return $a; |
|
8739 |
} |
|
8740 |
|
|
8741 |
} |
|
8742 |
} |
|
8743 |
|
|
8744 |
decode_error(", or ] expected while parsing array"); |
|
8745 |
} |
|
8746 |
|
|
8747 |
|
|
8748 |
sub object { |
|
8749 |
my $o = $_[0] || {}; # you can use this code to use another hash ref object. |
|
8750 |
my $k; |
|
8751 |
|
|
8752 |
decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)') |
|
8753 |
if (++$depth > $max_depth); |
|
8754 |
next_chr(); |
|
8755 |
white(); |
|
8756 |
|
|
8757 |
if(defined $ch and $ch eq '}'){ |
|
8758 |
--$depth; |
|
8759 |
next_chr(); |
|
8760 |
if ($F_HOOK) { |
|
8761 |
return _json_object_hook($o); |
|
8762 |
} |
|
8763 |
return $o; |
|
8764 |
} |
|
8765 |
else { |
|
8766 |
while (defined $ch) { |
|
8767 |
$k = ($allow_barekey and $ch ne '"' and $ch ne "'") ? bareKey() : string(); |
|
8768 |
white(); |
|
8769 |
|
|
8770 |
if(!defined $ch or $ch ne ':'){ |
|
8771 |
$at--; |
|
8772 |
decode_error("':' expected"); |
|
8773 |
} |
|
8774 |
|
|
8775 |
next_chr(); |
|
8776 |
$o->{$k} = value(); |
|
8777 |
white(); |
|
8778 |
|
|
8779 |
last if (!defined $ch); |
|
8780 |
|
|
8781 |
if($ch eq '}'){ |
|
8782 |
--$depth; |
|
8783 |
next_chr(); |
|
8784 |
if ($F_HOOK) { |
|
8785 |
return _json_object_hook($o); |
|
8786 |
} |
|
8787 |
return $o; |
|
8788 |
} |
|
8789 |
|
|
8790 |
if($ch ne ','){ |
|
8791 |
last; |
|
8792 |
} |
|
8793 |
|
|
8794 |
next_chr(); |
|
8795 |
white(); |
|
8796 |
|
|
8797 |
if ($relaxed and $ch eq '}') { |
|
8798 |
--$depth; |
|
8799 |
next_chr(); |
|
8800 |
if ($F_HOOK) { |
|
8801 |
return _json_object_hook($o); |
|
8802 |
} |
|
8803 |
return $o; |
|
8804 |
} |
|
8805 |
|
|
8806 |
} |
|
8807 |
|
|
8808 |
} |
|
8809 |
|
|
8810 |
$at--; |
|
8811 |
decode_error(", or } expected while parsing object/hash"); |
|
8812 |
} |
|
8813 |
|
|
8814 |
|
|
8815 |
sub bareKey { # doesn't strictly follow Standard ECMA-262 3rd Edition |
|
8816 |
my $key; |
|
8817 |
while($ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){ |
|
8818 |
$key .= $ch; |
|
8819 |
next_chr(); |
|
8820 |
} |
|
8821 |
return $key; |
|
8822 |
} |
|
8823 |
|
|
8824 |
|
|
8825 |
sub word { |
|
8826 |
my $word = substr($text,$at-1,4); |
|
8827 |
|
|
8828 |
if($word eq 'true'){ |
|
8829 |
$at += 3; |
|
8830 |
next_chr; |
|
8831 |
return $JSON::PP::true; |
|
8832 |
} |
|
8833 |
elsif($word eq 'null'){ |
|
8834 |
$at += 3; |
|
8835 |
next_chr; |
|
8836 |
return undef; |
|
8837 |
} |
|
8838 |
elsif($word eq 'fals'){ |
|
8839 |
$at += 3; |
|
8840 |
if(substr($text,$at,1) eq 'e'){ |
|
8841 |
$at++; |
|
8842 |
next_chr; |
|
8843 |
return $JSON::PP::false; |
|
8844 |
} |
|
8845 |
} |
|
8846 |
|
|
8847 |
$at--; # for decode_error report |
|
8848 |
|
|
8849 |
decode_error("'null' expected") if ($word =~ /^n/); |
|
8850 |
decode_error("'true' expected") if ($word =~ /^t/); |
|
8851 |
decode_error("'false' expected") if ($word =~ /^f/); |
|
8852 |
decode_error("malformed JSON string, neither array, object, number, string or atom"); |
|
8853 |
} |
|
8854 |
|
|
8855 |
|
|
8856 |
sub number { |
|
8857 |
my $n = ''; |
|
8858 |
my $v; |
|
8859 |
|
|
8860 |
# According to RFC4627, hex or oct digts are invalid. |
|
8861 |
if($ch eq '0'){ |
|
8862 |
my $peek = substr($text,$at,1); |
|
8863 |
my $hex = $peek =~ /[xX]/; # 0 or 1 |
|
8864 |
|
|
8865 |
if($hex){ |
|
8866 |
decode_error("malformed number (leading zero must not be followed by another digit)"); |
|
8867 |
($n) = ( substr($text, $at+1) =~ /^([0-9a-fA-F]+)/); |
|
8868 |
} |
|
8869 |
else{ # oct |
|
8870 |
($n) = ( substr($text, $at) =~ /^([0-7]+)/); |
|
8871 |
if (defined $n and length $n > 1) { |
|
8872 |
decode_error("malformed number (leading zero must not be followed by another digit)"); |
|
8873 |
} |
|
8874 |
} |
|
8875 |
|
|
8876 |
if(defined $n and length($n)){ |
|
8877 |
if (!$hex and length($n) == 1) { |
|
8878 |
decode_error("malformed number (leading zero must not be followed by another digit)"); |
|
8879 |
} |
|
8880 |
$at += length($n) + $hex; |
|
8881 |
next_chr; |
|
8882 |
return $hex ? hex($n) : oct($n); |
|
8883 |
} |
|
8884 |
} |
|
8885 |
|
|
8886 |
if($ch eq '-'){ |
|
8887 |
$n = '-'; |
|
8888 |
next_chr; |
|
8889 |
if (!defined $ch or $ch !~ /\d/) { |
|
8890 |
decode_error("malformed number (no digits after initial minus)"); |
|
8891 |
} |
|
8892 |
} |
|
8893 |
|
|
8894 |
while(defined $ch and $ch =~ /\d/){ |
|
8895 |
$n .= $ch; |
|
8896 |
next_chr; |
|
8897 |
} |
|
8898 |
|
|
8899 |
if(defined $ch and $ch eq '.'){ |
|
8900 |
$n .= '.'; |
|
8901 |
|
|
8902 |
next_chr; |
|
8903 |
if (!defined $ch or $ch !~ /\d/) { |
|
8904 |
decode_error("malformed number (no digits after decimal point)"); |
|
8905 |
} |
|
8906 |
else { |
|
8907 |
$n .= $ch; |
|
8908 |
} |
|
8909 |
|
|
8910 |
while(defined(next_chr) and $ch =~ /\d/){ |
|
8911 |
$n .= $ch; |
|
8912 |
} |
|
8913 |
} |
|
8914 |
|
|
8915 |
if(defined $ch and ($ch eq 'e' or $ch eq 'E')){ |
|
8916 |
$n .= $ch; |
|
8917 |
next_chr; |
|
8918 |
|
|
8919 |
if(defined($ch) and ($ch eq '+' or $ch eq '-')){ |
|
8920 |
$n .= $ch; |
|
8921 |
next_chr; |
|
8922 |
if (!defined $ch or $ch =~ /\D/) { |
|
8923 |
decode_error("malformed number (no digits after exp sign)"); |
|
8924 |
} |
|
8925 |
$n .= $ch; |
|
8926 |
} |
|
8927 |
elsif(defined($ch) and $ch =~ /\d/){ |
|
8928 |
$n .= $ch; |
|
8929 |
} |
|
8930 |
else { |
|
8931 |
decode_error("malformed number (no digits after exp sign)"); |
|
8932 |
} |
|
8933 |
|
|
8934 |
while(defined(next_chr) and $ch =~ /\d/){ |
|
8935 |
$n .= $ch; |
|
8936 |
} |
|
8937 |
|
|
8938 |
} |
|
8939 |
|
|
8940 |
$v .= $n; |
|
8941 |
|
|
8942 |
if ($v !~ /[.eE]/ and length $v > $max_intsize) { |
|
8943 |
if ($allow_bigint) { # from Adam Sussman |
|
8944 |
require Math::BigInt; |
|
8945 |
return Math::BigInt->new($v); |
|
8946 |
} |
|
8947 |
else { |
|
8948 |
return "$v"; |
|
8949 |
} |
|
8950 |
} |
|
8951 |
elsif ($allow_bigint) { |
|
8952 |
require Math::BigFloat; |
|
8953 |
return Math::BigFloat->new($v); |
|
8954 |
} |
|
8955 |
|
|
8956 |
return 0+$v; |
|
8957 |
} |
|
8958 |
|
|
8959 |
|
|
8960 |
sub is_valid_utf8 { |
|
8961 |
|
|
8962 |
$utf8_len = $_[0] =~ /[\x00-\x7F]/ ? 1 |
|
8963 |
: $_[0] =~ /[\xC2-\xDF]/ ? 2 |
|
8964 |
: $_[0] =~ /[\xE0-\xEF]/ ? 3 |
|
8965 |
: $_[0] =~ /[\xF0-\xF4]/ ? 4 |
|
8966 |
: 0 |
|
8967 |
; |
|
8968 |
|
|
8969 |
return unless $utf8_len; |
|
8970 |
|
|
8971 |
my $is_valid_utf8 = substr($text, $at - 1, $utf8_len); |
|
8972 |
|
|
8973 |
return ( $is_valid_utf8 =~ /^(?: |
|
8974 |
[\x00-\x7F] |
|
8975 |
|[\xC2-\xDF][\x80-\xBF] |
|
8976 |
|[\xE0][\xA0-\xBF][\x80-\xBF] |
|
8977 |
|[\xE1-\xEC][\x80-\xBF][\x80-\xBF] |
|
8978 |
|[\xED][\x80-\x9F][\x80-\xBF] |
|
8979 |
|[\xEE-\xEF][\x80-\xBF][\x80-\xBF] |
|
8980 |
|[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF] |
|
8981 |
|[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF] |
|
8982 |
|[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF] |
|
8983 |
)$/x ) ? $is_valid_utf8 : ''; |
|
8984 |
} |
|
8985 |
|
|
8986 |
|
|
8987 |
sub decode_error { |
|
8988 |
my $error = shift; |
|
8989 |
my $no_rep = shift; |
|
8990 |
my $str = defined $text ? substr($text, $at) : ''; |
|
8991 |
my $mess = ''; |
|
8992 |
my $type = $] >= 5.008 ? 'U*' |
|
8993 |
: $] < 5.006 ? 'C*' |
|
8994 |
: utf8::is_utf8( $str ) ? 'U*' # 5.6 |
|
8995 |
: 'C*' |
|
8996 |
; |
|
8997 |
|
|
8998 |
for my $c ( unpack( $type, $str ) ) { # emulate pv_uni_display() ? |
|
8999 |
$mess .= $c == 0x07 ? '\a' |
|
9000 |
: $c == 0x09 ? '\t' |
|
9001 |
: $c == 0x0a ? '\n' |
|
9002 |
: $c == 0x0d ? '\r' |
|
9003 |
: $c == 0x0c ? '\f' |
|
9004 |
: $c < 0x20 ? sprintf('\x{%x}', $c) |
|
9005 |
: $c == 0x5c ? '\\\\' |
|
9006 |
: $c < 0x80 ? chr($c) |
|
9007 |
: sprintf('\x{%x}', $c) |
|
9008 |
; |
|
9009 |
if ( length $mess >= 20 ) { |
|
9010 |
$mess .= '...'; |
|
9011 |
last; |
|
9012 |
} |
|
9013 |
} |
|
9014 |
|
|
9015 |
unless ( length $mess ) { |
|
9016 |
$mess = '(end of string)'; |
|
9017 |
} |
|
9018 |
|
|
9019 |
Carp::croak ( |
|
9020 |
$no_rep ? "$error" : "$error, at character offset $at (before \"$mess\")" |
|
9021 |
); |
|
9022 |
|
|
9023 |
} |
|
9024 |
|
|
9025 |
|
|
9026 |
sub _json_object_hook { |
|
9027 |
my $o = $_[0]; |
|
9028 |
my @ks = keys %{$o}; |
|
9029 |
|
|
9030 |
if ( $cb_sk_object and @ks == 1 and exists $cb_sk_object->{ $ks[0] } and ref $cb_sk_object->{ $ks[0] } ) { |
|
9031 |
my @val = $cb_sk_object->{ $ks[0] }->( $o->{$ks[0]} ); |
|
9032 |
if (@val == 1) { |
|
9033 |
return $val[0]; |
|
9034 |
} |
|
9035 |
} |
|
9036 |
|
|
9037 |
my @val = $cb_object->($o) if ($cb_object); |
|
9038 |
if (@val == 0 or @val > 1) { |
|
9039 |
return $o; |
|
9040 |
} |
|
9041 |
else { |
|
9042 |
return $val[0]; |
|
9043 |
} |
|
9044 |
} |
|
9045 |
|
|
9046 |
|
|
9047 |
sub PP_decode_box { |
|
9048 |
{ |
|
9049 |
text => $text, |
|
9050 |
at => $at, |
|
9051 |
ch => $ch, |
|
9052 |
len => $len, |
|
9053 |
depth => $depth, |
|
9054 |
encoding => $encoding, |
|
9055 |
is_valid_utf8 => $is_valid_utf8, |
|
9056 |
}; |
|
9057 |
} |
|
9058 |
|
|
9059 |
} # PARSE |
|
9060 |
|
|
9061 |
|
|
9062 |
sub _decode_surrogates { # from perlunicode |
|
9063 |
my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00); |
|
9064 |
my $un = pack('U*', $uni); |
|
9065 |
utf8::encode( $un ); |
|
9066 |
return $un; |
|
9067 |
} |
|
9068 |
|
|
9069 |
|
|
9070 |
sub _decode_unicode { |
|
9071 |
my $un = pack('U', hex shift); |
|
9072 |
utf8::encode( $un ); |
|
9073 |
return $un; |
|
9074 |
} |
|
9075 |
|
|
9076 |
# |
|
9077 |
# Setup for various Perl versions (the code from JSON::PP58) |
|
9078 |
# |
|
9079 |
|
|
9080 |
BEGIN { |
|
9081 |
|
|
9082 |
unless ( defined &utf8::is_utf8 ) { |
|
9083 |
require Encode; |
|
9084 |
*utf8::is_utf8 = *Encode::is_utf8; |
|
9085 |
} |
|
9086 |
|
|
9087 |
if ( $] >= 5.008 ) { |
|
9088 |
*JSON::PP::JSON_PP_encode_ascii = \&_encode_ascii; |
|
9089 |
*JSON::PP::JSON_PP_encode_latin1 = \&_encode_latin1; |
|
9090 |
*JSON::PP::JSON_PP_decode_surrogates = \&_decode_surrogates; |
|
9091 |
*JSON::PP::JSON_PP_decode_unicode = \&_decode_unicode; |
|
9092 |
} |
|
9093 |
|
|
9094 |
if ($] >= 5.008 and $] < 5.008003) { # join() in 5.8.0 - 5.8.2 is broken. |
|
9095 |
package JSON::PP; |
|
9096 |
require subs; |
|
9097 |
subs->import('join'); |
|
9098 |
eval q| |
|
9099 |
sub join { |
|
9100 |
return '' if (@_ < 2); |
|
9101 |
my $j = shift; |
|
9102 |
my $str = shift; |
|
9103 |
for (@_) { $str .= $j . $_; } |
|
9104 |
return $str; |
|
9105 |
} |
|
9106 |
|; |
|
9107 |
} |
|
9108 |
|
|
9109 |
|
|
9110 |
sub JSON::PP::incr_parse { |
|
9111 |
local $Carp::CarpLevel = 1; |
|
9112 |
( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ ); |
|
9113 |
} |
|
9114 |
|
|
9115 |
|
|
9116 |
sub JSON::PP::incr_skip { |
|
9117 |
( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip; |
|
9118 |
} |
|
9119 |
|
|
9120 |
|
|
9121 |
sub JSON::PP::incr_reset { |
|
9122 |
( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset; |
|
9123 |
} |
|
9124 |
|
|
9125 |
eval q{ |
|
9126 |
sub JSON::PP::incr_text : lvalue { |
|
9127 |
$_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new; |
|
9128 |
|
|
9129 |
if ( $_[0]->{_incr_parser}->{incr_parsing} ) { |
|
9130 |
Carp::croak("incr_text can not be called when the incremental parser already started parsing"); |
|
9131 |
} |
|
9132 |
$_[0]->{_incr_parser}->{incr_text}; |
|
9133 |
} |
|
9134 |
} if ( $] >= 5.006 ); |
|
9135 |
|
|
9136 |
} # Setup for various Perl versions (the code from JSON::PP58) |
|
9137 |
|
|
9138 |
|
|
9139 |
############################### |
|
9140 |
# Utilities |
|
9141 |
# |
|
9142 |
|
|
9143 |
BEGIN { |
|
9144 |
eval 'require Scalar::Util'; |
|
9145 |
unless($@){ |
|
9146 |
*JSON::PP::blessed = \&Scalar::Util::blessed; |
|
9147 |
*JSON::PP::reftype = \&Scalar::Util::reftype; |
|
9148 |
*JSON::PP::refaddr = \&Scalar::Util::refaddr; |
|
9149 |
} |
|
9150 |
else{ # This code is from Sclar::Util. |
|
9151 |
# warn $@; |
|
9152 |
eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }'; |
|
9153 |
*JSON::PP::blessed = sub { |
|
9154 |
local($@, $SIG{__DIE__}, $SIG{__WARN__}); |
|
9155 |
ref($_[0]) ? eval { $_[0]->a_sub_not_likely_to_be_here } : undef; |
|
9156 |
}; |
|
9157 |
my %tmap = qw( |
|
9158 |
B::NULL SCALAR |
|
9159 |
B::HV HASH |
|
9160 |
B::AV ARRAY |
|
9161 |
B::CV CODE |
|
9162 |
B::IO IO |
|
9163 |
B::GV GLOB |
|
9164 |
B::REGEXP REGEXP |
|
9165 |
); |
|
9166 |
*JSON::PP::reftype = sub { |
|
9167 |
my $r = shift; |
|
9168 |
|
|
9169 |
return undef unless length(ref($r)); |
|
9170 |
|
|
9171 |
my $t = ref(B::svref_2object($r)); |
|
9172 |
|
|
9173 |
return |
|
9174 |
exists $tmap{$t} ? $tmap{$t} |
|
9175 |
: length(ref($$r)) ? 'REF' |
|
9176 |
: 'SCALAR'; |
|
9177 |
}; |
|
9178 |
*JSON::PP::refaddr = sub { |
|
9179 |
return undef unless length(ref($_[0])); |
|
9180 |
|
|
9181 |
my $addr; |
|
9182 |
if(defined(my $pkg = blessed($_[0]))) { |
|
9183 |
$addr .= bless $_[0], 'Scalar::Util::Fake'; |
|
9184 |
bless $_[0], $pkg; |
|
9185 |
} |
|
9186 |
else { |
|
9187 |
$addr .= $_[0] |
|
9188 |
} |
|
9189 |
|
|
9190 |
$addr =~ /0x(\w+)/; |
|
9191 |
local $^W; |
|
9192 |
#no warnings 'portable'; |
|
9193 |
hex($1); |
|
9194 |
} |
|
9195 |
} |
|
9196 |
} |
|
9197 |
|
|
9198 |
|
|
9199 |
# shamely copied and modified from JSON::XS code. |
|
9200 |
|
|
9201 |
$JSON::PP::true = do { bless \(my $dummy = 1), "JSON::PP::Boolean" }; |
|
9202 |
$JSON::PP::false = do { bless \(my $dummy = 0), "JSON::PP::Boolean" }; |
|
9203 |
|
|
9204 |
sub is_bool { defined $_[0] and UNIVERSAL::isa($_[0], "JSON::PP::Boolean"); } |
|
9205 |
|
|
9206 |
sub true { $JSON::PP::true } |
|
9207 |
sub false { $JSON::PP::false } |
|
9208 |
sub null { undef; } |
|
9209 |
|
|
9210 |
############################### |
|
9211 |
|
|
9212 |
package JSON::PP::Boolean; |
|
9213 |
|
|
9214 |
use overload ( |
|
9215 |
"0+" => sub { ${$_[0]} }, |
|
9216 |
"++" => sub { $_[0] = ${$_[0]} + 1 }, |
|
9217 |
"--" => sub { $_[0] = ${$_[0]} - 1 }, |
|
9218 |
fallback => 1, |
|
9219 |
); |
|
9220 |
|
|
9221 |
|
|
9222 |
############################### |
|
9223 |
|
|
9224 |
package JSON::PP::IncrParser; |
|
9225 |
|
|
9226 |
use strict; |
|
9227 |
|
|
9228 |
use constant INCR_M_WS => 0; # initial whitespace skipping |
|
9229 |
use constant INCR_M_STR => 1; # inside string |
|
9230 |
use constant INCR_M_BS => 2; # inside backslash |
|
9231 |
use constant INCR_M_JSON => 3; # outside anything, count nesting |
|
9232 |
use constant INCR_M_C0 => 4; |
|
9233 |
use constant INCR_M_C1 => 5; |
|
9234 |
|
|
9235 |
$JSON::PP::IncrParser::VERSION = '1.01'; |
|
9236 |
|
|
9237 |
my $unpack_format = $] < 5.006 ? 'C*' : 'U*'; |
|
9238 |
|
|
9239 |
sub new { |
|
9240 |
my ( $class ) = @_; |
|
9241 |
|
|
9242 |
bless { |
|
9243 |
incr_nest => 0, |
|
9244 |
incr_text => undef, |
|
9245 |
incr_parsing => 0, |
|
9246 |
incr_p => 0, |
|
9247 |
}, $class; |
|
9248 |
} |
|
9249 |
|
|
9250 |
|
|
9251 |
sub incr_parse { |
|
9252 |
my ( $self, $coder, $text ) = @_; |
|
9253 |
|
|
9254 |
$self->{incr_text} = '' unless ( defined $self->{incr_text} ); |
|
9255 |
|
|
9256 |
if ( defined $text ) { |
|
9257 |
if ( utf8::is_utf8( $text ) and !utf8::is_utf8( $self->{incr_text} ) ) { |
|
9258 |
utf8::upgrade( $self->{incr_text} ) ; |
|
9259 |
utf8::decode( $self->{incr_text} ) ; |
|
9260 |
} |
|
9261 |
$self->{incr_text} .= $text; |
|
9262 |
} |
|
9263 |
|
|
9264 |
|
|
9265 |
my $max_size = $coder->get_max_size; |
|
9266 |
|
|
9267 |
if ( defined wantarray ) { |
|
9268 |
|
|
9269 |
$self->{incr_mode} = INCR_M_WS unless defined $self->{incr_mode}; |
|
9270 |
|
|
9271 |
if ( wantarray ) { |
|
9272 |
my @ret; |
|
9273 |
|
|
9274 |
$self->{incr_parsing} = 1; |
|
9275 |
|
|
9276 |
do { |
|
9277 |
push @ret, $self->_incr_parse( $coder, $self->{incr_text} ); |
|
9278 |
|
|
9279 |
unless ( !$self->{incr_nest} and $self->{incr_mode} == INCR_M_JSON ) { |
|
9280 |
$self->{incr_mode} = INCR_M_WS if $self->{incr_mode} != INCR_M_STR; |
|
9281 |
} |
|
9282 |
|
|
9283 |
} until ( length $self->{incr_text} >= $self->{incr_p} ); |
|
9284 |
|
|
9285 |
$self->{incr_parsing} = 0; |
|
9286 |
|
|
9287 |
return @ret; |
|
9288 |
} |
|
9289 |
else { # in scalar context |
|
9290 |
$self->{incr_parsing} = 1; |
|
9291 |
my $obj = $self->_incr_parse( $coder, $self->{incr_text} ); |
|
9292 |
$self->{incr_parsing} = 0 if defined $obj; # pointed by Martin J. Evans |
|
9293 |
return $obj ? $obj : undef; # $obj is an empty string, parsing was completed. |
|
9294 |
} |
|
9295 |
|
|
9296 |
} |
|
9297 |
|
|
9298 |
} |
|
9299 |
|
|
9300 |
|
|
9301 |
sub _incr_parse { |
|
9302 |
my ( $self, $coder, $text, $skip ) = @_; |
|
9303 |
my $p = $self->{incr_p}; |
|
9304 |
my $restore = $p; |
|
9305 |
|
|
9306 |
my @obj; |
|
9307 |
my $len = length $text; |
|
9308 |
|
|
9309 |
if ( $self->{incr_mode} == INCR_M_WS ) { |
|
9310 |
while ( $len > $p ) { |
|
9311 |
my $s = substr( $text, $p, 1 ); |
|
9312 |
$p++ and next if ( 0x20 >= unpack($unpack_format, $s) ); |
|
9313 |
$self->{incr_mode} = INCR_M_JSON; |
|
9314 |
last; |
|
9315 |
} |
|
9316 |
} |
|
9317 |
|
|
9318 |
while ( $len > $p ) { |
|
9319 |
my $s = substr( $text, $p++, 1 ); |
|
9320 |
|
|
9321 |
if ( $s eq '"' ) { |
|
9322 |
if (substr( $text, $p - 2, 1 ) eq '\\' ) { |
|
9323 |
next; |
|
9324 |
} |
|
9325 |
|
|
9326 |
if ( $self->{incr_mode} != INCR_M_STR ) { |
|
9327 |
$self->{incr_mode} = INCR_M_STR; |
|
9328 |
} |
|
9329 |
else { |
|
9330 |
$self->{incr_mode} = INCR_M_JSON; |
|
9331 |
unless ( $self->{incr_nest} ) { |
|
9332 |
last; |
|
9333 |
} |
|
9334 |
} |
|
9335 |
} |
|
9336 |
|
|
9337 |
if ( $self->{incr_mode} == INCR_M_JSON ) { |
|
9338 |
|
|
9339 |
if ( $s eq '[' or $s eq '{' ) { |
|
9340 |
if ( ++$self->{incr_nest} > $coder->get_max_depth ) { |
|
9341 |
Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)'); |
|
9342 |
} |
|
9343 |
} |
|
9344 |
elsif ( $s eq ']' or $s eq '}' ) { |
|
9345 |
last if ( --$self->{incr_nest} <= 0 ); |
|
9346 |
} |
|
9347 |
elsif ( $s eq '#' ) { |
|
9348 |
while ( $len > $p ) { |
|
9349 |
last if substr( $text, $p++, 1 ) eq "\n"; |
|
9350 |
} |
|
9351 |
} |
|
9352 |
|
|
9353 |
} |
|
9354 |
|
|
9355 |
} |
|
9356 |
|
|
9357 |
$self->{incr_p} = $p; |
|
9358 |
|
|
9359 |
return if ( $self->{incr_mode} == INCR_M_STR and not $self->{incr_nest} ); |
|
9360 |
return if ( $self->{incr_mode} == INCR_M_JSON and $self->{incr_nest} > 0 ); |
|
9361 |
|
|
9362 |
return '' unless ( length substr( $self->{incr_text}, 0, $p ) ); |
|
9363 |
|
|
9364 |
local $Carp::CarpLevel = 2; |
|
9365 |
|
|
9366 |
$self->{incr_p} = $restore; |
|
9367 |
$self->{incr_c} = $p; |
|
9368 |
|
|
9369 |
my ( $obj, $tail ) = $coder->PP_decode_json( substr( $self->{incr_text}, 0, $p ), 0x10000001 ); |
|
9370 |
|
|
9371 |
$self->{incr_text} = substr( $self->{incr_text}, $p ); |
|
9372 |
$self->{incr_p} = 0; |
|
9373 |
|
|
9374 |
return $obj or ''; |
|
9375 |
} |
|
9376 |
|
|
9377 |
|
|
9378 |
sub incr_text { |
|
9379 |
if ( $_[0]->{incr_parsing} ) { |
|
9380 |
Carp::croak("incr_text can not be called when the incremental parser already started parsing"); |
|
9381 |
} |
|
9382 |
$_[0]->{incr_text}; |
|
9383 |
} |
|
9384 |
|
|
9385 |
|
|
9386 |
sub incr_skip { |
|
9387 |
my $self = shift; |
|
9388 |
$self->{incr_text} = substr( $self->{incr_text}, $self->{incr_c} ); |
|
9389 |
$self->{incr_p} = 0; |
|
9390 |
} |
|
9391 |
|
|
9392 |
|
|
9393 |
sub incr_reset { |
|
9394 |
my $self = shift; |
|
9395 |
$self->{incr_text} = undef; |
|
9396 |
$self->{incr_p} = 0; |
|
9397 |
$self->{incr_mode} = 0; |
|
9398 |
$self->{incr_nest} = 0; |
|
9399 |
$self->{incr_parsing} = 0; |
|
9400 |
} |
|
9401 |
|
|
9402 |
############################### |
|
9403 |
|
|
9404 |
|
|
9405 |
1; |
|
9406 |
__END__ |
|
9407 |
=pod |
|
9408 |
|
|
9409 |
JSON_PP |
|
9410 | ||
9411 |
$fatpacked{"JSON/PP/Boolean.pm"} = <<'JSON_PP_BOOLEAN'; |
|
9412 |
use JSON::PP (); |
|
9413 |
use strict; |
|
9414 |
|
|
9415 |
1; |
|
9416 |
|
|
9417 |
JSON_PP_BOOLEAN |
|
9418 | ||
9419 |
$fatpacked{"Module/CPANfile.pm"} = <<'MODULE_CPANFILE'; |
|
9420 |
package Module::CPANfile; |
|
9421 |
use strict; |
|
9422 |
use warnings; |
|
9423 |
use Cwd; |
|
9424 |
|
|
9425 |
our $VERSION = '0.9010'; |
|
9426 |
|
|
9427 |
sub new { |
|
9428 |
my($class, $file) = @_; |
|
9429 |
bless {}, $class; |
|
9430 |
} |
|
9431 |
|
|
9432 |
sub load { |
|
9433 |
my($proto, $file) = @_; |
|
9434 |
my $self = ref $proto ? $proto : $proto->new; |
|
9435 |
$self->{file} = $file || "cpanfile"; |
|
9436 |
$self->parse; |
|
9437 |
$self; |
|
9438 |
} |
|
9439 |
|
|
9440 |
sub parse { |
|
9441 |
my $self = shift; |
|
9442 |
|
|
9443 |
my $file = Cwd::abs_path($self->{file}); |
|
9444 |
$self->{result} = Module::CPANfile::Environment::parse($file) or die $@; |
|
9445 |
} |
|
9446 |
|
|
9447 |
sub prereqs { shift->prereq } |
|
9448 |
|
|
9449 |
sub prereq { |
|
9450 |
my $self = shift; |
|
9451 |
require CPAN::Meta::Prereqs; |
|
9452 |
CPAN::Meta::Prereqs->new($self->prereq_specs); |
|
9453 |
} |
|
9454 |
|
|
9455 |
sub prereq_specs { |
|
9456 |
my $self = shift; |
|
9457 |
$self->{result}{spec}; |
|
9458 |
} |
|
9459 |
|
|
9460 |
sub merge_meta { |
|
9461 |
my($self, $file, $version) = @_; |
|
9462 |
|
|
9463 |
require CPAN::Meta; |
|
9464 |
|
|
9465 |
$version ||= $file =~ /\.yml$/ ? '1.4' : '2'; |
|
9466 |
|
|
9467 |
my $prereq = $self->prereqs; |
|
9468 |
|
|
9469 |
my $meta = CPAN::Meta->load_file($file); |
|
9470 |
my $prereqs_hash = $prereq->with_merged_prereqs($meta->effective_prereqs)->as_string_hash; |
|
9471 |
my $struct = { %{$meta->as_struct}, prereqs => $prereqs_hash }; |
|
9472 |
|
|
9473 |
CPAN::Meta->new($struct)->save($file, { version => $version }); |
|
9474 |
} |
|
9475 |
|
|
9476 |
package Module::CPANfile::Environment; |
|
9477 |
use strict; |
|
9478 |
|
|
9479 |
my @bindings = qw( |
|
9480 |
on requires recommends suggests conflicts |
|
9481 |
osname perl |
|
9482 |
configure_requires build_requires test_requires author_requires |
|
9483 |
); |
|
9484 |
|
|
9485 |
my $file_id = 1; |
|
9486 |
|
|
9487 |
sub import { |
|
9488 |
my($class, $result_ref) = @_; |
|
9489 |
my $pkg = caller; |
|
9490 |
|
|
9491 |
$$result_ref = Module::CPANfile::Result->new; |
|
9492 |
for my $binding (@bindings) { |
|
9493 |
no strict 'refs'; |
|
9494 |
*{"$pkg\::$binding"} = sub { $$result_ref->$binding(@_) }; |
|
9495 |
} |
|
9496 |
} |
|
9497 |
|
|
9498 |
sub parse { |
|
9499 |
my $file = shift; |
|
9500 |
|
|
9501 |
my $code = do { |
|
9502 |
open my $fh, "<", $file or die "$file: $!"; |
|
9503 |
join '', <$fh>; |
|
9504 |
}; |
|
9505 |
|
|
9506 |
my($res, $err); |
|
9507 |
|
|
9508 |
{ |
|
9509 |
local $@; |
|
9510 |
$res = eval sprintf <<EVAL, $file_id++; |
|
9511 |
package Module::CPANfile::Sandbox%d; |
|
9512 |
no warnings; |
|
9513 |
my \$_result; |
|
9514 |
BEGIN { import Module::CPANfile::Environment \\\$_result }; |
|
9515 |
|
|
9516 |
$code; |
|
9517 |
|
|
9518 |
\$_result; |
|
9519 |
EVAL |
|
9520 |
$err = $@; |
|
9521 |
} |
|
9522 |
|
|
9523 |
if ($err) { die "Parsing $file failed: $err" }; |
|
9524 |
|
|
9525 |
return $res; |
|
9526 |
} |
|
9527 |
|
|
9528 |
package Module::CPANfile::Result; |
|
9529 |
use strict; |
|
9530 |
|
|
9531 |
sub new { |
|
9532 |
bless { |
|
9533 |
phase => 'runtime', # default phase |
|
9534 |
spec => {}, |
|
9535 |
}, shift; |
|
9536 |
} |
|
9537 |
|
|
9538 |
sub on { |
|
9539 |
my($self, $phase, $code) = @_; |
|
9540 |
local $self->{phase} = $phase; |
|
9541 |
$code->() |
|
9542 |
} |
|
9543 |
|
|
9544 |
sub osname { die "TODO" } |
|
9545 |
sub perl { die "TODO" } |
|
9546 |
|
|
9547 |
sub requires { |
|
9548 |
my($self, $module, $requirement) = @_; |
|
9549 |
$self->{spec}{$self->{phase}}{requires}{$module} = $requirement || 0; |
|
9550 |
} |
|
9551 |
|
|
9552 |
sub recommends { |
|
9553 |
my($self, $module, $requirement) = @_; |
|
9554 |
$self->{spec}->{$self->{phase}}{recommends}{$module} = $requirement || 0; |
|
9555 |
} |
|
9556 |
|
|
9557 |
sub suggests { |
|
9558 |
my($self, $module, $requirement) = @_; |
|
9559 |
$self->{spec}->{$self->{phase}}{suggests}{$module} = $requirement || 0; |
|
9560 |
} |
|
9561 |
|
|
9562 |
sub conflicts { |
|
9563 |
my($self, $module, $requirement) = @_; |
|
9564 |
$self->{spec}->{$self->{phase}}{conflicts}{$module} = $requirement || 0; |
|
9565 |
} |
|
9566 |
|
|
9567 |
# Module::Install compatible shortcuts |
|
9568 |
|
|
9569 |
sub configure_requires { |
|
9570 |
my($self, @args) = @_; |
|
9571 |
$self->on(configure => sub { $self->requires(@args) }); |
|
9572 |
} |
|
9573 |
|
|
9574 |
sub build_requires { |
|
9575 |
my($self, @args) = @_; |
|
9576 |
$self->on(build => sub { $self->requires(@args) }); |
|
9577 |
} |
|
9578 |
|
|
9579 |
sub test_requires { |
|
9580 |
my($self, @args) = @_; |
|
9581 |
$self->on(test => sub { $self->requires(@args) }); |
|
9582 |
} |
|
9583 |
|
|
9584 |
sub author_requires { |
|
9585 |
my($self, @args) = @_; |
|
9586 |
$self->on(develop => sub { $self->requires(@args) }); |
|
9587 |
} |
|
9588 |
|
|
9589 |
package Module::CPANfile; |
|
9590 |
|
|
9591 |
1; |
|
9592 |
|
|
9593 |
__END__ |
|
9594 |
|
|
9595 |
|
|
9596 |
MODULE_CPANFILE |
|
9597 | ||
9598 |
$fatpacked{"Module/Metadata.pm"} = <<'MODULE_METADATA'; |
|
9599 |
# -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*- |
|
9600 |
# vim:ts=8:sw=2:et:sta:sts=2 |
|
9601 |
package Module::Metadata; |
|
9602 |
|
|
9603 |
# Adapted from Perl-licensed code originally distributed with |
|
9604 |
# Module-Build by Ken Williams |
|
9605 |
|
|
9606 |
# This module provides routines to gather information about |
|
9607 |
# perl modules (assuming this may be expanded in the distant |
|
9608 |
# parrot future to look at other types of modules). |
|
9609 |
|
|
9610 |
use strict; |
|
9611 |
use vars qw($VERSION); |
|
9612 |
$VERSION = '1.000011'; |
|
9613 |
$VERSION = eval $VERSION; |
|
9614 |
|
|
9615 |
use Carp qw/croak/; |
|
9616 |
use File::Spec; |
|
9617 |
use IO::File; |
|
9618 |
use version 0.87; |
|
9619 |
BEGIN { |
|
9620 |
if ($INC{'Log/Contextual.pm'}) { |
|
9621 |
Log::Contextual->import('log_info'); |
|
9622 |
} else { |
|
9623 |
*log_info = sub (&) { warn $_[0]->() }; |
|
9624 |
} |
|
9625 |
} |
|
9626 |
use File::Find qw(find); |
|
9627 |
|
|
9628 |
my $V_NUM_REGEXP = qr{v?[0-9._]+}; # crudely, a v-string or decimal |
|
9629 |
|
|
9630 |
my $PKG_REGEXP = qr{ # match a package declaration |
|
9631 |
^[\s\{;]* # intro chars on a line |
|
9632 |
package # the word 'package' |
|
9633 |
\s+ # whitespace |
|
9634 |
([\w:]+) # a package name |
|
9635 |
\s* # optional whitespace |
|
9636 |
($V_NUM_REGEXP)? # optional version number |
|
9637 |
\s* # optional whitesapce |
|
9638 |
[;\{] # semicolon line terminator or block start (since 5.16) |
|
9639 |
}x; |
|
9640 |
|
|
9641 |
my $VARNAME_REGEXP = qr{ # match fully-qualified VERSION name |
|
9642 |
([\$*]) # sigil - $ or * |
|
9643 |
( |
|
9644 |
( # optional leading package name |
|
9645 |
(?:::|\')? # possibly starting like just :: (� la $::VERSION) |
|
9646 |
(?:\w+(?:::|\'))* # Foo::Bar:: ... |
|
9647 |
)? |
|
9648 |
VERSION |
|
9649 |
)\b |
|
9650 |
}x; |
|
9651 |
|
|
9652 |
my $VERS_REGEXP = qr{ # match a VERSION definition |
|
9653 |
(?: |
|
9654 |
\(\s*$VARNAME_REGEXP\s*\) # with parens |
|
9655 |
| |
|
9656 |
$VARNAME_REGEXP # without parens |
|
9657 |
) |
|
9658 |
\s* |
|
9659 |
=[^=~] # = but not ==, nor =~ |
|
9660 |
}x; |
|
9661 |
|
|
9662 |
sub new_from_file { |
|
9663 |
my $class = shift; |
|
9664 |
my $filename = File::Spec->rel2abs( shift ); |
|
9665 |
|
|
9666 |
return undef unless defined( $filename ) && -f $filename; |
|
9667 |
return $class->_init(undef, $filename, @_); |
|
9668 |
} |
|
9669 |
|
|
9670 |
sub new_from_handle { |
|
9671 |
my $class = shift; |
|
9672 |
my $handle = shift; |
|
9673 |
my $filename = shift; |
|
9674 |
return undef unless defined($handle) && defined($filename); |
|
9675 |
$filename = File::Spec->rel2abs( $filename ); |
|
9676 |
|
|
9677 |
return $class->_init(undef, $filename, @_, handle => $handle); |
|
9678 |
|
|
9679 |
} |
|
9680 |
|
|
9681 |
|
|
9682 |
sub new_from_module { |
|
9683 |
my $class = shift; |
|
9684 |
my $module = shift; |
|
9685 |
my %props = @_; |
|
9686 |
|
|
9687 |
$props{inc} ||= \@INC; |
|
9688 |
my $filename = $class->find_module_by_name( $module, $props{inc} ); |
|
9689 |
return undef unless defined( $filename ) && -f $filename; |
|
9690 |
return $class->_init($module, $filename, %props); |
|
9691 |
} |
|
9692 |
|
|
9693 |
{ |
|
9694 |
|
|
9695 |
my $compare_versions = sub { |
|
9696 |
my ($v1, $op, $v2) = @_; |
|
9697 |
$v1 = version->new($v1) |
|
9698 |
unless UNIVERSAL::isa($v1,'version'); |
|
9699 |
|
|
9700 |
my $eval_str = "\$v1 $op \$v2"; |
|
9701 |
my $result = eval $eval_str; |
|
9702 |
log_info { "error comparing versions: '$eval_str' $@" } if $@; |
|
9703 |
|
|
9704 |
return $result; |
|
9705 |
}; |
|
9706 |
|
|
9707 |
my $normalize_version = sub { |
|
9708 |
my ($version) = @_; |
|
9709 |
if ( $version =~ /[=<>!,]/ ) { # logic, not just version |
|
9710 |
# take as is without modification |
|
9711 |
} |
|
9712 |
elsif ( ref $version eq 'version' ) { # version objects |
|
9713 |
$version = $version->is_qv ? $version->normal : $version->stringify; |
|
9714 |
} |
|
9715 |
elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots |
|
9716 |
# normalize string tuples without "v": "1.2.3" -> "v1.2.3" |
|
9717 |
$version = "v$version"; |
|
9718 |
} |
|
9719 |
else { |
|
9720 |
# leave alone |
|
9721 |
} |
|
9722 |
return $version; |
|
9723 |
}; |
|
9724 |
|
|
9725 |
# separate out some of the conflict resolution logic |
|
9726 |
|
|
9727 |
my $resolve_module_versions = sub { |
|
9728 |
my $packages = shift; |
|
9729 |
|
|
9730 |
my( $file, $version ); |
|
9731 |
my $err = ''; |
|
9732 |
foreach my $p ( @$packages ) { |
|
9733 |
if ( defined( $p->{version} ) ) { |
|
9734 |
if ( defined( $version ) ) { |
|
9735 |
if ( $compare_versions->( $version, '!=', $p->{version} ) ) { |
|
9736 |
$err .= " $p->{file} ($p->{version})\n"; |
|
9737 |
} else { |
|
9738 |
# same version declared multiple times, ignore |
|
9739 |
} |
|
9740 |
} else { |
|
9741 |
$file = $p->{file}; |
|
9742 |
$version = $p->{version}; |
|
9743 |
} |
|
9744 |
} |
|
9745 |
$file ||= $p->{file} if defined( $p->{file} ); |
|
9746 |
} |
|
9747 |
|
|
9748 |
if ( $err ) { |
|
9749 |
$err = " $file ($version)\n" . $err; |
|
9750 |
} |
|
9751 |
|
|
9752 |
my %result = ( |
|
9753 |
file => $file, |
|
9754 |
version => $version, |
|
9755 |
err => $err |
|
9756 |
); |
|
9757 |
|
|
9758 |
return \%result; |
|
9759 |
}; |
|
9760 |
|
|
9761 |
sub provides { |
|
9762 |
my $class = shift; |
|
9763 |
|
|
9764 |
croak "provides() requires key/value pairs \n" if @_ % 2; |
|
9765 |
my %args = @_; |
|
9766 |
|
|
9767 |
croak "provides() takes only one of 'dir' or 'files'\n" |
|
9768 |
if $args{dir} && $args{files}; |
|
9769 |
|
|
9770 |
croak "provides() requires a 'version' argument" |
|
9771 |
unless defined $args{version}; |
|
9772 |
|
|
9773 |
croak "provides() does not support version '$args{version}' metadata" |
|
9774 |
unless grep { $args{version} eq $_ } qw/1.4 2/; |
|
9775 |
|
|
9776 |
$args{prefix} = 'lib' unless defined $args{prefix}; |
|
9777 |
|
|
9778 |
my $p; |
|
9779 |
if ( $args{dir} ) { |
|
9780 |
$p = $class->package_versions_from_directory($args{dir}); |
|
9781 |
} |
|
9782 |
else { |
|
9783 |
croak "provides() requires 'files' to be an array reference\n" |
|
9784 |
unless ref $args{files} eq 'ARRAY'; |
|
9785 |
$p = $class->package_versions_from_directory($args{files}); |
|
9786 |
} |
|
9787 |
|
|
9788 |
# Now, fix up files with prefix |
|
9789 |
if ( length $args{prefix} ) { # check in case disabled with q{} |
|
9790 |
$args{prefix} =~ s{/$}{}; |
|
9791 |
for my $v ( values %$p ) { |
|
9792 |
$v->{file} = "$args{prefix}/$v->{file}"; |
|
9793 |
} |
|
9794 |
} |
|
9795 |
|
|
9796 |
return $p |
|
9797 |
} |
|
9798 |
|
|
9799 |
sub package_versions_from_directory { |
|
9800 |
my ( $class, $dir, $files ) = @_; |
|
9801 |
|
|
9802 |
my @files; |
|
9803 |
|
|
9804 |
if ( $files ) { |
|
9805 |
@files = @$files; |
|
9806 |
} else { |
|
9807 |
find( { |
|
9808 |
wanted => sub { |
|
9809 |
push @files, $_ if -f $_ && /\.pm$/; |
|
9810 |
}, |
|
9811 |
no_chdir => 1, |
|
9812 |
}, $dir ); |
|
9813 |
} |
|
9814 |
|
|
9815 |
# First, we enumerate all packages & versions, |
|
9816 |
# separating into primary & alternative candidates |
|
9817 |
my( %prime, %alt ); |
|
9818 |
foreach my $file (@files) { |
|
9819 |
my $mapped_filename = File::Spec::Unix->abs2rel( $file, $dir ); |
|
9820 |
my @path = split( /\//, $mapped_filename ); |
|
9821 |
(my $prime_package = join( '::', @path )) =~ s/\.pm$//; |
|
9822 |
|
|
9823 |
my $pm_info = $class->new_from_file( $file ); |
|
9824 |
|
|
9825 |
foreach my $package ( $pm_info->packages_inside ) { |
|
9826 |
next if $package eq 'main'; # main can appear numerous times, ignore |
|
9827 |
next if $package eq 'DB'; # special debugging package, ignore |
|
9828 |
next if grep /^_/, split( /::/, $package ); # private package, ignore |
|
9829 |
|
|
9830 |
my $version = $pm_info->version( $package ); |
|
9831 |
|
|
9832 |
$prime_package = $package if lc($prime_package) eq lc($package); |
|
9833 |
if ( $package eq $prime_package ) { |
|
9834 |
if ( exists( $prime{$package} ) ) { |
|
9835 |
croak "Unexpected conflict in '$package'; multiple versions found.\n"; |
|
9836 |
} else { |
|
9837 |
$mapped_filename = "$package.pm" if lc("$package.pm") eq lc($mapped_filename); |
|
9838 |
$prime{$package}{file} = $mapped_filename; |
|
9839 |
$prime{$package}{version} = $version if defined( $version ); |
|
9840 |
} |
|
9841 |
} else { |
|
9842 |
push( @{$alt{$package}}, { |
|
9843 |
file => $mapped_filename, |
|
9844 |
version => $version, |
|
9845 |
} ); |
|
9846 |
} |
|
9847 |
} |
|
9848 |
} |
|
9849 |
|
|
9850 |
# Then we iterate over all the packages found above, identifying conflicts |
|
9851 |
# and selecting the "best" candidate for recording the file & version |
|
9852 |
# for each package. |
|
9853 |
foreach my $package ( keys( %alt ) ) { |
|
9854 |
my $result = $resolve_module_versions->( $alt{$package} ); |
|
9855 |
|
|
9856 |
if ( exists( $prime{$package} ) ) { # primary package selected |
|
9857 |
|
|
9858 |
if ( $result->{err} ) { |
|
9859 |
# Use the selected primary package, but there are conflicting |
|
9860 |
# errors among multiple alternative packages that need to be |
|
9861 |
# reported |
|
9862 |
log_info { |
|
9863 |
"Found conflicting versions for package '$package'\n" . |
|
9864 |
" $prime{$package}{file} ($prime{$package}{version})\n" . |
|
9865 |
$result->{err} |
|
9866 |
}; |
|
9867 |
|
|
9868 |
} elsif ( defined( $result->{version} ) ) { |
|
9869 |
# There is a primary package selected, and exactly one |
|
9870 |
# alternative package |
|
9871 |
|
|
9872 |
if ( exists( $prime{$package}{version} ) && |
|
9873 |
defined( $prime{$package}{version} ) ) { |
|
9874 |
# Unless the version of the primary package agrees with the |
|
9875 |
# version of the alternative package, report a conflict |
|
9876 |
if ( $compare_versions->( |
|
9877 |
$prime{$package}{version}, '!=', $result->{version} |
|
9878 |
) |
|
9879 |
) { |
|
9880 |
|
|
9881 |
log_info { |
|
9882 |
"Found conflicting versions for package '$package'\n" . |
|
9883 |
" $prime{$package}{file} ($prime{$package}{version})\n" . |
|
9884 |
" $result->{file} ($result->{version})\n" |
|
9885 |
}; |
|
9886 |
} |
|
9887 |
|
|
9888 |
} else { |
|
9889 |
# The prime package selected has no version so, we choose to |
|
9890 |
# use any alternative package that does have a version |
|
9891 |
$prime{$package}{file} = $result->{file}; |
|
9892 |
$prime{$package}{version} = $result->{version}; |
|
9893 |
} |
|
9894 |
|
|
9895 |
} else { |
|
9896 |
# no alt package found with a version, but we have a prime |
|
9897 |
# package so we use it whether it has a version or not |
|
9898 |
} |
|
9899 |
|
|
9900 |
} else { # No primary package was selected, use the best alternative |
|
9901 |
|
|
9902 |
if ( $result->{err} ) { |
|
9903 |
log_info { |
|
9904 |
"Found conflicting versions for package '$package'\n" . |
|
9905 |
$result->{err} |
|
9906 |
}; |
|
9907 |
} |
|
9908 |
|
|
9909 |
# Despite possible conflicting versions, we choose to record |
|
9910 |
# something rather than nothing |
|
9911 |
$prime{$package}{file} = $result->{file}; |
|
9912 |
$prime{$package}{version} = $result->{version} |
|
9913 |
if defined( $result->{version} ); |
|
9914 |
} |
|
9915 |
} |
|
9916 |
|
|
9917 |
# Normalize versions. Can't use exists() here because of bug in YAML::Node. |
|
9918 |
# XXX "bug in YAML::Node" comment seems irrelvant -- dagolden, 2009-05-18 |
|
9919 |
for (grep defined $_->{version}, values %prime) { |
|
9920 |
$_->{version} = $normalize_version->( $_->{version} ); |
|
9921 |
} |
|
9922 |
|
|
9923 |
return \%prime; |
|
9924 |
} |
|
9925 |
} |
|
9926 |
|
|
9927 |
|
|
9928 |
sub _init { |
|
9929 |
my $class = shift; |
|
9930 |
my $module = shift; |
|
9931 |
my $filename = shift; |
|
9932 |
my %props = @_; |
|
9933 |
|
|
9934 |
my $handle = delete $props{handle}; |
|
9935 |
my( %valid_props, @valid_props ); |
|
9936 |
@valid_props = qw( collect_pod inc ); |
|
9937 |
@valid_props{@valid_props} = delete( @props{@valid_props} ); |
|
9938 |
warn "Unknown properties: @{[keys %props]}\n" if scalar( %props ); |
|
9939 |
|
|
9940 |
my %data = ( |
|
9941 |
module => $module, |
|
9942 |
filename => $filename, |
|
9943 |
version => undef, |
|
9944 |
packages => [], |
|
9945 |
versions => {}, |
|
9946 |
pod => {}, |
|
9947 |
pod_headings => [], |
|
9948 |
collect_pod => 0, |
|
9949 |
|
|
9950 |
%valid_props, |
|
9951 |
); |
|
9952 |
|
|
9953 |
my $self = bless(\%data, $class); |
|
9954 |
|
|
9955 |
if ( $handle ) { |
|
9956 |
$self->_parse_fh($handle); |
|
9957 |
} |
|
9958 |
else { |
|
9959 |
$self->_parse_file(); |
|
9960 |
} |
|
9961 |
|
|
9962 |
unless($self->{module} and length($self->{module})) { |
|
9963 |
my ($v, $d, $f) = File::Spec->splitpath($self->{filename}); |
|
9964 |
if($f =~ /\.pm$/) { |
|
9965 |
$f =~ s/\..+$//; |
|
9966 |
my @candidates = grep /$f$/, @{$self->{packages}}; |
|
9967 |
$self->{module} = shift(@candidates); # punt |
|
9968 |
} |
|
9969 |
else { |
|
9970 |
if(grep /main/, @{$self->{packages}}) { |
|
9971 |
$self->{module} = 'main'; |
|
9972 |
} |
|
9973 |
else { |
|
9974 |
$self->{module} = $self->{packages}[0] || ''; |
|
9975 |
} |
|
9976 |
} |
|
9977 |
} |
|
9978 |
|
|
9979 |
$self->{version} = $self->{versions}{$self->{module}} |
|
9980 |
if defined( $self->{module} ); |
|
9981 |
|
|
9982 |
return $self; |
|
9983 |
} |
|
9984 |
|
|
9985 |
# class method |
|
9986 |
sub _do_find_module { |
|
9987 |
my $class = shift; |
|
9988 |
my $module = shift || croak 'find_module_by_name() requires a package name'; |
|
9989 |
my $dirs = shift || \@INC; |
|
9990 |
|
|
9991 |
my $file = File::Spec->catfile(split( /::/, $module)); |
|
9992 |
foreach my $dir ( @$dirs ) { |
|
9993 |
my $testfile = File::Spec->catfile($dir, $file); |
|
9994 |
return [ File::Spec->rel2abs( $testfile ), $dir ] |
|
9995 |
if -e $testfile and !-d _; # For stuff like ExtUtils::xsubpp |
|
9996 |
return [ File::Spec->rel2abs( "$testfile.pm" ), $dir ] |
|
9997 |
if -e "$testfile.pm"; |
|
9998 |
} |
|
9999 |
return; |
|
10000 |
} |
|
10001 |
|
|
10002 |
# class method |
|
10003 |
sub find_module_by_name { |
|
10004 |
my $found = shift()->_do_find_module(@_) or return; |
|
10005 |
return $found->[0]; |
|
10006 |
} |
|
10007 |
|
|
10008 |
# class method |
|
10009 |
sub find_module_dir_by_name { |
|
10010 |
my $found = shift()->_do_find_module(@_) or return; |
|
10011 |
return $found->[1]; |
|
10012 |
} |
|
10013 |
|
|
10014 |
|
|
10015 |
# given a line of perl code, attempt to parse it if it looks like a |
|
10016 |
# $VERSION assignment, returning sigil, full name, & package name |
|
10017 |
sub _parse_version_expression { |
|
10018 |
my $self = shift; |
|
10019 |
my $line = shift; |
|
10020 |
|
|
10021 |
my( $sig, $var, $pkg ); |
|
10022 |
if ( $line =~ /$VERS_REGEXP/o ) { |
|
10023 |
( $sig, $var, $pkg ) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 ); |
|
10024 |
if ( $pkg ) { |
|
10025 |
$pkg = ($pkg eq '::') ? 'main' : $pkg; |
|
10026 |
$pkg =~ s/::$//; |
|
10027 |
} |
|
10028 |
} |
|
10029 |
|
|
10030 |
return ( $sig, $var, $pkg ); |
|
10031 |
} |
|
10032 |
|
|
10033 |
sub _parse_file { |
|
10034 |
my $self = shift; |
|
10035 |
|
|
10036 |
my $filename = $self->{filename}; |
|
10037 |
my $fh = IO::File->new( $filename ) |
|
10038 |
or croak( "Can't open '$filename': $!" ); |
|
10039 |
|
|
10040 |
$self->_handle_bom($fh, $filename); |
|
10041 |
|
|
10042 |
$self->_parse_fh($fh); |
|
10043 |
} |
|
10044 |
|
|
10045 |
# Look for a UTF-8/UTF-16BE/UTF-16LE BOM at the beginning of the stream. |
|
10046 |
# If there's one, then skip it and set the :encoding layer appropriately. |
|
10047 |
sub _handle_bom { |
|
10048 |
my ($self, $fh, $filename) = @_; |
|
10049 |
|
|
10050 |
my $pos = $fh->getpos; |
|
10051 |
return unless defined $pos; |
|
10052 |
|
|
10053 |
my $buf = ' ' x 2; |
|
10054 |
my $count = $fh->read( $buf, length $buf ); |
|
10055 |
return unless defined $count and $count >= 2; |
|
10056 |
|
|
10057 |
my $encoding; |
|
10058 |
if ( $buf eq "\x{FE}\x{FF}" ) { |
|
10059 |
$encoding = 'UTF-16BE'; |
|
10060 |
} elsif ( $buf eq "\x{FF}\x{FE}" ) { |
|
10061 |
$encoding = 'UTF-16LE'; |
|
10062 |
} elsif ( $buf eq "\x{EF}\x{BB}" ) { |
|
10063 |
$buf = ' '; |
|
10064 |
$count = $fh->read( $buf, length $buf ); |
|
10065 |
if ( defined $count and $count >= 1 and $buf eq "\x{BF}" ) { |
|
10066 |
$encoding = 'UTF-8'; |
|
10067 |
} |
|
10068 |
} |
|
10069 |
|
|
10070 |
if ( defined $encoding ) { |
|
10071 |
if ( "$]" >= 5.008 ) { |
|
10072 |
# $fh->binmode requires perl 5.10 |
|
10073 |
binmode( $fh, ":encoding($encoding)" ); |
|
10074 |
} |
|
10075 |
} else { |
|
10076 |
$fh->setpos($pos) |
|
10077 |
or croak( sprintf "Can't reset position to the top of '$filename'" ); |
|
10078 |
} |
|
10079 |
|
|
10080 |
return $encoding; |
|
10081 |
} |
|
10082 |
|
|
10083 |
sub _parse_fh { |
|
10084 |
my ($self, $fh) = @_; |
|
10085 |
|
|
10086 |
my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 ); |
|
10087 |
my( @pkgs, %vers, %pod, @pod ); |
|
10088 |
my $pkg = 'main'; |
|
10089 |
my $pod_sect = ''; |
|
10090 |
my $pod_data = ''; |
|
10091 |
|
|
10092 |
while (defined( my $line = <$fh> )) { |
|
10093 |
my $line_num = $.; |
|
10094 |
|
|
10095 |
chomp( $line ); |
|
10096 |
|
|
10097 |
# From toke.c : any line that begins by "=X", where X is an alphabetic |
|
10098 |
# character, introduces a POD segment. |
|
10099 |
my $is_cut; |
|
10100 |
if ( $line =~ /^=([a-zA-Z].*)/ ) { |
|
10101 |
my $cmd = $1; |
|
10102 |
# Then it goes back to Perl code for "=cutX" where X is a non-alphabetic |
|
10103 |
# character (which includes the newline, but here we chomped it away). |
|
10104 |
$is_cut = $cmd =~ /^cut(?:[^a-zA-Z]|$)/; |
|
10105 |
$in_pod = !$is_cut; |
|
10106 |
} |
|
10107 |
|
|
10108 |
if ( $in_pod ) { |
|
10109 |
|
|
10110 |
if ( $line =~ /^=head[1-4]\s+(.+)\s*$/ ) { |
|
10111 |
push( @pod, $1 ); |
|
10112 |
if ( $self->{collect_pod} && length( $pod_data ) ) { |
|
10113 |
$pod{$pod_sect} = $pod_data; |
|
10114 |
$pod_data = ''; |
|
10115 |
} |
|
10116 |
$pod_sect = $1; |
|
10117 |
|
|
10118 |
} elsif ( $self->{collect_pod} ) { |
|
10119 |
$pod_data .= "$line\n"; |
|
10120 |
|
|
10121 |
} |
|
10122 |
|
|
10123 |
} elsif ( $is_cut ) { |
|
10124 |
|
|
10125 |
if ( $self->{collect_pod} && length( $pod_data ) ) { |
|
10126 |
$pod{$pod_sect} = $pod_data; |
|
10127 |
$pod_data = ''; |
|
10128 |
} |
|
10129 |
$pod_sect = ''; |
|
10130 |
|
|
10131 |
} else { |
|
10132 |
|
|
10133 |
# Skip comments in code |
|
10134 |
next if $line =~ /^\s*#/; |
|
10135 |
|
|
10136 |
# Would be nice if we could also check $in_string or something too |
|
10137 |
last if $line =~ /^__(?:DATA|END)__$/; |
|
10138 |
|
|
10139 |
# parse $line to see if it's a $VERSION declaration |
|
10140 |
my( $vers_sig, $vers_fullname, $vers_pkg ) = |
|
10141 |
($line =~ /VERSION/) |
|
10142 |
? $self->_parse_version_expression( $line ) |
|
10143 |
: (); |
|
10144 |
|
|
10145 |
if ( $line =~ /$PKG_REGEXP/o ) { |
|
10146 |
$pkg = $1; |
|
10147 |
push( @pkgs, $pkg ) unless grep( $pkg eq $_, @pkgs ); |
|
10148 |
$vers{$pkg} = $2 unless exists( $vers{$pkg} ); |
|
10149 |
$need_vers = defined $2 ? 0 : 1; |
|
10150 |
|
|
10151 |
# VERSION defined with full package spec, i.e. $Module::VERSION |
|
10152 |
} elsif ( $vers_fullname && $vers_pkg ) { |
|
10153 |
push( @pkgs, $vers_pkg ) unless grep( $vers_pkg eq $_, @pkgs ); |
|
10154 |
$need_vers = 0 if $vers_pkg eq $pkg; |
|
10155 |
|
|
10156 |
unless ( defined $vers{$vers_pkg} && length $vers{$vers_pkg} ) { |
|
10157 |
$vers{$vers_pkg} = |
|
10158 |
$self->_evaluate_version_line( $vers_sig, $vers_fullname, $line ); |
|
10159 |
} |
|
10160 |
|
|
10161 |
# first non-comment line in undeclared package main is VERSION |
|
10162 |
} elsif ( !exists($vers{main}) && $pkg eq 'main' && $vers_fullname ) { |
|
10163 |
$need_vers = 0; |
|
10164 |
my $v = |
|
10165 |
$self->_evaluate_version_line( $vers_sig, $vers_fullname, $line ); |
|
10166 |
$vers{$pkg} = $v; |
|
10167 |
push( @pkgs, 'main' ); |
|
10168 |
|
|
10169 |
# first non-comment line in undeclared package defines package main |
|
10170 |
} elsif ( !exists($vers{main}) && $pkg eq 'main' && $line =~ /\w+/ ) { |
|
10171 |
$need_vers = 1; |
|
10172 |
$vers{main} = ''; |
|
10173 |
push( @pkgs, 'main' ); |
|
10174 |
|
|
10175 |
# only keep if this is the first $VERSION seen |
|
10176 |
} elsif ( $vers_fullname && $need_vers ) { |
|
10177 |
$need_vers = 0; |
|
10178 |
my $v = |
|
10179 |
$self->_evaluate_version_line( $vers_sig, $vers_fullname, $line ); |
|
10180 |
|
|
10181 |
|
|
10182 |
unless ( defined $vers{$pkg} && length $vers{$pkg} ) { |
|
10183 |
$vers{$pkg} = $v; |
|
10184 |
} |
|
10185 |
|
|
10186 |
} |
|
10187 |
|
|
10188 |
} |
|
10189 |
|
|
10190 |
} |
|
10191 |
|
|
10192 |
if ( $self->{collect_pod} && length($pod_data) ) { |
|
10193 |
$pod{$pod_sect} = $pod_data; |
|
10194 |
} |
|
10195 |
|
|
10196 |
$self->{versions} = \%vers; |
|
10197 |
$self->{packages} = \@pkgs; |
|
10198 |
$self->{pod} = \%pod; |
|
10199 |
$self->{pod_headings} = \@pod; |
|
10200 |
} |
|
10201 |
|
|
10202 |
{ |
|
10203 |
my $pn = 0; |
|
10204 |
sub _evaluate_version_line { |
|
10205 |
my $self = shift; |
|
10206 |
my( $sigil, $var, $line ) = @_; |
|
10207 |
|
|
10208 |
# Some of this code came from the ExtUtils:: hierarchy. |
|
10209 |
|
|
10210 |
# We compile into $vsub because 'use version' would cause |
|
10211 |
# compiletime/runtime issues with local() |
|
10212 |
my $vsub; |
|
10213 |
$pn++; # everybody gets their own package |
|
10214 |
my $eval = qq{BEGIN { q# Hide from _packages_inside() |
|
10215 |
#; package Module::Metadata::_version::p$pn; |
|
10216 |
use version; |
|
10217 |
no strict; |
|
10218 |
|
|
10219 |
\$vsub = sub { |
|
10220 |
local $sigil$var; |
|
10221 |
\$$var=undef; |
|
10222 |
$line; |
|
10223 |
\$$var |
|
10224 |
}; |
|
10225 |
}}; |
|
10226 |
|
|
10227 |
local $^W; |
|
10228 |
# Try to get the $VERSION |
|
10229 |
eval $eval; |
|
10230 |
# some modules say $VERSION = $Foo::Bar::VERSION, but Foo::Bar isn't |
|
10231 |
# installed, so we need to hunt in ./lib for it |
|
10232 |
if ( $@ =~ /Can't locate/ && -d 'lib' ) { |
|
10233 |
local @INC = ('lib',@INC); |
|
10234 |
eval $eval; |
|
10235 |
} |
|
10236 |
warn "Error evaling version line '$eval' in $self->{filename}: $@\n" |
|
10237 |
if $@; |
|
10238 |
(ref($vsub) eq 'CODE') or |
|
10239 |
croak "failed to build version sub for $self->{filename}"; |
|
10240 |
my $result = eval { $vsub->() }; |
|
10241 |
croak "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n" |
|
10242 |
if $@; |
|
10243 |
|
|
10244 |
# Upgrade it into a version object |
|
10245 |
my $version = eval { _dwim_version($result) }; |
|
10246 |
|
|
10247 |
croak "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n" |
|
10248 |
unless defined $version; # "0" is OK! |
|
10249 |
|
|
10250 |
return $version; |
|
10251 |
} |
|
10252 |
} |
|
10253 |
|
|
10254 |
# Try to DWIM when things fail the lax version test in obvious ways |
|
10255 |
{ |
|
10256 |
my @version_prep = ( |
|
10257 |
# Best case, it just works |
|
10258 |
sub { return shift }, |
|
10259 |
|
|
10260 |
# If we still don't have a version, try stripping any |
|
10261 |
# trailing junk that is prohibited by lax rules |
|
10262 |
sub { |
|
10263 |
my $v = shift; |
|
10264 |
$v =~ s{([0-9])[a-z-].*$}{$1}i; # 1.23-alpha or 1.23b |
|
10265 |
return $v; |
|
10266 |
}, |
|
10267 |
|
|
10268 |
# Activestate apparently creates custom versions like '1.23_45_01', which |
|
10269 |
# cause version.pm to think it's an invalid alpha. So check for that |
|
10270 |
# and strip them |
|
10271 |
sub { |
|
10272 |
my $v = shift; |
|
10273 |
my $num_dots = () = $v =~ m{(\.)}g; |
|
10274 |
my $num_unders = () = $v =~ m{(_)}g; |
|
10275 |
my $leading_v = substr($v,0,1) eq 'v'; |
|
10276 |
if ( ! $leading_v && $num_dots < 2 && $num_unders > 1 ) { |
|
10277 |
$v =~ s{_}{}g; |
|
10278 |
$num_unders = () = $v =~ m{(_)}g; |
|
10279 |
} |
|
10280 |
return $v; |
|
10281 |
}, |
|
10282 |
|
|
10283 |
# Worst case, try numifying it like we would have before version objects |
|
10284 |
sub { |
|
10285 |
my $v = shift; |
|
10286 |
no warnings 'numeric'; |
|
10287 |
return 0 + $v; |
|
10288 |
}, |
|
10289 |
|
|
10290 |
); |
|
10291 |
|
|
10292 |
sub _dwim_version { |
|
10293 |
my ($result) = shift; |
|
10294 |
|
|
10295 |
return $result if ref($result) eq 'version'; |
|
10296 |
|
|
10297 |
my ($version, $error); |
|
10298 |
for my $f (@version_prep) { |
|
10299 |
$result = $f->($result); |
|
10300 |
$version = eval { version->new($result) }; |
|
10301 |
$error ||= $@ if $@; # capture first failure |
|
10302 |
last if defined $version; |
|
10303 |
} |
|
10304 |
|
|
10305 |
croak $error unless defined $version; |
|
10306 |
|
|
10307 |
return $version; |
|
10308 |
} |
|
10309 |
} |
|
10310 |
|
|
10311 |
############################################################ |
|
10312 |
|
|
10313 |
# accessors |
|
10314 |
sub name { $_[0]->{module} } |
|
10315 |
|
|
10316 |
sub filename { $_[0]->{filename} } |
|
10317 |
sub packages_inside { @{$_[0]->{packages}} } |
|
10318 |
sub pod_inside { @{$_[0]->{pod_headings}} } |
|
10319 |
sub contains_pod { $#{$_[0]->{pod_headings}} } |
|
10320 |
|
|
10321 |
sub version { |
|
10322 |
my $self = shift; |
|
10323 |
my $mod = shift || $self->{module}; |
|
10324 |
my $vers; |
|
10325 |
if ( defined( $mod ) && length( $mod ) && |
|
10326 |
exists( $self->{versions}{$mod} ) ) { |
|
10327 |
return $self->{versions}{$mod}; |
|
10328 |
} else { |
|
10329 |
return undef; |
|
10330 |
} |
|
10331 |
} |
|
10332 |
|
|
10333 |
sub pod { |
|
10334 |
my $self = shift; |
|
10335 |
my $sect = shift; |
|
10336 |
if ( defined( $sect ) && length( $sect ) && |
|
10337 |
exists( $self->{pod}{$sect} ) ) { |
|
10338 |
return $self->{pod}{$sect}; |
|
10339 |
} else { |
|
10340 |
return undef; |
|
10341 |
} |
|
10342 |
} |
|
10343 |
|
|
10344 |
1; |
|
10345 |
|
|
10346 |
MODULE_METADATA |
|
10347 | ||
10348 |
$fatpacked{"Parse/CPAN/Meta.pm"} = <<'PARSE_CPAN_META'; |
|
10349 |
package Parse::CPAN::Meta; |
|
10350 |
|
|
10351 |
use strict; |
|
10352 |
use Carp 'croak'; |
|
10353 |
|
|
10354 |
# UTF Support? |
|
10355 |
sub HAVE_UTF8 () { $] >= 5.007003 } |
|
10356 |
sub IO_LAYER () { $] >= 5.008001 ? ":utf8" : "" } |
|
10357 |
|
|
10358 |
BEGIN { |
|
10359 |
if ( HAVE_UTF8 ) { |
|
10360 |
# The string eval helps hide this from Test::MinimumVersion |
|
10361 |
eval "require utf8;"; |
|
10362 |
die "Failed to load UTF-8 support" if $@; |
|
10363 |
} |
|
10364 |
|
|
10365 |
# Class structure |
|
10366 |
require 5.004; |
|
10367 |
require Exporter; |
|
10368 |
$Parse::CPAN::Meta::VERSION = '1.4404'; |
|
10369 |
@Parse::CPAN::Meta::ISA = qw{ Exporter }; |
|
10370 |
@Parse::CPAN::Meta::EXPORT_OK = qw{ Load LoadFile }; |
|
10371 |
} |
|
10372 |
|
|
10373 |
sub load_file { |
|
10374 |
my ($class, $filename) = @_; |
|
10375 |
|
|
10376 |
if ($filename =~ /\.ya?ml$/) { |
|
10377 |
return $class->load_yaml_string(_slurp($filename)); |
|
10378 |
} |
|
10379 |
|
|
10380 |
if ($filename =~ /\.json$/) { |
|
10381 |
return $class->load_json_string(_slurp($filename)); |
|
10382 |
} |
|
10383 |
|
|
10384 |
croak("file type cannot be determined by filename"); |
|
10385 |
} |
|
10386 |
|
|
10387 |
sub load_yaml_string { |
|
10388 |
my ($class, $string) = @_; |
|
10389 |
my $backend = $class->yaml_backend(); |
|
10390 |
my $data = eval { no strict 'refs'; &{"$backend\::Load"}($string) }; |
|
10391 |
if ( $@ ) { |
|
10392 |
croak $backend->can('errstr') ? $backend->errstr : $@ |
|
10393 |
} |
|
10394 |
return $data || {}; # in case document was valid but empty |
|
10395 |
} |
|
10396 |
|
|
10397 |
sub load_json_string { |
|
10398 |
my ($class, $string) = @_; |
|
10399 |
return $class->json_backend()->new->decode($string); |
|
10400 |
} |
|
10401 |
|
|
10402 |
sub yaml_backend { |
|
10403 |
local $Module::Load::Conditional::CHECK_INC_HASH = 1; |
|
10404 |
if (! defined $ENV{PERL_YAML_BACKEND} ) { |
|
10405 |
_can_load( 'CPAN::Meta::YAML', 0.002 ) |
|
10406 |
or croak "CPAN::Meta::YAML 0.002 is not available\n"; |
|
10407 |
return "CPAN::Meta::YAML"; |
|
10408 |
} |
|
10409 |
else { |
|
10410 |
my $backend = $ENV{PERL_YAML_BACKEND}; |
|
10411 |
_can_load( $backend ) |
|
10412 |
or croak "Could not load PERL_YAML_BACKEND '$backend'\n"; |
|
10413 |
$backend->can("Load") |
|
10414 |
or croak "PERL_YAML_BACKEND '$backend' does not implement Load()\n"; |
|
10415 |
return $backend; |
|
10416 |
} |
|
10417 |
} |
|
10418 |
|
|
10419 |
sub json_backend { |
|
10420 |
local $Module::Load::Conditional::CHECK_INC_HASH = 1; |
|
10421 |
if (! $ENV{PERL_JSON_BACKEND} or $ENV{PERL_JSON_BACKEND} eq 'JSON::PP') { |
|
10422 |
_can_load( 'JSON::PP' => 2.27103 ) |
|
10423 |
or croak "JSON::PP 2.27103 is not available\n"; |
|
10424 |
return 'JSON::PP'; |
|
10425 |
} |
|
10426 |
else { |
|
10427 |
_can_load( 'JSON' => 2.5 ) |
|
10428 |
or croak "JSON 2.5 is required for " . |
|
10429 |
"\$ENV{PERL_JSON_BACKEND} = '$ENV{PERL_JSON_BACKEND}'\n"; |
|
10430 |
return "JSON"; |
|
10431 |
} |
|
10432 |
} |
|
10433 |
|
|
10434 |
sub _slurp { |
|
10435 |
open my $fh, "<" . IO_LAYER, "$_[0]" |
|
10436 |
or die "can't open $_[0] for reading: $!"; |
|
10437 |
return do { local $/; <$fh> }; |
|
10438 |
} |
|
10439 |
|
|
10440 |
sub _can_load { |
|
10441 |
my ($module, $version) = @_; |
|
10442 |
(my $file = $module) =~ s{::}{/}g; |
|
10443 |
$file .= ".pm"; |
|
10444 |
return 1 if $INC{$file}; |
|
10445 |
return 0 if exists $INC{$file}; # prior load failed |
|
10446 |
eval { require $file; 1 } |
|
10447 |
or return 0; |
|
10448 |
if ( defined $version ) { |
|
10449 |
eval { $module->VERSION($version); 1 } |
|
10450 |
or return 0; |
|
10451 |
} |
|
10452 |
return 1; |
|
10453 |
} |
|
10454 |
|
|
10455 |
# Kept for backwards compatibility only |
|
10456 |
# Create an object from a file |
|
10457 |
sub LoadFile ($) { |
|
10458 |
require CPAN::Meta::YAML; |
|
10459 |
return CPAN::Meta::YAML::LoadFile(shift) |
|
10460 |
or die CPAN::Meta::YAML->errstr; |
|
10461 |
} |
|
10462 |
|
|
10463 |
# Parse a document from a string. |
|
10464 |
sub Load ($) { |
|
10465 |
require CPAN::Meta::YAML; |
|
10466 |
return CPAN::Meta::YAML::Load(shift) |
|
10467 |
or die CPAN::Meta::YAML->errstr; |
|
10468 |
} |
|
10469 |
|
|
10470 |
1; |
|
10471 |
|
|
10472 |
__END__ |
|
10473 |
|
|
10474 |
PARSE_CPAN_META |
|
10475 | ||
10476 |
$fatpacked{"lib/core/only.pm"} = <<'LIB_CORE_ONLY'; |
|
10477 |
package lib::core::only; |
|
10478 |
|
|
10479 |
use strict; |
|
10480 |
use warnings FATAL => 'all'; |
|
10481 |
use Config; |
|
10482 |
|
|
10483 |
sub import { |
|
10484 |
@INC = @Config{qw(privlibexp archlibexp)}; |
|
10485 |
return |
|
10486 |
} |
|
10487 |
|
|
10488 |
1; |
|
10489 |
LIB_CORE_ONLY |
|
10490 | ||
10491 |
$fatpacked{"local/lib.pm"} = <<'LOCAL_LIB'; |
|
10492 |
use strict; |
|
10493 |
use warnings; |
|
10494 |
|
|
10495 |
package local::lib; |
|
10496 |
|
|
10497 |
use 5.008001; # probably works with earlier versions but I'm not supporting them |
|
10498 |
# (patches would, of course, be welcome) |
|
10499 |
|
|
10500 |
use File::Spec (); |
|
10501 |
use File::Path (); |
|
10502 |
use Config; |
|
10503 |
|
|
10504 |
our $VERSION = '1.008009'; # 1.8.9 |
|
10505 |
|
|
10506 |
our @KNOWN_FLAGS = qw(--self-contained --deactivate --deactivate-all); |
|
10507 |
|
|
10508 |
sub DEACTIVATE_ONE () { 1 } |
|
10509 |
sub DEACTIVATE_ALL () { 2 } |
|
10510 |
|
|
10511 |
sub INTERPOLATE_ENV () { 1 } |
|
10512 |
sub LITERAL_ENV () { 0 } |
|
10513 |
|
|
10514 |
sub import { |
|
10515 |
my ($class, @args) = @_; |
|
10516 |
|
|
10517 |
# Remember what PERL5LIB was when we started |
|
10518 |
my $perl5lib = $ENV{PERL5LIB} || ''; |
|
10519 |
|
|
10520 |
my %arg_store; |
|
10521 |
for my $arg (@args) { |
|
10522 |
# check for lethal dash first to stop processing before causing problems |
|
10523 |
if ($arg =~ /−/) { |
|
10524 |
die <<'DEATH'; |
|
10525 |
WHOA THERE! It looks like you've got some fancy dashes in your commandline! |
|
10526 |
These are *not* the traditional -- dashes that software recognizes. You |
|
10527 |
probably got these by copy-pasting from the perldoc for this module as |
|
10528 |
rendered by a UTF8-capable formatter. This most typically happens on an OS X |
|
10529 |
terminal, but can happen elsewhere too. Please try again after replacing the |
|
10530 |
dashes with normal minus signs. |
|
10531 |
DEATH |
|
10532 |
} |
|
10533 |
elsif(grep { $arg eq $_ } @KNOWN_FLAGS) { |
|
10534 |
(my $flag = $arg) =~ s/--//; |
|
10535 |
$arg_store{$flag} = 1; |
|
10536 |
} |
|
10537 |
elsif($arg =~ /^--/) { |
|
10538 |
die "Unknown import argument: $arg"; |
|
10539 |
} |
|
10540 |
else { |
|
10541 |
# assume that what's left is a path |
|
10542 |
$arg_store{path} = $arg; |
|
10543 |
} |
|
10544 |
} |
|
10545 |
|
|
10546 |
if($arg_store{'self-contained'}) { |
|
10547 |
die "FATAL: The local::lib --self-contained flag has never worked reliably and the original author, Mark Stosberg, was unable or unwilling to maintain it. As such, this flag has been removed from the local::lib codebase in order to prevent misunderstandings and potentially broken builds. The local::lib authors recommend that you look at the lib::core::only module shipped with this distribution in order to create a more robust environment that is equivalent to what --self-contained provided (although quite possibly not what you originally thought it provided due to the poor quality of the documentation, for which we apologise).\n"; |
|
10548 |
} |
|
10549 |
|
|
10550 |
my $deactivating = 0; |
|
10551 |
if ($arg_store{deactivate}) { |
|
10552 |
$deactivating = DEACTIVATE_ONE; |
|
10553 |
} |
|
10554 |
if ($arg_store{'deactivate-all'}) { |
|
10555 |
$deactivating = DEACTIVATE_ALL; |
|
10556 |
} |
|
10557 |
|
|
10558 |
$arg_store{path} = $class->resolve_path($arg_store{path}); |
|
10559 |
$class->setup_local_lib_for($arg_store{path}, $deactivating); |
|
10560 |
|
|
10561 |
for (@INC) { # Untaint @INC |
|
10562 |
next if ref; # Skip entry if it is an ARRAY, CODE, blessed, etc. |
|
10563 |
m/(.*)/ and $_ = $1; |
|
10564 |
} |
|
10565 |
} |
|
10566 |
|
|
10567 |
sub pipeline; |
|
10568 |
|
|
10569 |
sub pipeline { |
|
10570 |
my @methods = @_; |
|
10571 |
my $last = pop(@methods); |
|
10572 |
if (@methods) { |
|
10573 |
\sub { |
|
10574 |
my ($obj, @args) = @_; |
|
10575 |
$obj->${pipeline @methods}( |
|
10576 |
$obj->$last(@args) |
|
10577 |
); |
|
10578 |
}; |
|
10579 |
} else { |
|
10580 |
\sub { |
|
10581 |
shift->$last(@_); |
|
10582 |
}; |
|
10583 |
} |
|
10584 |
} |
|
10585 |
|
|
10586 |
sub _uniq { |
|
10587 |
my %seen; |
|
10588 |
grep { ! $seen{$_}++ } @_; |
|
10589 |
} |
|
10590 |
|
|
10591 |
sub resolve_path { |
|
10592 |
my ($class, $path) = @_; |
|
10593 |
$class->${pipeline qw( |
|
10594 |
resolve_relative_path |
|
10595 |
resolve_home_path |
|
10596 |
resolve_empty_path |
|
10597 |
)}($path); |
|
10598 |
} |
|
10599 |
|
|
10600 |
sub resolve_empty_path { |
|
10601 |
my ($class, $path) = @_; |
|
10602 |
if (defined $path) { |
|
10603 |
$path; |
|
10604 |
} else { |
|
10605 |
'~/perl5'; |
|
10606 |
} |
|
10607 |
} |
|
10608 |
|
|
10609 |
sub resolve_home_path { |
|
10610 |
my ($class, $path) = @_; |
|
10611 |
return $path unless ($path =~ /^~/); |
|
10612 |
my ($user) = ($path =~ /^~([^\/]+)/); # can assume ^~ so undef for 'us' |
|
10613 |
my $tried_file_homedir; |
|
10614 |
my $homedir = do { |
|
10615 |
if (eval { require File::HomeDir } && $File::HomeDir::VERSION >= 0.65) { |
|
10616 |
$tried_file_homedir = 1; |
|
10617 |
if (defined $user) { |
|
10618 |
File::HomeDir->users_home($user); |
|
10619 |
} else { |
|
10620 |
File::HomeDir->my_home; |
|
10621 |
} |
|
10622 |
} else { |
|
10623 |
if (defined $user) { |
|
10624 |
(getpwnam $user)[7]; |
|
10625 |
} else { |
|
10626 |
if (defined $ENV{HOME}) { |
|
10627 |
$ENV{HOME}; |
|
10628 |
} else { |
|
10629 |
(getpwuid $<)[7]; |
|
10630 |
} |
|
10631 |
} |
|
10632 |
} |
|
10633 |
}; |
|
10634 |
unless (defined $homedir) { |
|
10635 |
require Carp; |
|
10636 |
Carp::croak( |
|
10637 |
"Couldn't resolve homedir for " |
|
10638 |
.(defined $user ? $user : 'current user') |
|
10639 |
.($tried_file_homedir ? '' : ' - consider installing File::HomeDir') |
|
10640 |
); |
|
10641 |
} |
|
10642 |
$path =~ s/^~[^\/]*/$homedir/; |
|
10643 |
$path; |
|
10644 |
} |
|
10645 |
|
|
10646 |
sub resolve_relative_path { |
|
10647 |
my ($class, $path) = @_; |
|
10648 |
$path = File::Spec->rel2abs($path); |
|
10649 |
} |
|
10650 |
|
|
10651 |
sub setup_local_lib_for { |
|
10652 |
my ($class, $path, $deactivating) = @_; |
|
10653 |
|
|
10654 |
my $interpolate = LITERAL_ENV; |
|
10655 |
my @active_lls = $class->active_paths; |
|
10656 |
|
|
10657 |
$class->ensure_dir_structure_for($path); |
|
10658 |
|
|
10659 |
# On Win32 directories often contain spaces. But some parts of the CPAN |
|
10660 |
# toolchain don't like that. To avoid this, GetShortPathName() gives us |
|
10661 |
# an alternate representation that has none. |
|
10662 |
# This only works if the directory already exists. |
|
10663 |
$path = Win32::GetShortPathName($path) if $^O eq 'MSWin32'; |
|
10664 |
|
|
10665 |
if (! $deactivating) { |
|
10666 |
if (@active_lls && $active_lls[-1] eq $path) { |
|
10667 |
exit 0 if $0 eq '-'; |
|
10668 |
return; # Asked to add what's already at the top of the stack |
|
10669 |
} elsif (grep { $_ eq $path} @active_lls) { |
|
10670 |
# Asked to add a dir that's lower in the stack -- so we remove it from |
|
10671 |
# where it is, and then add it back at the top. |
|
10672 |
$class->setup_env_hash_for($path, DEACTIVATE_ONE); |
|
10673 |
# Which means we can no longer output "PERL5LIB=...:$PERL5LIB" stuff |
|
10674 |
# anymore because we're taking something *out*. |
|
10675 |
$interpolate = INTERPOLATE_ENV; |
|
10676 |
} |
|
10677 |
} |
|
10678 |
|
|
10679 |
if ($0 eq '-') { |
|
10680 |
$class->print_environment_vars_for($path, $deactivating, $interpolate); |
|
10681 |
exit 0; |
|
10682 |
} else { |
|
10683 |
$class->setup_env_hash_for($path, $deactivating); |
|
10684 |
my $arch_dir = $Config{archname}; |
|
10685 |
@INC = _uniq( |
|
10686 |
( |
|
10687 |
# Inject $path/$archname for each path in PERL5LIB |
|
10688 |
map { ( File::Spec->catdir($_, $arch_dir), $_ ) } |
|
10689 |
split($Config{path_sep}, $ENV{PERL5LIB}) |
|
10690 |
), |
|
10691 |
@INC |
|
10692 |
); |
|
10693 |
} |
|
10694 |
} |
|
10695 |
|
|
10696 |
sub install_base_bin_path { |
|
10697 |
my ($class, $path) = @_; |
|
10698 |
File::Spec->catdir($path, 'bin'); |
|
10699 |
} |
|
10700 |
|
|
10701 |
sub install_base_perl_path { |
|
10702 |
my ($class, $path) = @_; |
|
10703 |
File::Spec->catdir($path, 'lib', 'perl5'); |
|
10704 |
} |
|
10705 |
|
|
10706 |
sub install_base_arch_path { |
|
10707 |
my ($class, $path) = @_; |
|
10708 |
File::Spec->catdir($class->install_base_perl_path($path), $Config{archname}); |
|
10709 |
} |
|
10710 |
|
|
10711 |
sub ensure_dir_structure_for { |
|
10712 |
my ($class, $path) = @_; |
|
10713 |
unless (-d $path) { |
|
10714 |
warn "Attempting to create directory ${path}\n"; |
|
10715 |
} |
|
10716 |
File::Path::mkpath($path); |
|
10717 |
return |
|
10718 |
} |
|
10719 |
|
|
10720 |
sub guess_shelltype { |
|
10721 |
my $shellbin = 'sh'; |
|
10722 |
if(defined $ENV{'SHELL'}) { |
|
10723 |
my @shell_bin_path_parts = File::Spec->splitpath($ENV{'SHELL'}); |
|
10724 |
$shellbin = $shell_bin_path_parts[-1]; |
|
10725 |
} |
|
10726 |
my $shelltype = do { |
|
10727 |
local $_ = $shellbin; |
|
10728 |
if(/csh/) { |
|
10729 |
'csh' |
|
10730 |
} else { |
|
10731 |
'bourne' |
|
10732 |
} |
|
10733 |
}; |
|
10734 |
|
|
10735 |
# Both Win32 and Cygwin have $ENV{COMSPEC} set. |
|
10736 |
if (defined $ENV{'COMSPEC'} && $^O ne 'cygwin') { |
|
10737 |
my @shell_bin_path_parts = File::Spec->splitpath($ENV{'COMSPEC'}); |
|
10738 |
$shellbin = $shell_bin_path_parts[-1]; |
|
10739 |
$shelltype = do { |
|
10740 |
local $_ = $shellbin; |
|
10741 |
if(/command\.com/) { |
|
10742 |
'win32' |
|
10743 |
} elsif(/cmd\.exe/) { |
|
10744 |
'win32' |
|
10745 |
} elsif(/4nt\.exe/) { |
|
10746 |
'win32' |
|
10747 |
} else { |
|
10748 |
$shelltype |
|
10749 |
} |
|
10750 |
}; |
|
10751 |
} |
|
10752 |
return $shelltype; |
|
10753 |
} |
|
10754 |
|
|
10755 |
sub print_environment_vars_for { |
|
10756 |
my ($class, $path, $deactivating, $interpolate) = @_; |
|
10757 |
print $class->environment_vars_string_for($path, $deactivating, $interpolate); |
|
10758 |
} |
|
10759 |
|
|
10760 |
sub environment_vars_string_for { |
|
10761 |
my ($class, $path, $deactivating, $interpolate) = @_; |
|
10762 |
my @envs = $class->build_environment_vars_for($path, $deactivating, $interpolate); |
|
10763 |
my $out = ''; |
|
10764 |
|
|
10765 |
# rather basic csh detection, goes on the assumption that something won't |
|
10766 |
# call itself csh unless it really is. also, default to bourne in the |
|
10767 |
# pathological situation where a user doesn't have $ENV{SHELL} defined. |
|
10768 |
# note also that shells with funny names, like zoid, are assumed to be |
|
10769 |
# bourne. |
|
10770 |
|
|
10771 |
my $shelltype = $class->guess_shelltype; |
|
10772 |
|
|
10773 |
while (@envs) { |
|
10774 |
my ($name, $value) = (shift(@envs), shift(@envs)); |
|
10775 |
$value =~ s/(\\")/\\$1/g if defined $value; |
|
10776 |
$out .= $class->${\"build_${shelltype}_env_declaration"}($name, $value); |
|
10777 |
} |
|
10778 |
return $out; |
|
10779 |
} |
|
10780 |
|
|
10781 |
# simple routines that take two arguments: an %ENV key and a value. return |
|
10782 |
# strings that are suitable for passing directly to the relevant shell to set |
|
10783 |
# said key to said value. |
|
10784 |
sub build_bourne_env_declaration { |
|
10785 |
my $class = shift; |
|
10786 |
my($name, $value) = @_; |
|
10787 |
return defined($value) ? qq{export ${name}="${value}";\n} : qq{unset ${name};\n}; |
|
10788 |
} |
|
10789 |
|
|
10790 |
sub build_csh_env_declaration { |
|
10791 |
my $class = shift; |
|
10792 |
my($name, $value) = @_; |
|
10793 |
return defined($value) ? qq{setenv ${name} "${value}"\n} : qq{unsetenv ${name}\n}; |
|
10794 |
} |
|
10795 |
|
|
10796 |
sub build_win32_env_declaration { |
|
10797 |
my $class = shift; |
|
10798 |
my($name, $value) = @_; |
|
10799 |
return defined($value) ? qq{set ${name}=${value}\n} : qq{set ${name}=\n}; |
|
10800 |
} |
|
10801 |
|
|
10802 |
sub setup_env_hash_for { |
|
10803 |
my ($class, $path, $deactivating) = @_; |
|
10804 |
my %envs = $class->build_environment_vars_for($path, $deactivating, INTERPOLATE_ENV); |
|
10805 |
@ENV{keys %envs} = values %envs; |
|
10806 |
} |
|
10807 |
|
|
10808 |
sub build_environment_vars_for { |
|
10809 |
my ($class, $path, $deactivating, $interpolate) = @_; |
|
10810 |
|
|
10811 |
if ($deactivating == DEACTIVATE_ONE) { |
|
10812 |
return $class->build_deactivate_environment_vars_for($path, $interpolate); |
|
10813 |
} elsif ($deactivating == DEACTIVATE_ALL) { |
|
10814 |
return $class->build_deact_all_environment_vars_for($path, $interpolate); |
|
10815 |
} else { |
|
10816 |
return $class->build_activate_environment_vars_for($path, $interpolate); |
|
10817 |
} |
|
10818 |
} |
|
10819 |
|
|
10820 |
# Build an environment value for a variable like PATH from a list of paths. |
|
10821 |
# References to existing variables are given as references to the variable name. |
|
10822 |
# Duplicates are removed. |
|
10823 |
# |
|
10824 |
# options: |
|
10825 |
# - interpolate: INTERPOLATE_ENV/LITERAL_ENV |
|
10826 |
# - exists: paths are included only if they exist (default: interpolate == INTERPOLATE_ENV) |
|
10827 |
# - filter: function to apply to each path do decide if it must be included |
|
10828 |
# - empty: the value to return in the case of empty value |
|
10829 |
my %ENV_LIST_VALUE_DEFAULTS = ( |
|
10830 |
interpolate => INTERPOLATE_ENV, |
|
10831 |
exists => undef, |
|
10832 |
filter => sub { 1 }, |
|
10833 |
empty => undef, |
|
10834 |
); |
|
10835 |
sub _env_list_value { |
|
10836 |
my $options = shift; |
|
10837 |
die(sprintf "unknown option '$_' at %s line %u\n", (caller)[1..2]) |
|
10838 |
for grep { !exists $ENV_LIST_VALUE_DEFAULTS{$_} } keys %$options; |
|
10839 |
my %options = (%ENV_LIST_VALUE_DEFAULTS, %{ $options }); |
|
10840 |
$options{exists} = $options{interpolate} == INTERPOLATE_ENV |
|
10841 |
unless defined $options{exists}; |
|
10842 |
|
|
10843 |
my %seen; |
|
10844 |
|
|
10845 |
my $value = join($Config{path_sep}, map { |
|
10846 |
ref $_ ? ($^O eq 'MSWin32' ? "%${$_}%" : "\$${$_}") : $_ |
|
10847 |
} grep { |
|
10848 |
ref $_ || (defined $_ |
|
10849 |
&& length($_) > 0 |
|
10850 |
&& !$seen{$_}++ |
|
10851 |
&& $options{filter}->($_) |
|
10852 |
&& (!$options{exists} || -e $_)) |
|
10853 |
} map { |
|
10854 |
if (ref $_ eq 'SCALAR' && $options{interpolate} == INTERPOLATE_ENV) { |
|
10855 |
exists $ENV{${$_}} ? (split /\Q$Config{path_sep}/, $ENV{${$_}}) : () |
|
10856 |
} else { |
|
10857 |
$_ |
|
10858 |
} |
|
10859 |
} @_); |
|
10860 |
return length($value) ? $value : $options{empty}; |
|
10861 |
} |
|
10862 |
|
|
10863 |
sub build_activate_environment_vars_for { |
|
10864 |
my ($class, $path, $interpolate) = @_; |
|
10865 |
return ( |
|
10866 |
PERL_LOCAL_LIB_ROOT => |
|
10867 |
_env_list_value( |
|
10868 |
{ interpolate => $interpolate, exists => 0, empty => '' }, |
|
10869 |
\'PERL_LOCAL_LIB_ROOT', |
|
10870 |
$path, |
|
10871 |
), |
|
10872 |
PERL_MB_OPT => "--install_base ${path}", |
|
10873 |
PERL_MM_OPT => "INSTALL_BASE=${path}", |
|
10874 |
PERL5LIB => |
|
10875 |
_env_list_value( |
|
10876 |
{ interpolate => $interpolate, exists => 0, empty => '' }, |
|
10877 |
$class->install_base_perl_path($path), |
|
10878 |
\'PERL5LIB', |
|
10879 |
), |
|
10880 |
PATH => _env_list_value( |
|
10881 |
{ interpolate => $interpolate, exists => 0, empty => '' }, |
|
10882 |
$class->install_base_bin_path($path), |
|
10883 |
\'PATH', |
|
10884 |
), |
|
10885 |
) |
|
10886 |
} |
|
10887 |
|
|
10888 |
sub active_paths { |
|
10889 |
my ($class) = @_; |
|
10890 |
|
|
10891 |
return () unless defined $ENV{PERL_LOCAL_LIB_ROOT}; |
|
10892 |
return grep { $_ ne '' } split /\Q$Config{path_sep}/, $ENV{PERL_LOCAL_LIB_ROOT}; |
|
10893 |
} |
|
10894 |
|
|
10895 |
sub build_deactivate_environment_vars_for { |
|
10896 |
my ($class, $path, $interpolate) = @_; |
|
10897 |
|
|
10898 |
my @active_lls = $class->active_paths; |
|
10899 |
|
|
10900 |
if (!grep { $_ eq $path } @active_lls) { |
|
10901 |
warn "Tried to deactivate inactive local::lib '$path'\n"; |
|
10902 |
return (); |
|
10903 |
} |
|
10904 |
|
|
10905 |
my $perl_path = $class->install_base_perl_path($path); |
|
10906 |
my $arch_path = $class->install_base_arch_path($path); |
|
10907 |
my $bin_path = $class->install_base_bin_path($path); |
|
10908 |
|
|
10909 |
|
|
10910 |
my %env = ( |
|
10911 |
PERL_LOCAL_LIB_ROOT => _env_list_value( |
|
10912 |
{ |
|
10913 |
exists => 0, |
|
10914 |
}, |
|
10915 |
grep { $_ ne $path } @active_lls |
|
10916 |
), |
|
10917 |
PERL5LIB => _env_list_value( |
|
10918 |
{ |
|
10919 |
exists => 0, |
|
10920 |
filter => sub { |
|
10921 |
$_ ne $perl_path && $_ ne $arch_path |
|
10922 |
}, |
|
10923 |
}, |
|
10924 |
\'PERL5LIB', |
|
10925 |
), |
|
10926 |
PATH => _env_list_value( |
|
10927 |
{ |
|
10928 |
exists => 0, |
|
10929 |
filter => sub { $_ ne $bin_path }, |
|
10930 |
}, |
|
10931 |
\'PATH', |
|
10932 |
), |
|
10933 |
); |
|
10934 |
|
|
10935 |
# If removing ourselves from the "top of the stack", set install paths to |
|
10936 |
# correspond with the new top of stack. |
|
10937 |
if ($active_lls[-1] eq $path) { |
|
10938 |
my $new_top = $active_lls[-2]; |
|
10939 |
$env{PERL_MB_OPT} = defined($new_top) ? "--install_base ${new_top}" : undef; |
|
10940 |
$env{PERL_MM_OPT} = defined($new_top) ? "INSTALL_BASE=${new_top}" : undef; |
|
10941 |
} |
|
10942 |
|
|
10943 |
return %env; |
|
10944 |
} |
|
10945 |
|
|
10946 |
sub build_deact_all_environment_vars_for { |
|
10947 |
my ($class, $path, $interpolate) = @_; |
|
10948 |
|
|
10949 |
my @active_lls = $class->active_paths; |
|
10950 |
|
|
10951 |
my %perl_paths = map { ( |
|
10952 |
$class->install_base_perl_path($_) => 1, |
|
10953 |
$class->install_base_arch_path($_) => 1 |
|
10954 |
) } @active_lls; |
|
10955 |
my %bin_paths = map { ( |
|
10956 |
$class->install_base_bin_path($_) => 1, |
|
10957 |
) } @active_lls; |
|
10958 |
|
|
10959 |
my %env = ( |
|
10960 |
PERL_LOCAL_LIB_ROOT => undef, |
|
10961 |
PERL_MM_OPT => undef, |
|
10962 |
PERL_MB_OPT => undef, |
|
10963 |
PERL5LIB => _env_list_value( |
|
10964 |
{ |
|
10965 |
exists => 0, |
|
10966 |
filter => sub { |
|
10967 |
! scalar grep { exists $perl_paths{$_} } $_[0] |
|
10968 |
}, |
|
10969 |
}, |
|
10970 |
\'PERL5LIB' |
|
10971 |
), |
|
10972 |
PATH => _env_list_value( |
|
10973 |
{ |
|
10974 |
exists => 0, |
|
10975 |
filter => sub { |
|
10976 |
! scalar grep { exists $bin_paths{$_} } $_[0] |
|
10977 |
}, |
|
10978 |
}, |
|
10979 |
\'PATH' |
|
10980 |
), |
|
10981 |
); |
|
10982 |
|
|
10983 |
return %env; |
|
10984 |
} |
|
10985 |
|
|
10986 |
1; |
|
10987 |
LOCAL_LIB |
|
10988 | ||
10989 |
$fatpacked{"version.pm"} = <<'VERSION'; |
|
10990 |
#!perl -w |
|
10991 |
package version; |
|
10992 |
|
|
10993 |
use 5.005_04; |
|
10994 |
use strict; |
|
10995 |
|
|
10996 |
use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv); |
|
10997 |
|
|
10998 |
$VERSION = 0.9901; |
|
10999 |
|
|
11000 |
$CLASS = 'version'; |
|
11001 |
|
|
11002 |
#--------------------------------------------------------------------------# |
|
11003 |
# Version regexp components |
|
11004 |
#--------------------------------------------------------------------------# |
|
11005 |
|
|
11006 |
# Fraction part of a decimal version number. This is a common part of |
|
11007 |
# both strict and lax decimal versions |
|
11008 |
|
|
11009 |
my $FRACTION_PART = qr/\.[0-9]+/; |
|
11010 |
|
|
11011 |
# First part of either decimal or dotted-decimal strict version number. |
|
11012 |
# Unsigned integer with no leading zeroes (except for zero itself) to |
|
11013 |
# avoid confusion with octal. |
|
11014 |
|
|
11015 |
my $STRICT_INTEGER_PART = qr/0|[1-9][0-9]*/; |
|
11016 |
|
|
11017 |
# First part of either decimal or dotted-decimal lax version number. |
|
11018 |
# Unsigned integer, but allowing leading zeros. Always interpreted |
|
11019 |
# as decimal. However, some forms of the resulting syntax give odd |
|
11020 |
# results if used as ordinary Perl expressions, due to how perl treats |
|
11021 |
# octals. E.g. |
|
11022 |
# version->new("010" ) == 10 |
|
11023 |
# version->new( 010 ) == 8 |
|
11024 |
# version->new( 010.2) == 82 # "8" . "2" |
|
11025 |
|
|
11026 |
my $LAX_INTEGER_PART = qr/[0-9]+/; |
|
11027 |
|
|
11028 |
# Second and subsequent part of a strict dotted-decimal version number. |
|
11029 |
# Leading zeroes are permitted, and the number is always decimal. |
|
11030 |
# Limited to three digits to avoid overflow when converting to decimal |
|
11031 |
# form and also avoid problematic style with excessive leading zeroes. |
|
11032 |
|
|
11033 |
my $STRICT_DOTTED_DECIMAL_PART = qr/\.[0-9]{1,3}/; |
|
11034 |
|
|
11035 |
# Second and subsequent part of a lax dotted-decimal version number. |
|
11036 |
# Leading zeroes are permitted, and the number is always decimal. No |
|
11037 |
# limit on the numerical value or number of digits, so there is the |
|
11038 |
# possibility of overflow when converting to decimal form. |
|
11039 |
|
|
11040 |
my $LAX_DOTTED_DECIMAL_PART = qr/\.[0-9]+/; |
|
11041 |
|
|
11042 |
# Alpha suffix part of lax version number syntax. Acts like a |
|
11043 |
# dotted-decimal part. |
|
11044 |
|
|
11045 |
my $LAX_ALPHA_PART = qr/_[0-9]+/; |
|
11046 |
|
|
11047 |
#--------------------------------------------------------------------------# |
|
11048 |
# Strict version regexp definitions |
|
11049 |
#--------------------------------------------------------------------------# |
|
11050 |
|
|
11051 |
# Strict decimal version number. |
|
11052 |
|
|
11053 |
my $STRICT_DECIMAL_VERSION = |
|
11054 |
qr/ $STRICT_INTEGER_PART $FRACTION_PART? /x; |
|
11055 |
|
|
11056 |
# Strict dotted-decimal version number. Must have both leading "v" and |
|
11057 |
# at least three parts, to avoid confusion with decimal syntax. |
|
11058 |
|
|
11059 |
my $STRICT_DOTTED_DECIMAL_VERSION = |
|
11060 |
qr/ v $STRICT_INTEGER_PART $STRICT_DOTTED_DECIMAL_PART{2,} /x; |
|
11061 |
|
|
11062 |
# Complete strict version number syntax -- should generally be used |
|
11063 |
# anchored: qr/ \A $STRICT \z /x |
|
11064 |
|
|
11065 |
$STRICT = |
|
11066 |
qr/ $STRICT_DECIMAL_VERSION | $STRICT_DOTTED_DECIMAL_VERSION /x; |
|
11067 |
|
|
11068 |
#--------------------------------------------------------------------------# |
|
11069 |
# Lax version regexp definitions |
|
11070 |
#--------------------------------------------------------------------------# |
|
11071 |
|
|
11072 |
# Lax decimal version number. Just like the strict one except for |
|
11073 |
# allowing an alpha suffix or allowing a leading or trailing |
|
11074 |
# decimal-point |
|
11075 |
|
|
11076 |
my $LAX_DECIMAL_VERSION = |
|
11077 |
qr/ $LAX_INTEGER_PART (?: \. | $FRACTION_PART $LAX_ALPHA_PART? )? |
|
11078 |
| |
|
11079 |
$FRACTION_PART $LAX_ALPHA_PART? |
|
11080 |
/x; |
|
11081 |
|
|
11082 |
# Lax dotted-decimal version number. Distinguished by having either |
|
11083 |
# leading "v" or at least three non-alpha parts. Alpha part is only |
|
11084 |
# permitted if there are at least two non-alpha parts. Strangely |
|
11085 |
# enough, without the leading "v", Perl takes .1.2 to mean v0.1.2, |
|
11086 |
# so when there is no "v", the leading part is optional |
|
11087 |
|
|
11088 |
my $LAX_DOTTED_DECIMAL_VERSION = |
|
11089 |
qr/ |
|
11090 |
v $LAX_INTEGER_PART (?: $LAX_DOTTED_DECIMAL_PART+ $LAX_ALPHA_PART? )? |
|
11091 |
| |
|
11092 |
$LAX_INTEGER_PART? $LAX_DOTTED_DECIMAL_PART{2,} $LAX_ALPHA_PART? |
|
11093 |
/x; |
|
11094 |
|
|
11095 |
# Complete lax version number syntax -- should generally be used |
|
11096 |
# anchored: qr/ \A $LAX \z /x |
|
11097 |
# |
|
11098 |
# The string 'undef' is a special case to make for easier handling |
|
11099 |
# of return values from ExtUtils::MM->parse_version |
|
11100 |
|
|
11101 |
$LAX = |
|
11102 |
qr/ undef | $LAX_DECIMAL_VERSION | $LAX_DOTTED_DECIMAL_VERSION /x; |
|
11103 |
|
|
11104 |
#--------------------------------------------------------------------------# |
|
11105 |
|
|
11106 |
{ |
|
11107 |
local $SIG{'__DIE__'}; |
|
11108 |
eval "use version::vxs $VERSION"; |
|
11109 |
if ( $@ ) { # don't have the XS version installed |
|
11110 |
eval "use version::vpp $VERSION"; # don't tempt fate |
|
11111 |
die "$@" if ( $@ ); |
|
11112 |
push @ISA, "version::vpp"; |
|
11113 |
local $^W; |
|
11114 |
*version::qv = \&version::vpp::qv; |
|
11115 |
*version::declare = \&version::vpp::declare; |
|
11116 |
*version::_VERSION = \&version::vpp::_VERSION; |
|
11117 |
*version::vcmp = \&version::vpp::vcmp; |
|
11118 |
if ($] >= 5.009000) { |
|
11119 |
no strict 'refs'; |
|
11120 |
*version::stringify = \&version::vpp::stringify; |
|
11121 |
*{'version::(""'} = \&version::vpp::stringify; |
|
11122 |
*{'version::(<=>'} = \&version::vpp::vcmp; |
|
11123 |
*version::new = \&version::vpp::new; |
|
11124 |
*version::parse = \&version::vpp::parse; |
|
11125 |
} |
|
11126 |
} |
|
11127 |
else { # use XS module |
|
11128 |
push @ISA, "version::vxs"; |
|
11129 |
local $^W; |
|
11130 |
*version::declare = \&version::vxs::declare; |
|
11131 |
*version::qv = \&version::vxs::qv; |
|
11132 |
*version::_VERSION = \&version::vxs::_VERSION; |
|
11133 |
*version::vcmp = \&version::vxs::VCMP; |
|
11134 |
if ($] >= 5.009000) { |
|
11135 |
no strict 'refs'; |
|
11136 |
*version::stringify = \&version::vxs::stringify; |
|
11137 |
*{'version::(""'} = \&version::vxs::stringify; |
|
11138 |
*{'version::(<=>'} = \&version::vxs::VCMP; |
|
11139 |
*version::new = \&version::vxs::new; |
|
11140 |
*version::parse = \&version::vxs::parse; |
|
11141 |
} |
|
11142 |
|
|
11143 |
} |
|
11144 |
} |
|
11145 |
|
|
11146 |
# Preloaded methods go here. |
|
11147 |
sub import { |
|
11148 |
no strict 'refs'; |
|
11149 |
my ($class) = shift; |
|
11150 |
|
|
11151 |
# Set up any derived class |
|
11152 |
unless ($class eq 'version') { |
|
11153 |
local $^W; |
|
11154 |
*{$class.'::declare'} = \&version::declare; |
|
11155 |
*{$class.'::qv'} = \&version::qv; |
|
11156 |
} |
|
11157 |
|
|
11158 |
my %args; |
|
11159 |
if (@_) { # any remaining terms are arguments |
|
11160 |
map { $args{$_} = 1 } @_ |
|
11161 |
} |
|
11162 |
else { # no parameters at all on use line |
|
11163 |
%args = |
|
11164 |
( |
|
11165 |
qv => 1, |
|
11166 |
'UNIVERSAL::VERSION' => 1, |
|
11167 |
); |
|
11168 |
} |
|
11169 |
|
|
11170 |
my $callpkg = caller(); |
|
11171 |
|
|
11172 |
if (exists($args{declare})) { |
|
11173 |
*{$callpkg.'::declare'} = |
|
11174 |
sub {return $class->declare(shift) } |
|
11175 |
unless defined(&{$callpkg.'::declare'}); |
|
11176 |
} |
|
11177 |
|
|
11178 |
if (exists($args{qv})) { |
|
11179 |
*{$callpkg.'::qv'} = |
|
11180 |
sub {return $class->qv(shift) } |
|
11181 |
unless defined(&{$callpkg.'::qv'}); |
|
11182 |
} |
|
11183 |
|
|
11184 |
if (exists($args{'UNIVERSAL::VERSION'})) { |
|
11185 |
local $^W; |
|
11186 |
*UNIVERSAL::VERSION |
|
11187 |
= \&version::_VERSION; |
|
11188 |
} |
|
11189 |
|
|
11190 |
if (exists($args{'VERSION'})) { |
|
11191 |
*{$callpkg.'::VERSION'} = \&version::_VERSION; |
|
11192 |
} |
|
11193 |
|
|
11194 |
if (exists($args{'is_strict'})) { |
|
11195 |
*{$callpkg.'::is_strict'} = \&version::is_strict |
|
11196 |
unless defined(&{$callpkg.'::is_strict'}); |
|
11197 |
} |
|
11198 |
|
|
11199 |
if (exists($args{'is_lax'})) { |
|
11200 |
*{$callpkg.'::is_lax'} = \&version::is_lax |
|
11201 |
unless defined(&{$callpkg.'::is_lax'}); |
|
11202 |
} |
|
11203 |
} |
|
11204 |
|
|
11205 |
sub is_strict { defined $_[0] && $_[0] =~ qr/ \A $STRICT \z /x } |
|
11206 |
sub is_lax { defined $_[0] && $_[0] =~ qr/ \A $LAX \z /x } |
|
11207 |
|
|
11208 |
1; |
|
11209 |
VERSION |
|
11210 | ||
11211 |
$fatpacked{"version/vpp.pm"} = <<'VERSION_VPP'; |
|
11212 |
package charstar; |
|
11213 |
# a little helper class to emulate C char* semantics in Perl |
|
11214 |
# so that prescan_version can use the same code as in C |
|
11215 |
|
|
11216 |
use overload ( |
|
11217 |
'""' => \&thischar, |
|
11218 |
'0+' => \&thischar, |
|
11219 |
'++' => \&increment, |
|
11220 |
'--' => \&decrement, |
|
11221 |
'+' => \&plus, |
|
11222 |
'-' => \&minus, |
|
11223 |
'*' => \&multiply, |
|
11224 |
'cmp' => \&cmp, |
|
11225 |
'<=>' => \&spaceship, |
|
11226 |
'bool' => \&thischar, |
|
11227 |
'=' => \&clone, |
|
11228 |
); |
|
11229 |
|
|
11230 |
sub new { |
|
11231 |
my ($self, $string) = @_; |
|
11232 |
my $class = ref($self) || $self; |
|
11233 |
|
|
11234 |
my $obj = { |
|
11235 |
string => [split(//,$string)], |
|
11236 |
current => 0, |
|
11237 |
}; |
|
11238 |
return bless $obj, $class; |
|
11239 |
} |
|
11240 |
|
|
11241 |
sub thischar { |
|
11242 |
my ($self) = @_; |
|
11243 |
my $last = $#{$self->{string}}; |
|
11244 |
my $curr = $self->{current}; |
|
11245 |
if ($curr >= 0 && $curr <= $last) { |
|
11246 |
return $self->{string}->[$curr]; |
|
11247 |
} |
|
11248 |
else { |
|
11249 |
return ''; |
|
11250 |
} |
|
11251 |
} |
|
11252 |
|
|
11253 |
sub increment { |
|
11254 |
my ($self) = @_; |
|
11255 |
$self->{current}++; |
|
11256 |
} |
|
11257 |
|
|
11258 |
sub decrement { |
|
11259 |
my ($self) = @_; |
|
11260 |
$self->{current}--; |
|
11261 |
} |
|
11262 |
|
|
11263 |
sub plus { |
|
11264 |
my ($self, $offset) = @_; |
|
11265 |
my $rself = $self->clone; |
|
11266 |
$rself->{current} += $offset; |
|
11267 |
return $rself; |
|
11268 |
} |
|
11269 |
|
|
11270 |
sub minus { |
|
11271 |
my ($self, $offset) = @_; |
|
11272 |
my $rself = $self->clone; |
|
11273 |
$rself->{current} -= $offset; |
|
11274 |
return $rself; |
|
11275 |
} |
|
11276 |
|
|
11277 |
sub multiply { |
|
11278 |
my ($left, $right, $swapped) = @_; |
|
11279 |
my $char = $left->thischar(); |
|
11280 |
return $char * $right; |
|
11281 |
} |
|
11282 |
|
|
11283 |
sub spaceship { |
|
11284 |
my ($left, $right, $swapped) = @_; |
|
11285 |
unless (ref($right)) { # not an object already |
|
11286 |
$right = $left->new($right); |
|
11287 |
} |
|
11288 |
return $left->{current} <=> $right->{current}; |
|
11289 |
} |
|
11290 |
|
|
11291 |
sub cmp { |
|
11292 |
my ($left, $right, $swapped) = @_; |
|
11293 |
unless (ref($right)) { # not an object already |
|
11294 |
if (length($right) == 1) { # comparing single character only |
|
11295 |
return $left->thischar cmp $right; |
|
11296 |
} |
|
11297 |
$right = $left->new($right); |
|
11298 |
} |
|
11299 |
return $left->currstr cmp $right->currstr; |
|
11300 |
} |
|
11301 |
|
|
11302 |
sub bool { |
|
11303 |
my ($self) = @_; |
|
11304 |
my $char = $self->thischar; |
|
11305 |
return ($char ne ''); |
|
11306 |
} |
|
11307 |
|
|
11308 |
sub clone { |
|
11309 |
my ($left, $right, $swapped) = @_; |
|
11310 |
$right = { |
|
11311 |
string => [@{$left->{string}}], |
|
11312 |
current => $left->{current}, |
|
11313 |
}; |
|
11314 |
return bless $right, ref($left); |
|
11315 |
} |
|
11316 |
|
|
11317 |
sub currstr { |
|
11318 |
my ($self, $s) = @_; |
|
11319 |
my $curr = $self->{current}; |
|
11320 |
my $last = $#{$self->{string}}; |
|
11321 |
if (defined($s) && $s->{current} < $last) { |
|
11322 |
$last = $s->{current}; |
|
11323 |
} |
|
11324 |
|
|
11325 |
my $string = join('', @{$self->{string}}[$curr..$last]); |
|
11326 |
return $string; |
|
11327 |
} |
|
11328 |
|
|
11329 |
package version::vpp; |
|
11330 |
use strict; |
|
11331 |
|
|
11332 |
use POSIX qw/locale_h/; |
|
11333 |
use locale; |
|
11334 |
use vars qw ($VERSION @ISA @REGEXS); |
|
11335 |
$VERSION = 0.9901; |
|
11336 |
|
|
11337 |
use overload ( |
|
11338 |
'""' => \&stringify, |
|
11339 |
'0+' => \&numify, |
|
11340 |
'cmp' => \&vcmp, |
|
11341 |
'<=>' => \&vcmp, |
|
11342 |
'bool' => \&vbool, |
|
11343 |
'+' => \&vnoop, |
|
11344 |
'-' => \&vnoop, |
|
11345 |
'*' => \&vnoop, |
|
11346 |
'/' => \&vnoop, |
|
11347 |
'+=' => \&vnoop, |
|
11348 |
'-=' => \&vnoop, |
|
11349 |
'*=' => \&vnoop, |
|
11350 |
'/=' => \&vnoop, |
|
11351 |
'abs' => \&vnoop, |
|
11352 |
); |
|
11353 |
|
|
11354 |
eval "use warnings"; |
|
11355 |
if ($@) { |
|
11356 |
eval ' |
|
11357 |
package |
|
11358 |
warnings; |
|
11359 |
sub enabled {return $^W;} |
|
11360 |
1; |
|
11361 |
'; |
|
11362 |
} |
|
11363 |
|
|
11364 |
my $VERSION_MAX = 0x7FFFFFFF; |
|
11365 |
|
|
11366 |
# implement prescan_version as closely to the C version as possible |
|
11367 |
use constant TRUE => 1; |
|
11368 |
use constant FALSE => 0; |
|
11369 |
|
|
11370 |
sub isDIGIT { |
|
11371 |
my ($char) = shift->thischar(); |
|
11372 |
return ($char =~ /\d/); |
|
11373 |
} |
|
11374 |
|
|
11375 |
sub isALPHA { |
|
11376 |
my ($char) = shift->thischar(); |
|
11377 |
return ($char =~ /[a-zA-Z]/); |
|
11378 |
} |
|
11379 |
|
|
11380 |
sub isSPACE { |
|
11381 |
my ($char) = shift->thischar(); |
|
11382 |
return ($char =~ /\s/); |
|
11383 |
} |
|
11384 |
|
|
11385 |
sub BADVERSION { |
|
11386 |
my ($s, $errstr, $error) = @_; |
|
11387 |
if ($errstr) { |
|
11388 |
$$errstr = $error; |
|
11389 |
} |
|
11390 |
return $s; |
|
11391 |
} |
|
11392 |
|
|
11393 |
sub prescan_version { |
|
11394 |
my ($s, $strict, $errstr, $sqv, $ssaw_decimal, $swidth, $salpha) = @_; |
|
11395 |
my $qv = defined $sqv ? $$sqv : FALSE; |
|
11396 |
my $saw_decimal = defined $ssaw_decimal ? $$ssaw_decimal : 0; |
|
11397 |
my $width = defined $swidth ? $$swidth : 3; |
|
11398 |
my $alpha = defined $salpha ? $$salpha : FALSE; |
|
11399 |
|
|
11400 |
my $d = $s; |
|
11401 |
|
|
11402 |
if ($qv && isDIGIT($d)) { |
|
11403 |
goto dotted_decimal_version; |
|
11404 |
} |
|
11405 |
|
|
11406 |
if ($d eq 'v') { # explicit v-string |
|
11407 |
$d++; |
|
11408 |
if (isDIGIT($d)) { |
|
11409 |
$qv = TRUE; |
|
11410 |
} |
|
11411 |
else { # degenerate v-string |
|
11412 |
# requires v1.2.3 |
|
11413 |
return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); |
|
11414 |
} |
|
11415 |
|
|
11416 |
dotted_decimal_version: |
|
11417 |
if ($strict && $d eq '0' && isDIGIT($d+1)) { |
|
11418 |
# no leading zeros allowed |
|
11419 |
return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)"); |
|
11420 |
} |
|
11421 |
|
|
11422 |
while (isDIGIT($d)) { # integer part |
|
11423 |
$d++; |
|
11424 |
} |
|
11425 |
|
|
11426 |
if ($d eq '.') |
|
11427 |
{ |
|
11428 |
$saw_decimal++; |
|
11429 |
$d++; # decimal point |
|
11430 |
} |
|
11431 |
else |
|
11432 |
{ |
|
11433 |
if ($strict) { |
|
11434 |
# require v1.2.3 |
|
11435 |
return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); |
|
11436 |
} |
|
11437 |
else { |
|
11438 |
goto version_prescan_finish; |
|
11439 |
} |
|
11440 |
} |
|
11441 |
|
|
11442 |
{ |
|
11443 |
my $i = 0; |
|
11444 |
my $j = 0; |
|
11445 |
while (isDIGIT($d)) { # just keep reading |
|
11446 |
$i++; |
|
11447 |
while (isDIGIT($d)) { |
|
11448 |
$d++; $j++; |
|
11449 |
# maximum 3 digits between decimal |
|
11450 |
if ($strict && $j > 3) { |
|
11451 |
return BADVERSION($s,$errstr,"Invalid version format (maximum 3 digits between decimals)"); |
|
11452 |
} |
|
11453 |
} |
|
11454 |
if ($d eq '_') { |
|
11455 |
if ($strict) { |
|
11456 |
return BADVERSION($s,$errstr,"Invalid version format (no underscores)"); |
|
11457 |
} |
|
11458 |
if ( $alpha ) { |
|
11459 |
return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)"); |
|
11460 |
} |
|
11461 |
$d++; |
|
11462 |
$alpha = TRUE; |
|
11463 |
} |
|
11464 |
elsif ($d eq '.') { |
|
11465 |
if ($alpha) { |
|
11466 |
return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)"); |
|
11467 |
} |
|
11468 |
$saw_decimal++; |
|
11469 |
$d++; |
|
11470 |
} |
|
11471 |
elsif (!isDIGIT($d)) { |
|
11472 |
last; |
|
11473 |
} |
|
11474 |
$j = 0; |
|
11475 |
} |
|
11476 |
|
|
11477 |
if ($strict && $i < 2) { |
|
11478 |
# requires v1.2.3 |
|
11479 |
return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); |
|
11480 |
} |
|
11481 |
} |
|
11482 |
} # end if dotted-decimal |
|
11483 |
else |
|
11484 |
{ # decimal versions |
|
11485 |
my $j = 0; |
|
11486 |
# special $strict case for leading '.' or '0' |
|
11487 |
if ($strict) { |
|
11488 |
if ($d eq '.') { |
|
11489 |
return BADVERSION($s,$errstr,"Invalid version format (0 before decimal required)"); |
|
11490 |
} |
|
11491 |
if ($d eq '0' && isDIGIT($d+1)) { |
|
11492 |
return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)"); |
|
11493 |
} |
|
11494 |
} |
|
11495 |
|
|
11496 |
# and we never support negative version numbers |
|
11497 |
if ($d eq '-') { |
|
11498 |
return BADVERSION($s,$errstr,"Invalid version format (negative version number)"); |
|
11499 |
} |
|
11500 |
|
|
11501 |
# consume all of the integer part |
|
11502 |
while (isDIGIT($d)) { |
|
11503 |
$d++; |
|
11504 |
} |
|
11505 |
|
|
11506 |
# look for a fractional part |
|
11507 |
if ($d eq '.') { |
|
11508 |
# we found it, so consume it |
|
11509 |
$saw_decimal++; |
|
11510 |
$d++; |
|
11511 |
} |
|
11512 |
elsif (!$d || $d eq ';' || isSPACE($d) || $d eq '}') { |
|
11513 |
if ( $d == $s ) { |
|
11514 |
# found nothing |
|
11515 |
return BADVERSION($s,$errstr,"Invalid version format (version required)"); |
|
11516 |
} |
|
11517 |
# found just an integer |
|
11518 |
goto version_prescan_finish; |
|
11519 |
} |
|
11520 |
elsif ( $d == $s ) { |
|
11521 |
# didn't find either integer or period |
|
11522 |
return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)"); |
|
11523 |
} |
|
11524 |
elsif ($d eq '_') { |
|
11525 |
# underscore can't come after integer part |
|
11526 |
if ($strict) { |
|
11527 |
return BADVERSION($s,$errstr,"Invalid version format (no underscores)"); |
|
11528 |
} |
|
11529 |
elsif (isDIGIT($d+1)) { |
|
11530 |
return BADVERSION($s,$errstr,"Invalid version format (alpha without decimal)"); |
|
11531 |
} |
|
11532 |
else { |
|
11533 |
return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)"); |
|
11534 |
} |
|
11535 |
} |
|
11536 |
elsif ($d) { |
|
11537 |
# anything else after integer part is just invalid data |
|
11538 |
return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)"); |
|
11539 |
} |
|
11540 |
|
|
11541 |
# scan the fractional part after the decimal point |
|
11542 |
if ($d && !isDIGIT($d) && ($strict || ! ($d eq ';' || isSPACE($d) || $d eq '}') )) { |
|
11543 |
# $strict or lax-but-not-the-end |
|
11544 |
return BADVERSION($s,$errstr,"Invalid version format (fractional part required)"); |
|
11545 |
} |
|
11546 |
|
|
11547 |
while (isDIGIT($d)) { |
|
11548 |
$d++; $j++; |
|
11549 |
if ($d eq '.' && isDIGIT($d-1)) { |
|
11550 |
if ($alpha) { |
|
11551 |
return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)"); |
|
11552 |
} |
|
11553 |
if ($strict) { |
|
11554 |
return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions must begin with 'v')"); |
|
11555 |
} |
|
11556 |
$d = $s; # start all over again |
|
11557 |
$qv = TRUE; |
|
11558 |
goto dotted_decimal_version; |
|
11559 |
} |
|
11560 |
if ($d eq '_') { |
|
11561 |
if ($strict) { |
|
11562 |
return BADVERSION($s,$errstr,"Invalid version format (no underscores)"); |
|
11563 |
} |
|
11564 |
if ( $alpha ) { |
|
11565 |
return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)"); |
|
11566 |
} |
|
11567 |
if ( ! isDIGIT($d+1) ) { |
|
11568 |
return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)"); |
|
11569 |
} |
|
11570 |
$width = $j; |
|
11571 |
$d++; |
|
11572 |
$alpha = TRUE; |
|
11573 |
} |
|
11574 |
} |
|
11575 |
} |
|
11576 |
|
|
11577 |
version_prescan_finish: |
|
11578 |
while (isSPACE($d)) { |
|
11579 |
$d++; |
|
11580 |
} |
|
11581 |
|
|
11582 |
if ($d && !isDIGIT($d) && (! ($d eq ';' || $d eq '}') )) { |
|
11583 |
# trailing non-numeric data |
|
11584 |
return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)"); |
|
11585 |
} |
|
11586 |
|
|
11587 |
if (defined $sqv) { |
|
11588 |
$$sqv = $qv; |
|
11589 |
} |
|
11590 |
if (defined $swidth) { |
|
11591 |
$$swidth = $width; |
|
11592 |
} |
|
11593 |
if (defined $ssaw_decimal) { |
|
11594 |
$$ssaw_decimal = $saw_decimal; |
|
11595 |
} |
|
11596 |
if (defined $salpha) { |
|
11597 |
$$salpha = $alpha; |
|
11598 |
} |
|
11599 |
return $d; |
|
11600 |
} |
|
11601 |
|
|
11602 |
sub scan_version { |
|
11603 |
my ($s, $rv, $qv) = @_; |
|
11604 |
my $start; |
|
11605 |
my $pos; |
|
11606 |
my $last; |
|
11607 |
my $errstr; |
|
11608 |
my $saw_decimal = 0; |
|
11609 |
my $width = 3; |
|
11610 |
my $alpha = FALSE; |
|
11611 |
my $vinf = FALSE; |
|
11612 |
my @av; |
|
11613 |
|
|
11614 |
$s = new charstar $s; |
|
11615 |
|
|
11616 |
while (isSPACE($s)) { # leading whitespace is OK |
|
11617 |
$s++; |
|
11618 |
} |
|
11619 |
|
|
11620 |
$last = prescan_version($s, FALSE, \$errstr, \$qv, \$saw_decimal, |
|
11621 |
\$width, \$alpha); |
|
11622 |
|
|
11623 |
if ($errstr) { |
|
11624 |
# 'undef' is a special case and not an error |
|
11625 |
if ( $s ne 'undef') { |
|
11626 |
use Carp; |
|
11627 |
Carp::croak($errstr); |
|
11628 |
} |
|
11629 |
} |
|
11630 |
|
|
11631 |
$start = $s; |
|
11632 |
if ($s eq 'v') { |
|
11633 |
$s++; |
|
11634 |
} |
|
11635 |
$pos = $s; |
|
11636 |
|
|
11637 |
if ( $qv ) { |
|
11638 |
$$rv->{qv} = $qv; |
|
11639 |
} |
|
11640 |
if ( $alpha ) { |
|
11641 |
$$rv->{alpha} = $alpha; |
|
11642 |
} |
|
11643 |
if ( !$qv && $width < 3 ) { |
|
11644 |
$$rv->{width} = $width; |
|
11645 |
} |
|
11646 |
|
|
11647 |
while (isDIGIT($pos)) { |
|
11648 |
$pos++; |
|
11649 |
} |
|
11650 |
if (!isALPHA($pos)) { |
|
11651 |
my $rev; |
|
11652 |
|
|
11653 |
for (;;) { |
|
11654 |
$rev = 0; |
|
11655 |
{ |
|
11656 |
# this is atoi() that delimits on underscores |
|
11657 |
my $end = $pos; |
|
11658 |
my $mult = 1; |
|
11659 |
my $orev; |
|
11660 |
|
|
11661 |
# the following if() will only be true after the decimal |
|
11662 |
# point of a version originally created with a bare |
|
11663 |
# floating point number, i.e. not quoted in any way |
|
11664 |
# |
|
11665 |
if ( !$qv && $s > $start && $saw_decimal == 1 ) { |
|
11666 |
$mult *= 100; |
|
11667 |
while ( $s < $end ) { |
|
11668 |
$orev = $rev; |
|
11669 |
$rev += $s * $mult; |
|
11670 |
$mult /= 10; |
|
11671 |
if ( (abs($orev) > abs($rev)) |
|
11672 |
|| (abs($rev) > $VERSION_MAX )) { |
|
11673 |
warn("Integer overflow in version %d", |
|
11674 |
$VERSION_MAX); |
|
11675 |
$s = $end - 1; |
|
11676 |
$rev = $VERSION_MAX; |
|
11677 |
$vinf = 1; |
|
11678 |
} |
|
11679 |
$s++; |
|
11680 |
if ( $s eq '_' ) { |
|
11681 |
$s++; |
|
11682 |
} |
|
11683 |
} |
|
11684 |
} |
|
11685 |
else { |
|
11686 |
while (--$end >= $s) { |
|
11687 |
$orev = $rev; |
|
11688 |
$rev += $end * $mult; |
|
11689 |
$mult *= 10; |
|
11690 |
if ( (abs($orev) > abs($rev)) |
|
11691 |
|| (abs($rev) > $VERSION_MAX )) { |
|
11692 |
warn("Integer overflow in version"); |
|
11693 |
$end = $s - 1; |
|
11694 |
$rev = $VERSION_MAX; |
|
11695 |
$vinf = 1; |
|
11696 |
} |
|
11697 |
} |
|
11698 |
} |
|
11699 |
} |
|
11700 |
|
|
11701 |
# Append revision |
|
11702 |
push @av, $rev; |
|
11703 |
if ( $vinf ) { |
|
11704 |
$s = $last; |
|
11705 |
last; |
|
11706 |
} |
|
11707 |
elsif ( $pos eq '.' ) { |
|
11708 |
$s = ++$pos; |
|
11709 |
} |
|
11710 |
elsif ( $pos eq '_' && isDIGIT($pos+1) ) { |
|
11711 |
$s = ++$pos; |
|
11712 |
} |
|
11713 |
elsif ( $pos eq ',' && isDIGIT($pos+1) ) { |
|
11714 |
$s = ++$pos; |
|
11715 |
} |
|
11716 |
elsif ( isDIGIT($pos) ) { |
|
11717 |
$s = $pos; |
|
11718 |
} |
|
11719 |
else { |
|
11720 |
$s = $pos; |
|
11721 |
last; |
|
11722 |
} |
|
11723 |
if ( $qv ) { |
|
11724 |
while ( isDIGIT($pos) ) { |
|
11725 |
$pos++; |
|
11726 |
} |
|
11727 |
} |
|
11728 |
else { |
|
11729 |
my $digits = 0; |
|
11730 |
while ( ( isDIGIT($pos) || $pos eq '_' ) && $digits < 3 ) { |
|
11731 |
if ( $pos ne '_' ) { |
|
11732 |
$digits++; |
|
11733 |
} |
|
11734 |
$pos++; |
|
11735 |
} |
|
11736 |
} |
|
11737 |
} |
|
11738 |
} |
|
11739 |
if ( $qv ) { # quoted versions always get at least three terms |
|
11740 |
my $len = $#av; |
|
11741 |
# This for loop appears to trigger a compiler bug on OS X, as it |
|
11742 |
# loops infinitely. Yes, len is negative. No, it makes no sense. |
|
11743 |
# Compiler in question is: |
|
11744 |
# gcc version 3.3 20030304 (Apple Computer, Inc. build 1640) |
|
11745 |
# for ( len = 2 - len; len > 0; len-- ) |
|
11746 |
# av_push(MUTABLE_AV(sv), newSViv(0)); |
|
11747 |
# |
|
11748 |
$len = 2 - $len; |
|
11749 |
while ($len-- > 0) { |
|
11750 |
push @av, 0; |
|
11751 |
} |
|
11752 |
} |
|
11753 |
|
|
11754 |
# need to save off the current version string for later |
|
11755 |
if ( $vinf ) { |
|
11756 |
$$rv->{original} = "v.Inf"; |
|
11757 |
$$rv->{vinf} = 1; |
|
11758 |
} |
|
11759 |
elsif ( $s > $start ) { |
|
11760 |
$$rv->{original} = $start->currstr($s); |
|
11761 |
if ( $qv && $saw_decimal == 1 && $start ne 'v' ) { |
|
11762 |
# need to insert a v to be consistent |
|
11763 |
$$rv->{original} = 'v' . $$rv->{original}; |
|
11764 |
} |
|
11765 |
} |
|
11766 |
else { |
|
11767 |
$$rv->{original} = '0'; |
|
11768 |
push(@av, 0); |
|
11769 |
} |
|
11770 |
|
|
11771 |
# And finally, store the AV in the hash |
|
11772 |
$$rv->{version} = \@av; |
|
11773 |
|
|
11774 |
# fix RT#19517 - special case 'undef' as string |
|
11775 |
if ($s eq 'undef') { |
|
11776 |
$s += 5; |
|
11777 |
} |
|
11778 |
|
|
11779 |
return $s; |
|
11780 |
} |
|
11781 |
|
|
11782 |
sub new |
|
11783 |
{ |
|
11784 |
my ($class, $value) = @_; |
|
11785 |
my $self = bless ({}, ref ($class) || $class); |
|
11786 |
my $qv = FALSE; |
|
11787 |
|
|
11788 |
if ( ref($value) && eval('$value->isa("version")') ) { |
|
11789 |
# Can copy the elements directly |
|
11790 |
$self->{version} = [ @{$value->{version} } ]; |
|
11791 |
$self->{qv} = 1 if $value->{qv}; |
|
11792 |
$self->{alpha} = 1 if $value->{alpha}; |
|
11793 |
$self->{original} = ''.$value->{original}; |
|
11794 |
return $self; |
|
11795 |
} |
|
11796 |
|
|
11797 |
my $currlocale = setlocale(LC_ALL); |
|
11798 |
|
|
11799 |
# if the current locale uses commas for decimal points, we |
|
11800 |
# just replace commas with decimal places, rather than changing |
|
11801 |
# locales |
|
11802 |
if ( localeconv()->{decimal_point} eq ',' ) { |
|
11803 |
$value =~ tr/,/./; |
|
11804 |
} |
|
11805 |
|
|
11806 |
if ( not defined $value or $value =~ /^undef$/ ) { |
|
11807 |
# RT #19517 - special case for undef comparison |
|
11808 |
# or someone forgot to pass a value |
|
11809 |
push @{$self->{version}}, 0; |
|
11810 |
$self->{original} = "0"; |
|
11811 |
return ($self); |
|
11812 |
} |
|
11813 |
|
|
11814 |
if ( $#_ == 2 ) { # must be CVS-style |
|
11815 |
$value = $_[2]; |
|
11816 |
$qv = TRUE; |
|
11817 |
} |
|
11818 |
|
|
11819 |
$value = _un_vstring($value); |
|
11820 |
|
|
11821 |
# exponential notation |
|
11822 |
if ( $value =~ /\d+.?\d*e[-+]?\d+/ ) { |
|
11823 |
$value = sprintf("%.9f",$value); |
|
11824 |
$value =~ s/(0+)$//; # trim trailing zeros |
|
11825 |
} |
|
11826 |
|
|
11827 |
my $s = scan_version($value, \$self, $qv); |
|
11828 |
|
|
11829 |
if ($s) { # must be something left over |
|
11830 |
warn("Version string '%s' contains invalid data; " |
|
11831 |
."ignoring: '%s'", $value, $s); |
|
11832 |
} |
|
11833 |
|
|
11834 |
return ($self); |
|
11835 |
} |
|
11836 |
|
|
11837 |
*parse = \&new; |
|
11838 |
|
|
11839 |
sub numify |
|
11840 |
{ |
|
11841 |
my ($self) = @_; |
|
11842 |
unless (_verify($self)) { |
|
11843 |
require Carp; |
|
11844 |
Carp::croak("Invalid version object"); |
|
11845 |
} |
|
11846 |
my $width = $self->{width} || 3; |
|
11847 |
my $alpha = $self->{alpha} || ""; |
|
11848 |
my $len = $#{$self->{version}}; |
|
11849 |
my $digit = $self->{version}[0]; |
|
11850 |
my $string = sprintf("%d.", $digit ); |
|
11851 |
|
|
11852 |
for ( my $i = 1 ; $i < $len ; $i++ ) { |
|
11853 |
$digit = $self->{version}[$i]; |
|
11854 |
if ( $width < 3 ) { |
|
11855 |
my $denom = 10**(3-$width); |
|
11856 |
my $quot = int($digit/$denom); |
|
11857 |
my $rem = $digit - ($quot * $denom); |
|
11858 |
$string .= sprintf("%0".$width."d_%d", $quot, $rem); |
|
11859 |
} |
|
11860 |
else { |
|
11861 |
$string .= sprintf("%03d", $digit); |
|
11862 |
} |
|
11863 |
} |
|
11864 |
|
|
11865 |
if ( $len > 0 ) { |
|
11866 |
$digit = $self->{version}[$len]; |
|
11867 |
if ( $alpha && $width == 3 ) { |
|
11868 |
$string .= "_"; |
|
11869 |
} |
|
11870 |
$string .= sprintf("%0".$width."d", $digit); |
|
11871 |
} |
|
11872 |
else # $len = 0 |
|
11873 |
{ |
|
11874 |
$string .= sprintf("000"); |
|
11875 |
} |
|
11876 |
|
|
11877 |
return $string; |
|
11878 |
} |
|
11879 |
|
|
11880 |
sub normal |
|
11881 |
{ |
|
11882 |
my ($self) = @_; |
|
11883 |
unless (_verify($self)) { |
|
11884 |
require Carp; |
|
11885 |
Carp::croak("Invalid version object"); |
|
11886 |
} |
|
11887 |
my $alpha = $self->{alpha} || ""; |
|
11888 |
my $len = $#{$self->{version}}; |
|
11889 |
my $digit = $self->{version}[0]; |
|
11890 |
my $string = sprintf("v%d", $digit ); |
|
11891 |
|
|
11892 |
for ( my $i = 1 ; $i < $len ; $i++ ) { |
|
11893 |
$digit = $self->{version}[$i]; |
|
11894 |
$string .= sprintf(".%d", $digit); |
|
11895 |
} |
|
11896 |
|
|
11897 |
if ( $len > 0 ) { |
|
11898 |
$digit = $self->{version}[$len]; |
|
11899 |
if ( $alpha ) { |
|
11900 |
$string .= sprintf("_%0d", $digit); |
|
11901 |
} |
|
11902 |
else { |
|
11903 |
$string .= sprintf(".%0d", $digit); |
|
11904 |
} |
|
11905 |
} |
|
11906 |
|
|
11907 |
if ( $len <= 2 ) { |
|
11908 |
for ( $len = 2 - $len; $len != 0; $len-- ) { |
|
11909 |
$string .= sprintf(".%0d", 0); |
|
11910 |
} |
|
11911 |
} |
|
11912 |
|
|
11913 |
return $string; |
|
11914 |
} |
|
11915 |
|
|
11916 |
sub stringify |
|
11917 |
{ |
|
11918 |
my ($self) = @_; |
|
11919 |
unless (_verify($self)) { |
|
11920 |
require Carp; |
|
11921 |
Carp::croak("Invalid version object"); |
|
11922 |
} |
|
11923 |
return exists $self->{original} |
|
11924 |
? $self->{original} |
|
11925 |
: exists $self->{qv} |
|
11926 |
? $self->normal |
|
11927 |
: $self->numify; |
|
11928 |
} |
|
11929 |
|
|
11930 |
sub vcmp |
|
11931 |
{ |
|
11932 |
require UNIVERSAL; |
|
11933 |
my ($left,$right,$swap) = @_; |
|
11934 |
my $class = ref($left); |
|
11935 |
unless ( UNIVERSAL::isa($right, $class) ) { |
|
11936 |
$right = $class->new($right); |
|
11937 |
} |
|
11938 |
|
|
11939 |
if ( $swap ) { |
|
11940 |
($left, $right) = ($right, $left); |
|
11941 |
} |
|
11942 |
unless (_verify($left)) { |
|
11943 |
require Carp; |
|
11944 |
Carp::croak("Invalid version object"); |
|
11945 |
} |
|
11946 |
unless (_verify($right)) { |
|
11947 |
require Carp; |
|
11948 |
Carp::croak("Invalid version format"); |
|
11949 |
} |
|
11950 |
my $l = $#{$left->{version}}; |
|
11951 |
my $r = $#{$right->{version}}; |
|
11952 |
my $m = $l < $r ? $l : $r; |
|
11953 |
my $lalpha = $left->is_alpha; |
|
11954 |
my $ralpha = $right->is_alpha; |
|
11955 |
my $retval = 0; |
|
11956 |
my $i = 0; |
|
11957 |
while ( $i <= $m && $retval == 0 ) { |
|
11958 |
$retval = $left->{version}[$i] <=> $right->{version}[$i]; |
|
11959 |
$i++; |
|
11960 |
} |
|
11961 |
|
|
11962 |
# tiebreaker for alpha with identical terms |
|
11963 |
if ( $retval == 0 |
|
11964 |
&& $l == $r |
|
11965 |
&& $left->{version}[$m] == $right->{version}[$m] |
|
11966 |
&& ( $lalpha || $ralpha ) ) { |
|
11967 |
|
|
11968 |
if ( $lalpha && !$ralpha ) { |
|
11969 |
$retval = -1; |
|
11970 |
} |
|
11971 |
elsif ( $ralpha && !$lalpha) { |
|
11972 |
$retval = +1; |
|
11973 |
} |
|
11974 |
} |
|
11975 |
|
|
11976 |
# possible match except for trailing 0's |
|
11977 |
if ( $retval == 0 && $l != $r ) { |
|
11978 |
if ( $l < $r ) { |
|
11979 |
while ( $i <= $r && $retval == 0 ) { |
|
11980 |
if ( $right->{version}[$i] != 0 ) { |
|
11981 |
$retval = -1; # not a match after all |
|
11982 |
} |
|
11983 |
$i++; |
|
11984 |
} |
|
11985 |
} |
|
11986 |
else { |
|
11987 |
while ( $i <= $l && $retval == 0 ) { |
|
11988 |
if ( $left->{version}[$i] != 0 ) { |
|
11989 |
$retval = +1; # not a match after all |
|
11990 |
} |
|
11991 |
$i++; |
|
11992 |
} |
|
11993 |
} |
|
11994 |
} |
|
11995 |
|
|
11996 |
return $retval; |
|
11997 |
} |
|
11998 |
|
|
11999 |
sub vbool { |
|
12000 |
my ($self) = @_; |
|
12001 |
return vcmp($self,$self->new("0"),1); |
|
12002 |
} |
|
12003 |
|
|
12004 |
sub vnoop { |
|
12005 |
require Carp; |
|
12006 |
Carp::croak("operation not supported with version object"); |
|
12007 |
} |
|
12008 |
|
|
12009 |
sub is_alpha { |
|
12010 |
my ($self) = @_; |
|
12011 |
return (exists $self->{alpha}); |
|
12012 |
} |
|
12013 |
|
|
12014 |
sub qv { |
|
12015 |
my $value = shift; |
|
12016 |
my $class = 'version'; |
|
12017 |
if (@_) { |
|
12018 |
$class = ref($value) || $value; |
|
12019 |
$value = shift; |
|
12020 |
} |
|
12021 |
|
|
12022 |
$value = _un_vstring($value); |
|
12023 |
$value = 'v'.$value unless $value =~ /(^v|\d+\.\d+\.\d)/; |
|
12024 |
my $obj = version->new($value); |
|
12025 |
return bless $obj, $class; |
|
12026 |
} |
|
12027 |
|
|
12028 |
*declare = \&qv; |
|
12029 |
|
|
12030 |
sub is_qv { |
|
12031 |
my ($self) = @_; |
|
12032 |
return (exists $self->{qv}); |
|
12033 |
} |
|
12034 |
|
|
12035 |
|
|
12036 |
sub _verify { |
|
12037 |
my ($self) = @_; |
|
12038 |
if ( ref($self) |
|
12039 |
&& eval { exists $self->{version} } |
|
12040 |
&& ref($self->{version}) eq 'ARRAY' |
|
12041 |
) { |
|
12042 |
return 1; |
|
12043 |
} |
|
12044 |
else { |
|
12045 |
return 0; |
|
12046 |
} |
|
12047 |
} |
|
12048 |
|
|
12049 |
sub _is_non_alphanumeric { |
|
12050 |
my $s = shift; |
|
12051 |
$s = new charstar $s; |
|
12052 |
while ($s) { |
|
12053 |
return 0 if isSPACE($s); # early out |
|
12054 |
return 1 unless (isALPHA($s) || isDIGIT($s) || $s =~ /[.-]/); |
|
12055 |
$s++; |
|
12056 |
} |
|
12057 |
return 0; |
|
12058 |
} |
|
12059 |
|
|
12060 |
sub _un_vstring { |
|
12061 |
my $value = shift; |
|
12062 |
# may be a v-string |
|
12063 |
if ( length($value) >= 3 && $value !~ /[._]/ |
|
12064 |
&& _is_non_alphanumeric($value)) { |
|
12065 |
my $tvalue; |
|
12066 |
if ( $] ge 5.008_001 ) { |
|
12067 |
$tvalue = _find_magic_vstring($value); |
|
12068 |
$value = $tvalue if length $tvalue; |
|
12069 |
} |
|
12070 |
elsif ( $] ge 5.006_000 ) { |
|
12071 |
$tvalue = sprintf("v%vd",$value); |
|
12072 |
if ( $tvalue =~ /^v\d+(\.\d+){2,}$/ ) { |
|
12073 |
# must be a v-string |
|
12074 |
$value = $tvalue; |
|
12075 |
} |
|
12076 |
} |
|
12077 |
} |
|
12078 |
return $value; |
|
12079 |
} |
|
12080 |
|
|
12081 |
sub _find_magic_vstring { |
|
12082 |
my $value = shift; |
|
12083 |
my $tvalue = ''; |
|
12084 |
require B; |
|
12085 |
my $sv = B::svref_2object(\$value); |
|
12086 |
my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef; |
|
12087 |
while ( $magic ) { |
|
12088 |
if ( $magic->TYPE eq 'V' ) { |
|
12089 |
$tvalue = $magic->PTR; |
|
12090 |
$tvalue =~ s/^v?(.+)$/v$1/; |
|
12091 |
last; |
|
12092 |
} |
|
12093 |
else { |
|
12094 |
$magic = $magic->MOREMAGIC; |
|
12095 |
} |
|
12096 |
} |
|
12097 |
return $tvalue; |
|
12098 |
} |
|
12099 |
|
|
12100 |
sub _VERSION { |
|
12101 |
my ($obj, $req) = @_; |
|
12102 |
my $class = ref($obj) || $obj; |
|
12103 |
|
|
12104 |
no strict 'refs'; |
|
12105 |
if ( exists $INC{"$class.pm"} and not %{"$class\::"} and $] >= 5.008) { |
|
12106 |
# file but no package |
|
12107 |
require Carp; |
|
12108 |
Carp::croak( "$class defines neither package nor VERSION" |
|
12109 |
."--version check failed"); |
|
12110 |
} |
|
12111 |
|
|
12112 |
my $version = eval "\$$class\::VERSION"; |
|
12113 |
if ( defined $version ) { |
|
12114 |
local $^W if $] <= 5.008; |
|
12115 |
$version = version::vpp->new($version); |
|
12116 |
} |
|
12117 |
|
|
12118 |
if ( defined $req ) { |
|
12119 |
unless ( defined $version ) { |
|
12120 |
require Carp; |
|
12121 |
my $msg = $] < 5.006 |
|
12122 |
? "$class version $req required--this is only version " |
|
12123 |
: "$class does not define \$$class\::VERSION" |
|
12124 |
."--version check failed"; |
|
12125 |
|
|
12126 |
if ( $ENV{VERSION_DEBUG} ) { |
|
12127 |
Carp::confess($msg); |
|
12128 |
} |
|
12129 |
else { |
|
12130 |
Carp::croak($msg); |
|
12131 |
} |
|
12132 |
} |
|
12133 |
|
|
12134 |
$req = version::vpp->new($req); |
|
12135 |
|
|
12136 |
if ( $req > $version ) { |
|
12137 |
require Carp; |
|
12138 |
if ( $req->is_qv ) { |
|
12139 |
Carp::croak( |
|
12140 |
sprintf ("%s version %s required--". |
|
12141 |
"this is only version %s", $class, |
|
12142 |
$req->normal, $version->normal) |
|
12143 |
); |
|
12144 |
} |
|
12145 |
else { |
|
12146 |
Carp::croak( |
|
12147 |
sprintf ("%s version %s required--". |
|
12148 |
"this is only version %s", $class, |
|
12149 |
$req->stringify, $version->stringify) |
|
12150 |
); |
|
12151 |
} |
|
12152 |
} |
|
12153 |
} |
|
12154 |
|
|
12155 |
return defined $version ? $version->stringify : undef; |
|
12156 |
} |
|
12157 |
|
|
12158 |
1; #this line is important and will help the module return a true value |
|
12159 |
VERSION_VPP |
|
12160 | ||
12161 |
s/^ //mg for values %fatpacked; |
|
12162 | ||
12163 |
unshift @INC, sub { |
|
12164 |
if (my $fat = $fatpacked{$_[1]}) { |
|
12165 |
if ($] < 5.008) { |
|
12166 |
return sub { |
|
12167 |
return 0 unless length $fat; |
|
12168 |
$fat =~ s/^([^\n]*\n?)//; |
|
12169 |
$_ = $1; |
|
12170 |
return 1; |
|
12171 |
}; |
|
12172 |
} |
|
12173 |
open my $fh, '<', \$fat |
|
12174 |
or die "FatPacker error loading $_[1] (could be a perl installation issue?)"; |
|
12175 |
return $fh; |
|
12176 |
} |
|
12177 |
return |
|
12178 |
}; |
|
12179 | ||
12180 |
} # END OF FATPACK CODE |
|
12181 | ||
12182 |
use strict; |
|
12183 |
use App::cpanminus::script; |
|
12184 | ||
12185 |
unless (caller) { |
|
12186 |
my $app = App::cpanminus::script->new; |
|
12187 |
$app->parse_options(@ARGV); |
|
12188 |
$app->doit or exit(1); |
|
12189 |
} |
|
12190 | ||
12191 |
__END__ |
|
12192 | ||
12193 |
=head1 NAME |
|
12194 | ||
12195 |
cpanm - get, unpack build and install modules from CPAN |
|
12196 | ||
12197 |
=head1 SYNOPSIS |
|
12198 | ||
12199 |
cpanm Test::More # install Test::More |
|
12200 |
cpanm MIYAGAWA/Plack-0.99_05.tar.gz # full distribution path |
|
12201 |
cpanm http://example.org/LDS/CGI.pm-3.20.tar.gz # install from URL |
|
12202 |
cpanm ~/dists/MyCompany-Enterprise-1.00.tar.gz # install from a local file |
|
12203 |
cpanm --interactive Task::Kensho # Configure interactively |
|
12204 |
cpanm . # install from local directory |
|
12205 |
cpanm --installdeps . # install all the deps for the current directory |
|
12206 |
cpanm -L extlib Plack # install Plack and all non-core deps into extlib |
|
12207 |
cpanm --mirror http://cpan.cpantesters.org/ DBI # use the fast-syncing mirror |
|
12208 |
cpanm --scandeps Moose # See what modules will be installed for Moose |
|
12209 | ||
12210 |
=head1 COMMANDS |
|
12211 | ||
12212 |
=over 4 |
|
12213 | ||
12214 |
=item (arguments) |
|
12215 | ||
12216 |
Command line arguments can be either a module name, distribution file, |
|
12217 |
local file path, HTTP URL or git repository URL. Following commands |
|
12218 |
will all work as you expect. |
|
12219 | ||
12220 |
cpanm Plack |
|
12221 |
cpanm Plack/Request.pm |
|
12222 |
cpanm MIYAGAWA/Plack-1.0000.tar.gz |
|
12223 |
cpanm /path/to/Plack-1.0000.tar.gz |
|
12224 |
cpanm http://cpan.metacpan.org/authors/id/M/MI/MIYAGAWA/Plack-0.9990.tar.gz |
|
12225 |
cpanm git://github.com/miyagawa/Plack.git |
|
12226 | ||
12227 |
Additionally, you can use the notation using C<~> and C<@> to specify |
|
12228 |
version for a given module. C<~> specifies the version requirement in |
|
12229 |
the L<CPAN::Meta::Spec> format, while C<@> pins the exact version, and |
|
12230 |
is a shortcut for C<~"== VERSION">. |
|
12231 | ||
12232 |
cpanm Plack~1.0000 # 1.0000 or later |
|
12233 |
cpanm Plack~">= 1.0000, < 2.0000" # latest of 1.xxxx |
|
12234 |
cpanm Plack@0.9990 # specific version. same as Plack~"== 0.9990" |
|
12235 | ||
12236 |
The version query including specific version or range will be sent to |
|
12237 |
L<MetaCPAN> to search for previous releases. The query will search for |
|
12238 |
BackPAN archives by default, unless you specify C<--dev> option, in |
|
12239 |
which case, archived versions will be filtered out. |
|
12240 | ||
12241 |
For a git repository, you can specify a branch, tag, or commit SHA to |
|
12242 |
build. The default is C<master> |
|
12243 | ||
12244 |
cpanm git://github.com/miyagawa/Plack.git@1.0000 # tag |
|
12245 |
cpanm git://github.com/miyagawa/Plack.git@devel # branch |
|
12246 | ||
12247 |
=item -i, --install |
|
12248 | ||
12249 |
Installs the modules. This is a default behavior and this is just a |
|
12250 |
compatibility option to make it work like L<cpan> or L<cpanp>. |
|
12251 | ||
12252 |
=item --self-upgrade |
|
12253 | ||
12254 |
Upgrades itself. It's just an alias for: |
|
12255 | ||
12256 |
cpanm App::cpanminus |
|
12257 | ||
12258 |
=item --info |
|
12259 | ||
12260 |
Displays the distribution information in |
|
12261 |
C<AUTHOR/Dist-Name-ver.tar.gz> format in the standard out. |
|
12262 | ||
12263 |
=item --installdeps |
|
12264 | ||
12265 |
Installs the dependencies of the target distribution but won't build |
|
12266 |
itself. Handy if you want to try the application from a version |
|
12267 |
controlled repository such as git. |
|
12268 | ||
12269 |
cpanm --installdeps . |
|
12270 | ||
12271 |
=item --look |
|
12272 | ||
12273 |
Download and unpack the distribution and then open the directory with |
|
12274 |
your shell. Handy to poke around the source code or do manual |
|
12275 |
testing. |
|
12276 | ||
12277 |
=item -h, --help |
|
12278 | ||
12279 |
Displays the help message. |
|
12280 | ||
12281 |
=item -V, --version |
|
12282 | ||
12283 |
Displays the version number. |
|
12284 | ||
12285 |
=back |
|
12286 | ||
12287 |
=head1 OPTIONS |
|
12288 | ||
12289 |
You can specify the default options in C<PERL_CPANM_OPT> environment variable. |
|
12290 | ||
12291 |
=over 4 |
|
12292 | ||
12293 |
=item -f, --force |
|
12294 | ||
12295 |
Force install modules even when testing failed. |
|
12296 | ||
12297 |
=item -n, --notest |
|
12298 | ||
12299 |
Skip the testing of modules. Use this only when you just want to save |
|
12300 |
time for installing hundreds of distributions to the same perl and |
|
12301 |
architecture you've already tested to make sure it builds fine. |
|
12302 | ||
12303 |
Defaults to false, and you can say C<--no-notest> to override when it |
|
12304 |
is set in the default options in C<PERL_CPANM_OPT>. |
|
12305 | ||
12306 |
=item --test-only |
|
12307 | ||
12308 |
Run the tests only, and do not install the specified module or |
|
12309 |
distributions. Handy if you want to verify the new (or even old) |
|
12310 |
releases pass its unit tests without installing the module. |
|
12311 | ||
12312 |
Note that if you specify this option with a module or distribution |
|
12313 |
that has dependencies, these dependencies will be installed if you |
|
12314 |
don't currently have them. |
|
12315 | ||
12316 |
=item -S, --sudo |
|
12317 | ||
12318 |
Switch to the root user with C<sudo> when installing modules. Use this |
|
12319 |
if you want to install modules to the system perl include path. |
|
12320 | ||
12321 |
Defaults to false, and you can say C<--no-sudo> to override when it is |
|
12322 |
set in the default options in C<PERL_CPANM_OPT>. |
|
12323 | ||
12324 |
=item -v, --verbose |
|
12325 | ||
12326 |
Makes the output verbose. It also enables the interactive |
|
12327 |
configuration. (See --interactive) |
|
12328 | ||
12329 |
=item -q, --quiet |
|
12330 | ||
12331 |
Makes the output even more quiet than the default. It doesn't print |
|
12332 |
anything to the STDERR. |
|
12333 | ||
12334 |
=item -l, --local-lib |
|
12335 | ||
12336 |
Sets the L<local::lib> compatible path to install modules to. You |
|
12337 |
don't need to set this if you already configure the shell environment |
|
12338 |
variables using L<local::lib>, but this can be used to override that |
|
12339 |
as well. |
|
12340 | ||
12341 |
=item -L, --local-lib-contained |
|
12342 | ||
12343 |
Same with C<--local-lib> but when examining the dependencies, it |
|
12344 |
assumes no non-core modules are installed on the system. It's handy if |
|
12345 |
you want to bundle application dependencies in one directory so you |
|
12346 |
can distribute to other machines. |
|
12347 | ||
12348 |
For instance, |
|
12349 | ||
12350 |
cpanm -L extlib Plack |
|
12351 | ||
12352 |
would install Plack and all of its non-core dependencies into the |
|
12353 |
directory C<extlib>, which can be loaded from your application with: |
|
12354 | ||
12355 |
use local::lib '/path/to/extlib'; |
|
12356 | ||
12357 |
=item --mirror |
|
12358 | ||
12359 |
Specifies the base URL for the CPAN mirror to use, such as |
|
12360 |
C<http://cpan.cpantesters.org/> (you can omit the trailing slash). You |
|
12361 |
can specify multiple mirror URLs by repeating the command line option. |
|
12362 | ||
12363 |
You can use a local directory that has a CPAN mirror structure |
|
12364 |
(created by tools such as L<OrePAN> or L<Pinto>) by using a special |
|
12365 |
URL scheme C<file://>. If the given URL begins with `/` (without any |
|
12366 |
scheme), it is considered as a file scheme as well. |
|
12367 | ||
12368 |
cpanm --mirror file:///path/to/mirror |
|
12369 |
cpanm --mirror ~/minicpan # Because shell expands ~ to /home/user |
|
12370 | ||
12371 |
Defaults to C<http://search.cpan.org/CPAN> which is a geo location |
|
12372 |
aware redirector. |
|
12373 | ||
12374 |
=item --mirror-only |
|
12375 | ||
12376 |
Download the mirror's 02packages.details.txt.gz index file instead of |
|
12377 |
querying the CPAN Meta DB. |
|
12378 | ||
12379 |
Select this option if you are using a local mirror of CPAN, such as |
|
12380 |
minicpan when you're offline, or your own CPAN index (a.k.a darkpan). |
|
12381 | ||
12382 |
B<Tip:> It might be useful if you name these mirror options with your |
|
12383 |
shell aliases, like: |
|
12384 | ||
12385 |
alias minicpanm='cpanm --mirror ~/minicpan --mirror-only' |
|
12386 |
alias darkpan='cpanm --mirror http://mycompany.example.com/DPAN --mirror-only' |
|
12387 | ||
12388 |
=item --mirror-index |
|
12389 | ||
12390 |
B<EXPERIMENTAL>: Specifies the file path to C<02packages.details.txt> |
|
12391 |
for module search index. |
|
12392 | ||
12393 |
=item --prompt |
|
12394 | ||
12395 |
Prompts when a test fails so that you can skip, force install, retry |
|
12396 |
or look in the shell to see what's going wrong. It also prompts when |
|
12397 |
one of the dependency failed if you want to proceed the installation. |
|
12398 | ||
12399 |
Defaults to false, and you can say C<--no-prompt> to override if it's |
|
12400 |
set in the default options in C<PERL_CPANM_OPT>. |
|
12401 | ||
12402 |
=item --dev |
|
12403 | ||
12404 |
B<EXPERIMENTAL>: search for a newer developer release as well. Defaults to false. |
|
12405 | ||
12406 |
=item --reinstall |
|
12407 | ||
12408 |
cpanm, when given a module name in the command line (i.e. C<cpanm |
|
12409 |
Plack>), checks the locally installed version first and skips if it is |
|
12410 |
already installed. This option makes it skip the check, so: |
|
12411 | ||
12412 |
cpanm --reinstall Plack |
|
12413 | ||
12414 |
would reinstall L<Plack> even if your locally installed version is |
|
12415 |
latest, or even newer (which would happen if you install a developer |
|
12416 |
release from version control repositories). |
|
12417 | ||
12418 |
Defaults to false. |
|
12419 | ||
12420 |
=item --interactive |
|
12421 | ||
12422 |
Makes the configuration (such as C<Makefile.PL> and C<Build.PL>) |
|
12423 |
interactive, so you can answer questions in the distribution that |
|
12424 |
requires custom configuration or Task:: distributions. |
|
12425 | ||
12426 |
Defaults to false, and you can say C<--no-interactive> to override |
|
12427 |
when it's set in the default options in C<PERL_CPANM_OPT>. |
|
12428 | ||
12429 |
=item --scandeps |
|
12430 | ||
12431 |
Scans the depencencies of given modules and output the tree in a text |
|
12432 |
format. (See C<--format> below for more options) |
|
12433 | ||
12434 |
Because this command doesn't actually install any distributions, it |
|
12435 |
will be useful that by typing: |
|
12436 | ||
12437 |
cpanm --scandeps Catalyst::Runtime |
|
12438 | ||
12439 |
you can make sure what modules will be installed. |
|
12440 | ||
12441 |
This command takes into account which modules you already have |
|
12442 |
installed in your system. If you want to see what modules will be |
|
12443 |
installed against a vanilla perl installation, you might want to |
|
12444 |
combine it with C<-L> option. |
|
12445 | ||
12446 |
=item --format |
|
12447 | ||
12448 |
Determines what format to display the scanned dependency |
|
12449 |
tree. Available options are C<tree>, C<json>, C<yaml> and C<dists>. |
|
12450 | ||
12451 |
=over 8 |
|
12452 | ||
12453 |
=item tree |
|
12454 | ||
12455 |
Displays the tree in a plain text format. This is the default value. |
|
12456 | ||
12457 |
=item json, yaml |
|
12458 | ||
12459 |
Outputs the tree in a JSON or YAML format. L<JSON> and L<YAML> modules |
|
12460 |
need to be installed respectively. The output tree is represented as a |
|
12461 |
recursive tuple of: |
|
12462 | ||
12463 |
[ distribution, dependencies ] |
|
12464 | ||
12465 |
and the container is an array containing the root elements. Note that |
|
12466 |
there may be multiple root nodes, since you can give multiple modules |
|
12467 |
to the C<--scandeps> command. |
|
12468 | ||
12469 |
=item dists |
|
12470 | ||
12471 |
C<dists> is a special output format, where it prints the distribution |
|
12472 |
filename in the I<depth first order> after the dependency resolution, |
|
12473 |
like: |
|
12474 | ||
12475 |
GAAS/MIME-Base64-3.13.tar.gz |
|
12476 |
GAAS/URI-1.58.tar.gz |
|
12477 |
PETDANCE/HTML-Tagset-3.20.tar.gz |
|
12478 |
GAAS/HTML-Parser-3.68.tar.gz |
|
12479 |
GAAS/libwww-perl-5.837.tar.gz |
|
12480 | ||
12481 |
which means you can install these distributions in this order without |
|
12482 |
extra dependencies. When combined with C<-L> option, it will be useful |
|
12483 |
to replay installations on other machines. |
|
12484 | ||
12485 |
=back |
|
12486 | ||
12487 |
=item --save-dists |
|
12488 | ||
12489 |
Specifies the optional directory path to copy downloaded tarballs in |
|
12490 |
the CPAN mirror compatible directory structure |
|
12491 |
i.e. I<authors/id/A/AU/AUTHORS/Foo-Bar-version.tar.gz> |
|
12492 | ||
12493 |
=item --uninst-shadows |
|
12494 | ||
12495 |
Uninstalls the shadow files of the distribution that you're |
|
12496 |
installing. This eliminates the confusion if you're trying to install |
|
12497 |
core (dual-life) modules from CPAN against perl 5.10 or older, or |
|
12498 |
modules that used to be XS-based but switched to pure perl at some |
|
12499 |
version. |
|
12500 | ||
12501 |
If you run cpanm as root and use C<INSTALL_BASE> or equivalent to |
|
12502 |
specify custom installation path, you SHOULD disable this option so |
|
12503 |
you won't accidentally uninstall dual-life modules from the core |
|
12504 |
include path. |
|
12505 | ||
12506 |
Defaults to true if your perl version is smaller than 5.12, and you |
|
12507 |
can disable that with C<--no-uninst-shadows>. |
|
12508 | ||
12509 |
B<NOTE>: Since version 1.3000 this flag is turned off by default for |
|
12510 |
perl newer than 5.12, since with 5.12 @INC contains site_perl directory |
|
12511 |
I<before> the perl core library path, and uninstalling shadows is not |
|
12512 |
necessary anymore and does more harm by deleting files from the core |
|
12513 |
library path. |
|
12514 | ||
12515 |
=item --cascade-search |
|
12516 | ||
12517 |
B<EXPERIMENTAL>: Specifies whether to cascade search when you specify |
|
12518 |
multiple mirrors and a mirror doesn't have a module or has a lower |
|
12519 |
version of the module than requested. Defaults to false. |
|
12520 | ||
12521 |
=item --skip-installed |
|
12522 | ||
12523 |
Specifies whether a module given in the command line is skipped if its latest |
|
12524 |
version is already installed. Defaults to true. |
|
12525 | ||
12526 |
B<NOTE>: The C<PERL5LIB> environment variable have to be correctly set for this |
|
12527 |
to work with modules installed using L<local::lib>. |
|
12528 | ||
12529 |
=item --skip-satisfied |
|
12530 | ||
12531 |
B<EXPERIMENTAL>: Specifies whether a module (and version) given in the |
|
12532 |
command line is skipped if it's already installed. |
|
12533 | ||
12534 |
If you run: |
|
12535 | ||
12536 |
cpanm --skip-satisfied CGI DBI~1.2 |
|
12537 | ||
12538 |
cpanm won't install them if you already have CGI (for whatever |
|
12539 |
versions) or have DBI with version higher than 1.2. It is similar to |
|
12540 |
C<--skip-installed> but while C<--skip-installed> checks if the |
|
12541 |
I<latest> version of CPAN is installed, C<--skip-satisfied> checks if |
|
12542 |
a requested version (or not, which means any version) is installed. |
|
12543 | ||
12544 |
Defaults to false. |
|
12545 | ||
12546 |
=item --verify |
|
12547 | ||
12548 |
Verify the integrity of distribution files retrieved from PAUSE using |
|
12549 |
CHECKSUMS and SIGNATURES (if found). Defaults to false. |
|
12550 | ||
12551 |
=item --auto-cleanup |
|
12552 | ||
12553 |
Specifies the number of days in which cpanm's work directories |
|
12554 |
expire. Defaults to 7, which means old work directories will be |
|
12555 |
cleaned up in one week. |
|
12556 | ||
12557 |
You can set the value to C<0> to make cpan never cleanup those |
|
12558 |
directories. |
|
12559 | ||
12560 |
=item --man-pages |
|
12561 | ||
12562 |
Generates man pages for executables (man1) and libraries (man3). |
|
12563 | ||
12564 |
Defaults to false (no man pages generated) if |
|
12565 |
C<-L|--local-lib-contained> option is supplied. Otherwise, defaults to |
|
12566 |
true, and you can disable it with C<--no-man-pages>. |
|
12567 | ||
12568 |
=item --lwp |
|
12569 | ||
12570 |
Uses L<LWP> module to download stuff over HTTP. Defaults to true, and |
|
12571 |
you can say C<--no-lwp> to disable using LWP, when you want to upgrade |
|
12572 |
LWP from CPAN on some broken perl systems. |
|
12573 | ||
12574 |
=item --wget |
|
12575 | ||
12576 |
Uses GNU Wget (if available) to download stuff. Defaults to true, and |
|
12577 |
you can say C<--no-wget> to disable using Wget (versions of Wget older |
|
12578 |
than 1.9 don't support the C<--retry-connrefused> option used by cpanm). |
|
12579 | ||
12580 |
=item --curl |
|
12581 | ||
12582 |
Uses cURL (if available) to download stuff. Defaults to true, and |
|
12583 |
you can say C<--no-curl> to disable using cURL. |
|
12584 | ||
12585 |
Normally with C<--lwp>, C<--wget> and C<--curl> options set to true |
|
12586 |
(which is the default) cpanm tries L<LWP>, Wget, cURL and L<HTTP::Tiny> |
|
12587 |
(in that order) and uses the first one available. |
|
12588 | ||
12589 |
=back |
|
12590 | ||
12591 |
=head1 SEE ALSO |
|
12592 | ||
12593 |
L<App::cpanminus> |
|
12594 | ||
12595 |
=head1 COPYRIGHT |
|
12596 | ||
12597 |
Copyright 2010 Tatsuhiko Miyagawa. |
|
12598 | ||
12599 |
=head1 AUTHOR |
|
12600 | ||
12601 |
Tatsuhiko Miyagawa |
|
12602 | ||
12603 |
=cut |