...
|
...
|
@@ -1,481 +1,35 @@
|
1
|
1
|
#!/usr/bin/env perl
|
2
|
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.
|
|
3
|
+# This is a pre-compiled source code for the cpanm (cpanminus) program.
|
|
4
|
+# For more details about how to install cpanm, go to the following URL:
|
6
|
5
|
#
|
7
|
|
-# % curl -L http://cpanmin.us | perl - --self-upgrade
|
|
6
|
+# https://github.com/miyagawa/cpanminus
|
8
|
7
|
#
|
9
|
|
-# If you don't have curl but wget, replace `curl -L` with `wget -O -`.
|
|
8
|
+# Quickstart: Run the following command and it will install itself for
|
|
9
|
+# you. You might want to run it as a root with sudo if you want to install
|
|
10
|
+# to places like /usr/local/bin.
|
10
|
11
|
#
|
11
|
|
-# For more details about this program, visit http://search.cpan.org/dist/App-cpanminus
|
|
12
|
+# % curl -L https://cpanmin.us | perl - App::cpanminus
|
12
|
13
|
#
|
|
14
|
+# If you don't have curl but wget, replace `curl -L` with `wget -O -`.
|
|
15
|
+
|
13
|
16
|
# DO NOT EDIT -- this is an auto generated file
|
|
17
|
+
|
14
|
18
|
# This chunk of stuff was generated by App::FatPacker. To find the original
|
15
|
19
|
# file's code, look for the end of this BEGIN block or the string 'FATPACK'
|
16
|
20
|
BEGIN {
|
17
|
21
|
my %fatpacked;
|
18
|
22
|
|
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;
|
|
23
|
+$fatpacked{"App/cpanminus.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_CPANMINUS';
|
|
24
|
+ package App::cpanminus;our$VERSION="1.7040";1;
|
306
|
25
|
APP_CPANMINUS
|
307
|
26
|
|
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;
|
|
27
|
+$fatpacked{"App/cpanminus/Dependency.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_CPANMINUS_DEPENDENCY';
|
|
28
|
+ package App::cpanminus::Dependency;use strict;use CPAN::Meta::Requirements;sub from_prereqs {my($class,$prereqs,$phases,$types)=@_;my@deps;for my$type (@$types){push@deps,$class->from_versions($prereqs->merged_requirements($phases,[$type])->as_string_hash,$type,)}return@deps}sub from_versions {my($class,$versions,$type)=@_;my@deps;while (my($module,$version)=each %$versions){push@deps,$class->new($module,$version,$type)}@deps}sub merge_with {my($self,$requirements)=@_;$self->{original_version}=$self->version;eval {$requirements->add_string_requirement($self->module,$self->version)};if ($@ =~ /illegal requirements/){warn sprintf("Can't merge requirements for %s: '%s' and '%s'",$self->module,$self->version,$requirements->requirements_for_module($self->module))}$self->{version}=$requirements->requirements_for_module($self->module)}sub new {my($class,$module,$version,$type)=@_;bless {module=>$module,version=>$version,type=>$type || 'requires',},$class}sub module {$_[0]->{module}}sub version {$_[0]->{version}}sub type {$_[0]->{type}}sub requires_version {my$self=shift;if (defined$self->{original_version}){return$self->{original_version}}$self->version}sub is_requirement {$_[0]->{type}eq 'requires'}1;
|
|
29
|
+APP_CPANMINUS_DEPENDENCY
|
|
30
|
+
|
|
31
|
+$fatpacked{"App/cpanminus/script.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_CPANMINUS_SCRIPT';
|
|
32
|
+ package App::cpanminus::script;use strict;use Config;use Cwd ();use App::cpanminus;use App::cpanminus::Dependency;use File::Basename ();use File::Find ();use File::Path ();use File::Spec ();use File::Copy ();use File::Temp ();use Getopt::Long ();use Symbol ();use String::ShellQuote ();use version ();use constant WIN32=>$^O eq 'MSWin32';use constant BAD_TAR=>($^O eq 'solaris' || $^O eq 'hpux');use constant CAN_SYMLINK=>eval {symlink("","");1};our$VERSION=$App::cpanminus::VERSION;if ($INC{"App/FatPacker/Trace.pm"}){require version::vpp}my$quote=WIN32 ? q/"/ : q/'/;sub agent {my$self=shift;my$agent="cpanminus/$VERSION";$agent .= " perl/$]" if$self->{report_perl_version};$agent}sub determine_home {my$class=shift;my$homedir=$ENV{HOME}|| eval {require File::HomeDir;File::HomeDir->my_home}|| join('',@ENV{qw(HOMEDRIVE HOMEPATH)});if (WIN32){require Win32;$homedir=Win32::GetShortPathName($homedir)}return "$homedir/.cpanm"}sub new {my$class=shift;bless {home=>$class->determine_home,cmd=>'install',seen=>{},notest=>undef,test_only=>undef,installdeps=>undef,force=>undef,sudo=>undef,make=>undef,verbose=>undef,quiet=>undef,interactive=>undef,log=>undef,mirrors=>[],mirror_only=>undef,mirror_index=>undef,cpanmetadb=>"http://cpanmetadb.plackperl.org/v1.0/",perl=>$^X,argv=>[],local_lib=>undef,self_contained=>undef,exclude_vendor=>undef,prompt_timeout=>0,prompt=>undef,configure_timeout=>60,build_timeout=>3600,test_timeout=>1800,try_lwp=>1,try_wget=>1,try_curl=>1,uninstall_shadows=>($] < 5.012),skip_installed=>1,skip_satisfied=>0,auto_cleanup=>7,pod2man=>1,installed_dists=>0,install_types=>['requires'],with_develop=>0,showdeps=>0,scandeps=>0,scandeps_tree=>[],format=>'tree',save_dists=>undef,skip_configure=>0,verify=>0,report_perl_version=>!$class->maybe_ci,build_args=>{},features=>{},pure_perl=>0,cpanfile_path=>'cpanfile',@_,},$class}sub env {my($self,$key)=@_;$ENV{"PERL_CPANM_" .$key}}sub maybe_ci {my$class=shift;grep$ENV{$_},qw(TRAVIS CI AUTOMATED_TESTING AUTHOR_TESTING)}sub install_type_handlers {my$self=shift;my@handlers;for my$type (qw(recommends suggests)){push@handlers,"with-$type"=>sub {my%uniq;$self->{install_types}=[grep!$uniq{$_}++,@{$self->{install_types}},$type ]};push@handlers,"without-$type"=>sub {$self->{install_types}=[grep $_ ne $type,@{$self->{install_types}}]}}@handlers}sub build_args_handlers {my$self=shift;my@handlers;for my$phase (qw(configure build test install)){push@handlers,"$phase-args=s"=>\($self->{build_args}{$phase})}@handlers}sub parse_options {my$self=shift;local@ARGV=@{$self->{argv}};push@ARGV,grep length,split /\s+/,$self->env('OPT');push@ARGV,@_;Getopt::Long::Configure("bundling");Getopt::Long::GetOptions('f|force'=>sub {$self->{skip_installed}=0;$self->{force}=1},'n|notest!'=>\$self->{notest},'test-only'=>sub {$self->{notest}=0;$self->{skip_installed}=0;$self->{test_only}=1},'S|sudo!'=>\$self->{sudo},'v|verbose'=>\$self->{verbose},'verify!'=>\$self->{verify},'q|quiet!'=>\$self->{quiet},'h|help'=>sub {$self->{action}='show_help'},'V|version'=>sub {$self->{action}='show_version'},'perl=s'=>sub {$self->diag("--perl is deprecated since it's known to be fragile in figuring out dependencies. Run `$_[1] -S cpanm` instead.\n",1);$self->{perl}=$_[1]},'l|local-lib=s'=>sub {$self->{local_lib}=$self->maybe_abs($_[1])},'L|local-lib-contained=s'=>sub {$self->{local_lib}=$self->maybe_abs($_[1]);$self->{self_contained}=1;$self->{pod2man}=undef},'self-contained!'=>\$self->{self_contained},'exclude-vendor!'=>\$self->{exclude_vendor},'mirror=s@'=>$self->{mirrors},'mirror-only!'=>\$self->{mirror_only},'mirror-index=s'=>sub {$self->{mirror_index}=$self->maybe_abs($_[1])},'M|from=s'=>sub {$self->{mirrors}=[$_[1]];$self->{mirror_only}=1},'cpanmetadb=s'=>\$self->{cpanmetadb},'cascade-search!'=>\$self->{cascade_search},'prompt!'=>\$self->{prompt},'installdeps'=>\$self->{installdeps},'skip-installed!'=>\$self->{skip_installed},'skip-satisfied!'=>\$self->{skip_satisfied},'reinstall'=>sub {$self->{skip_installed}=0},'interactive!'=>\$self->{interactive},'i|install'=>sub {$self->{cmd}='install'},'info'=>sub {$self->{cmd}='info'},'look'=>sub {$self->{cmd}='look';$self->{skip_installed}=0},'U|uninstall'=>sub {$self->{cmd}='uninstall'},'self-upgrade'=>sub {$self->{action}='self_upgrade'},'uninst-shadows!'=>\$self->{uninstall_shadows},'lwp!'=>\$self->{try_lwp},'wget!'=>\$self->{try_wget},'curl!'=>\$self->{try_curl},'auto-cleanup=s'=>\$self->{auto_cleanup},'man-pages!'=>\$self->{pod2man},'scandeps'=>\$self->{scandeps},'showdeps'=>sub {$self->{showdeps}=1;$self->{skip_installed}=0},'format=s'=>\$self->{format},'save-dists=s'=>sub {$self->{save_dists}=$self->maybe_abs($_[1])},'skip-configure!'=>\$self->{skip_configure},'dev!'=>\$self->{dev_release},'metacpan!'=>\$self->{metacpan},'report-perl-version!'=>\$self->{report_perl_version},'configure-timeout=i'=>\$self->{configure_timeout},'build-timeout=i'=>\$self->{build_timeout},'test-timeout=i'=>\$self->{test_timeout},'with-develop'=>\$self->{with_develop},'without-develop'=>sub {$self->{with_develop}=0},'with-feature=s'=>sub {$self->{features}{$_[1]}=1},'without-feature=s'=>sub {$self->{features}{$_[1]}=0},'with-all-features'=>sub {$self->{features}{__all}=1},'pp|pureperl!'=>\$self->{pure_perl},"cpanfile=s"=>\$self->{cpanfile_path},$self->install_type_handlers,$self->build_args_handlers,);if (!@ARGV && $0 ne '-' &&!-t STDIN){push@ARGV,$self->load_argv_from_fh(\*STDIN);$self->{load_from_stdin}=1}$self->{argv}=\@ARGV}sub check_upgrade {my$self=shift;my$install_base=$ENV{PERL_LOCAL_LIB_ROOT}? $self->local_lib_target($ENV{PERL_LOCAL_LIB_ROOT}): $Config{installsitebin};if ($0 eq '-'){return}elsif ($0 !~ /^$install_base/){if ($0 =~ m!perlbrew/bin!){die <<DIE}else {die <<DIE}}}sub check_libs {my$self=shift;return if$self->{_checked}++;$self->bootstrap_local_lib}sub setup_verify {my$self=shift;my$has_modules=eval {require Module::Signature;require Digest::SHA;1};$self->{cpansign}=$self->which('cpansign');unless ($has_modules && $self->{cpansign}){warn "WARNING: Module::Signature and Digest::SHA is required for distribution verifications.\n";$self->{verify}=0}}sub parse_module_args {my($self,$module)=@_;$module =~ s/^([A-Za-z0-9_:]+)@([v\d\._]+)$/$1~== $2/;if ($module =~ /\~[v\d\._,\!<>= ]+$/){return split /\~/,$module,2}else {return$module,undef}}sub doit {my$self=shift;my$code;eval {$code=($self->_doit==0)};if (my$e=$@){warn$e;$code=1}return$code}sub _doit {my$self=shift;$self->setup_home;$self->init_tools;$self->setup_verify if$self->{verify};if (my$action=$self->{action}){$self->$action()and return 1}return$self->show_help(1)unless @{$self->{argv}}or $self->{load_from_stdin};$self->configure_mirrors;my$cwd=Cwd::cwd;my@fail;for my$module (@{$self->{argv}}){if ($module =~ s/\.pm$//i){my ($volume,$dirs,$file)=File::Spec->splitpath($module);$module=join '::',grep {$_}File::Spec->splitdir($dirs),$file}($module,my$version)=$self->parse_module_args($module);$self->chdir($cwd);if ($self->{cmd}eq 'uninstall'){$self->uninstall_module($module)or push@fail,$module}else {$self->install_module($module,0,$version)or push@fail,$module}}if ($self->{base}&& $self->{auto_cleanup}){$self->cleanup_workdirs}if ($self->{installed_dists}){my$dists=$self->{installed_dists}> 1 ? "distributions" : "distribution";$self->diag("$self->{installed_dists} $dists installed\n",1)}if ($self->{scandeps}){$self->dump_scandeps()}$self->chdir($cwd);return!@fail}sub setup_home {my$self=shift;$self->{home}=$self->env('HOME')if$self->env('HOME');unless (_writable($self->{home})){die "Can't write to cpanm home '$self->{home}': You should fix it with chown/chmod first.\n"}$self->{base}="$self->{home}/work/" .time .".$$";File::Path::mkpath([$self->{base}],0,0777);$self->{log}=File::Spec->catfile($self->{base},"build.log");my$final_log="$self->{home}/build.log";{open my$out,">$self->{log}" or die "$self->{log}: $!"}if (CAN_SYMLINK){my$build_link="$self->{home}/latest-build";unlink$build_link;symlink$self->{base},$build_link;unlink$final_log;symlink$self->{log},$final_log}else {my$log=$self->{log};my$home=$self->{home};$self->{at_exit}=sub {my$self=shift;my$temp_log="$home/build.log." .time .".$$";File::Copy::copy($log,$temp_log)&& unlink($final_log);rename($temp_log,$final_log)}}$self->chat("cpanm (App::cpanminus) $VERSION on perl $] built for $Config{archname}\n" ."Work directory is $self->{base}\n")}sub package_index_for {my ($self,$mirror)=@_;return$self->source_for($mirror)."/02packages.details.txt"}sub generate_mirror_index {my ($self,$mirror)=@_;my$file=$self->package_index_for($mirror);my$gz_file=$file .'.gz';my$index_mtime=(stat$gz_file)[9];unless (-e $file && (stat$file)[9]>= $index_mtime){$self->chat("Uncompressing index file...\n");if (eval {require Compress::Zlib}){my$gz=Compress::Zlib::gzopen($gz_file,"rb")or do {$self->diag_fail("$Compress::Zlib::gzerrno opening compressed index");return};open my$fh,'>',$file or do {$self->diag_fail("$! opening uncompressed index for write");return};my$buffer;while (my$status=$gz->gzread($buffer)){if ($status < 0){$self->diag_fail($gz->gzerror ." reading compressed index");return}print$fh $buffer}}else {if (system("gunzip -c $gz_file > $file")){$self->diag_fail("Cannot uncompress -- please install gunzip or Compress::Zlib");return}}utime$index_mtime,$index_mtime,$file}return 1}sub search_mirror_index {my ($self,$mirror,$module,$version)=@_;$self->search_mirror_index_file($self->package_index_for($mirror),$module,$version)}sub search_mirror_index_file {my($self,$file,$module,$version)=@_;open my$fh,'<',$file or return;my$found;while (<$fh>){if (m!^\Q$module\E\s+([\w\.]+)\s+(\S*)!m){$found=$self->cpan_module($module,$2,$1);last}}return$found unless$self->{cascade_search};if ($found){if ($self->satisfy_version($module,$found->{module_version},$version)){return$found}else {$self->chat("Found $module $found->{module_version} which doesn't satisfy $version.\n")}}return}sub with_version_range {my($self,$version)=@_;defined($version)&& $version =~ /(?:<|!=|==)/}sub encode_json {my($self,$data)=@_;require JSON::PP;my$json=JSON::PP::encode_json($data);$json =~ s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/eg;$json}sub version_to_query {my($self,$module,$version)=@_;require CPAN::Meta::Requirements;my$requirements=CPAN::Meta::Requirements->new;$requirements->add_string_requirement($module,$version || '0');my$req=$requirements->requirements_for_module($module);if ($req =~ s/^==\s*//){return {term=>{'module.version'=>$req },}}elsif ($req !~ /\s/){return {range=>{'module.version_numified'=>{'gte'=>$self->numify_ver_metacpan($req)}},}}else {my%ops=qw(< lt <= lte > gt >= gte);my(%range,@exclusion);my@requirements=split /,\s*/,$req;for my$r (@requirements){if ($r =~ s/^([<>]=?)\s*//){$range{$ops{$1}}=$self->numify_ver_metacpan($r)}elsif ($r =~ s/\!=\s*//){push@exclusion,$self->numify_ver_metacpan($r)}}my@filters=({range=>{'module.version_numified'=>\%range }},);if (@exclusion){push@filters,{not=>{or=>[map {+{term=>{'module.version_numified'=>$self->numify_ver_metacpan($_)}}}@exclusion ]},}}return@filters}}sub numify_ver_metacpan {my($self,$ver)=@_;$ver =~ s/_//g;version->new($ver)->numify}sub numify_ver {my($self,$ver)=@_;eval version->new($ver)->numify}sub maturity_filter {my($self,$module,$version)=@_;if ($version =~ /==/){return}elsif ($self->{dev_release}){return +{not=>{term=>{status=>'backpan' }}}}else {return ({not=>{term=>{status=>'backpan' }}},{term=>{maturity=>'released' }},)}}sub by_version {my%s=qw(latest 3 cpan 2 backpan 1);$b->{_score}<=> $a->{_score}|| $s{$b->{fields}{status}}<=> $s{$a->{fields}{status}}}sub by_first_come {$a->{fields}{date}cmp $b->{fields}{date}}sub by_date {$b->{fields}{date}cmp $a->{fields}{date}}sub find_best_match {my($self,$match,$version)=@_;return unless$match && @{$match->{hits}{hits}|| []};my@hits=$self->{dev_release}? sort {by_version || by_date}@{$match->{hits}{hits}}: sort {by_version || by_first_come}@{$match->{hits}{hits}};$hits[0]->{fields}}sub search_metacpan {my($self,$module,$version)=@_;require JSON::PP;$self->chat("Searching $module ($version) on metacpan ...\n");my$metacpan_uri='http://api.metacpan.org/v0';my@filter=$self->maturity_filter($module,$version);my$query={filtered=>{(@filter ? (filter=>{and=>\@filter }): ()),query=>{nested=>{score_mode=>'max',path=>'module',query=>{custom_score=>{metacpan_script=>"score_version_numified",query=>{constant_score=>{filter=>{and=>[{term=>{'module.authorized'=>JSON::PP::true()}},{term=>{'module.indexed'=>JSON::PP::true()}},{term=>{'module.name'=>$module }},$self->version_to_query($module,$version),]}}},}},}},}};my$module_uri="$metacpan_uri/file/_search?source=";$module_uri .= $self->encode_json({query=>$query,fields=>['date','release','author','module','status' ],});my($release,$author,$module_version);my$module_json=$self->get($module_uri);my$module_meta=eval {JSON::PP::decode_json($module_json)};my$match=$self->find_best_match($module_meta);if ($match){$release=$match->{release};$author=$match->{author};my$module_matched=(grep {$_->{name}eq $module}@{$match->{module}})[0];$module_version=$module_matched->{version}}unless ($release){$self->chat("! Could not find a release matching $module ($version) on MetaCPAN.\n");return}my$dist_uri="$metacpan_uri/release/_search?source=";$dist_uri .= $self->encode_json({filter=>{and=>[{term=>{'release.name'=>$release }},{term=>{'release.author'=>$author }},]},fields=>['download_url','stat','status' ],});my$dist_json=$self->get($dist_uri);my$dist_meta=eval {JSON::PP::decode_json($dist_json)};if ($dist_meta){$dist_meta=$dist_meta->{hits}{hits}[0]{fields}}if ($dist_meta && $dist_meta->{download_url}){(my$distfile=$dist_meta->{download_url})=~ s!.+/authors/id/!!;local$self->{mirrors}=$self->{mirrors};if ($dist_meta->{status}eq 'backpan'){$self->{mirrors}=['http://backpan.perl.org' ]}elsif ($dist_meta->{stat}{mtime}> time()-24*60*60){$self->{mirrors}=['http://cpan.metacpan.org' ]}return$self->cpan_module($module,$distfile,$module_version)}$self->diag_fail("Finding $module on metacpan failed.");return}sub search_database {my($self,$module,$version)=@_;my$found;if ($self->{dev_release}or $self->{metacpan}){$found=$self->search_metacpan($module,$version)and return$found;$found=$self->search_cpanmetadb($module,$version)and return$found}else {$found=$self->search_cpanmetadb($module,$version)and return$found;$found=$self->search_metacpan($module,$version)and return$found}}sub search_cpanmetadb {my($self,$module,$version)=@_;$self->chat("Searching $module ($version) on cpanmetadb ...\n");if ($self->with_version_range($version)){return$self->search_cpanmetadb_history($module,$version)}else {return$self->search_cpanmetadb_package($module,$version)}}sub search_cpanmetadb_package {my($self,$module,$version)=@_;require CPAN::Meta::YAML;(my$uri=$self->{cpanmetadb})=~ s{/?$}{/package/$module};my$yaml=$self->get($uri);my$meta=eval {CPAN::Meta::YAML::Load($yaml)};if ($meta && $meta->{distfile}){return$self->cpan_module($module,$meta->{distfile},$meta->{version})}$self->diag_fail("Finding $module on cpanmetadb failed.");return}sub search_cpanmetadb_history {my($self,$module,$version)=@_;(my$uri=$self->{cpanmetadb})=~ s{/?$}{/history/$module};my$content=$self->get($uri)or return;my@found;for my$line (split /\r?\n/,$content){if ($line =~ /^$module\s+(\S+)\s+(\S+)$/){push@found,{version=>$1,version_obj=>version::->parse($1),distfile=>$2,}}}return unless@found;$found[-1]->{latest}=1;my$match;for my$try (sort {$b->{version_obj}cmp $a->{version_obj}}@found){if ($self->satisfy_version($module,$try->{version_obj},$version)){local$self->{mirrors}=$self->{mirrors};unshift @{$self->{mirrors}},'http://backpan.perl.org' unless$try->{latest};return$self->cpan_module($module,$try->{distfile},$try->{version})}}$self->diag_fail("Finding $module ($version) on cpanmetadb failed.");return}sub search_module {my($self,$module,$version)=@_;if ($self->{mirror_index}){$self->mask_output(chat=>"Searching $module on mirror index $self->{mirror_index} ...\n");my$pkg=$self->search_mirror_index_file($self->{mirror_index},$module,$version);return$pkg if$pkg;unless ($self->{cascade_search}){$self->mask_output(diag_fail=>"Finding $module ($version) on mirror index $self->{mirror_index} failed.");return}}unless ($self->{mirror_only}){my$found=$self->search_database($module,$version);return$found if$found}MIRROR: for my$mirror (@{$self->{mirrors}}){$self->mask_output(chat=>"Searching $module on mirror $mirror ...\n");my$name='02packages.details.txt.gz';my$uri="$mirror/modules/$name";my$gz_file=$self->package_index_for($mirror).'.gz';unless ($self->{pkgs}{$uri}){$self->mask_output(chat=>"Downloading index file $uri ...\n");$self->mirror($uri,$gz_file);$self->generate_mirror_index($mirror)or next MIRROR;$self->{pkgs}{$uri}="!!retrieved!!"}my$pkg=$self->search_mirror_index($mirror,$module,$version);return$pkg if$pkg;$self->mask_output(diag_fail=>"Finding $module ($version) on mirror $mirror failed.")}return}sub source_for {my($self,$mirror)=@_;$mirror =~ s/[^\w\.\-]+/%/g;my$dir="$self->{home}/sources/$mirror";File::Path::mkpath([$dir ],0,0777);return$dir}sub load_argv_from_fh {my($self,$fh)=@_;my@argv;while(defined(my$line=<$fh>)){chomp$line;$line =~ s/#.+$//;$line =~ s/^\s+//;$line =~ s/\s+$//;push@argv,split ' ',$line if$line}return@argv}sub show_version {my$self=shift;print "cpanm (App::cpanminus) version $VERSION ($0)\n";print "perl version $] ($^X)\n\n";print " \%Config:\n";for my$key (qw(archname installsitelib installsitebin installman1dir installman3dir sitearchexp sitelibexp vendorarch vendorlibexp archlibexp privlibexp)){print " $key=$Config{$key}\n" if$Config{$key}}print " \%ENV:\n";for my$key (grep /^PERL/,sort keys%ENV){print " $key=$ENV{$key}\n"}print " \@INC:\n";for my$inc (@INC){print " $inc\n" unless ref($inc)eq 'CODE'}return 1}sub show_help {my$self=shift;if ($_[0]){print <<USAGE;return}print <<HELP;return 1}sub _writable {my$dir=shift;my@dir=File::Spec->splitdir($dir);while (@dir){$dir=File::Spec->catdir(@dir);if (-e $dir){return -w _}pop@dir}return}sub maybe_abs {my($self,$lib)=@_;if ($lib eq '_' or $lib =~ /^~/ or File::Spec->file_name_is_absolute($lib)){return$lib}else {return File::Spec->canonpath(File::Spec->catdir(Cwd::cwd(),$lib))}}sub local_lib_target {my($self,$root)=@_;(grep {$_ ne ''}split /\Q$Config{path_sep}/,$root)[0]}sub bootstrap_local_lib {my$self=shift;if ($self->{local_lib}){return$self->setup_local_lib($self->{local_lib})}if ($ENV{PERL_LOCAL_LIB_ROOT}&& $ENV{PERL_MM_OPT}){return$self->setup_local_lib($self->local_lib_target($ENV{PERL_LOCAL_LIB_ROOT}),1)}return if$self->{sudo}or (_writable($Config{installsitelib})and _writable($Config{installsitebin}));if ($ENV{PERL_MM_OPT}and ($ENV{MODULEBUILDRC}or $ENV{PERL_MB_OPT})){return}$self->setup_local_lib;$self->diag(<<DIAG,1);sleep 2}sub upgrade_toolchain {my($self,$config_deps)=@_;my%deps=map {$_->module=>$_}@$config_deps;my$reqs=CPAN::Meta::Requirements->from_string_hash({'Module::Build'=>'0.38','ExtUtils::MakeMaker'=>'6.58','ExtUtils::Install'=>'1.46',});if ($deps{"ExtUtils::MakeMaker"}){$deps{"ExtUtils::MakeMaker"}->merge_with($reqs)}elsif ($deps{"Module::Build"}){$deps{"Module::Build"}->merge_with($reqs);$deps{"ExtUtils::Install"}||= App::cpanminus::Dependency->new("ExtUtils::Install",0,'configure');$deps{"ExtUtils::Install"}->merge_with($reqs)}@$config_deps=values%deps}sub _core_only_inc {my($self,$base)=@_;require local::lib;(local::lib->resolve_path(local::lib->install_base_arch_path($base)),local::lib->resolve_path(local::lib->install_base_perl_path($base)),(!$self->{exclude_vendor}? grep {$_}@Config{qw(vendorarch vendorlibexp)}: ()),@Config{qw(archlibexp privlibexp)},)}sub _diff {my($self,$old,$new)=@_;my@diff;my%old=map {$_=>1}@$old;for my$n (@$new){push@diff,$n unless exists$old{$n}}@diff}sub _setup_local_lib_env {my($self,$base)=@_;$self->diag(<<WARN,1)if$base =~ /\s/;local$SIG{__WARN__}=sub {};local::lib->setup_env_hash_for($base,0)}sub setup_local_lib {my($self,$base,$no_env)=@_;$base=undef if$base eq '_';require local::lib;{local $0='cpanm';$base ||= "~/perl5";$base=local::lib->resolve_path($base);if ($self->{self_contained}){my@inc=$self->_core_only_inc($base);$self->{search_inc}=[@inc ]}else {$self->{search_inc}=[local::lib->install_base_arch_path($base),local::lib->install_base_perl_path($base),@INC,]}$self->_setup_local_lib_env($base)unless$no_env;$self->{local_lib}=$base}}sub prompt_bool {my($self,$mess,$def)=@_;my$val=$self->prompt($mess,$def);return lc$val eq 'y'}sub prompt {my($self,$mess,$def)=@_;my$isa_tty=-t STDIN && (-t STDOUT ||!(-f STDOUT || -c STDOUT));my$dispdef=defined$def ? "[$def] " : " ";$def=defined$def ? $def : "";if (!$self->{prompt}|| (!$isa_tty && eof STDIN)){return$def}local $|=1;local $\;my$ans;eval {local$SIG{ALRM}=sub {undef$ans;die "alarm\n"};print STDOUT "$mess $dispdef";alarm$self->{prompt_timeout}if$self->{prompt_timeout};$ans=<STDIN>;alarm 0};if (defined$ans){chomp$ans}else {print STDOUT "\n"}return (!defined$ans || $ans eq '')? $def : $ans}sub diag_ok {my($self,$msg)=@_;chomp$msg;$msg ||= "OK";if ($self->{in_progress}){$self->_diag("$msg\n");$self->{in_progress}=0}$self->log("-> $msg\n")}sub diag_fail {my($self,$msg,$always)=@_;chomp$msg;if ($self->{in_progress}){$self->_diag("FAIL\n");$self->{in_progress}=0}if ($msg){$self->_diag("! $msg\n",$always,1);$self->log("-> FAIL $msg\n")}}sub diag_progress {my($self,$msg)=@_;chomp$msg;$self->{in_progress}=1;$self->_diag("$msg ... ");$self->log("$msg\n")}sub _diag {my($self,$msg,$always,$error)=@_;my$fh=$error ? *STDERR : *STDOUT;print {$fh}$msg if$always or $self->{verbose}or!$self->{quiet}}sub diag {my($self,$msg,$always)=@_;$self->_diag($msg,$always);$self->log($msg)}sub chat {my$self=shift;print STDERR @_ if$self->{verbose};$self->log(@_)}sub mask_output {my$self=shift;my$method=shift;$self->$method($self->mask_uri_passwords(@_))}sub log {my$self=shift;open my$out,">>$self->{log}";print$out @_}sub run {my($self,$cmd)=@_;if (WIN32){$cmd=$self->shell_quote(@$cmd)if ref$cmd eq 'ARRAY';unless ($self->{verbose}){$cmd .= " >> " .$self->shell_quote($self->{log})." 2>&1"}!system$cmd}else {my$pid=fork;if ($pid){waitpid$pid,0;return!$?}else {$self->run_exec($cmd)}}}sub run_exec {my($self,$cmd)=@_;if (ref$cmd eq 'ARRAY'){unless ($self->{verbose}){open my$logfh,">>",$self->{log};open STDERR,'>&',$logfh;open STDOUT,'>&',$logfh;close$logfh}exec @$cmd}else {unless ($self->{verbose}){$cmd .= " >> " .$self->shell_quote($self->{log})." 2>&1"}exec$cmd}}sub run_timeout {my($self,$cmd,$timeout)=@_;return$self->run($cmd)if WIN32 || $self->{verbose}||!$timeout;my$pid=fork;if ($pid){eval {local$SIG{ALRM}=sub {die "alarm\n"};alarm$timeout;waitpid$pid,0;alarm 0};if ($@ && $@ eq "alarm\n"){$self->diag_fail("Timed out (> ${timeout}s). Use --verbose to retry.");local$SIG{TERM}='IGNORE';kill TERM=>0;waitpid$pid,0;return}return!$?}elsif ($pid==0){$self->run_exec($cmd)}else {$self->chat("! fork failed: falling back to system()\n");$self->run($cmd)}}sub append_args {my($self,$cmd,$phase)=@_;if (my$args=$self->{build_args}{$phase}){$cmd=join ' ',$self->shell_quote(@$cmd),$args}$cmd}sub configure {my($self,$cmd,$depth)=@_;local$ENV{PERL5_CPAN_IS_RUNNING}=local$ENV{PERL5_CPANPLUS_IS_RUNNING}=$$;local$ENV{PERL5_CPANM_IS_RUNNING}=$$;my$use_default=!$self->{interactive};local$ENV{PERL_MM_USE_DEFAULT}=$use_default;local$ENV{PERL_MM_OPT}=$ENV{PERL_MM_OPT};local$ENV{PERL_MB_OPT}=$ENV{PERL_MB_OPT};unless ($self->{pod2man}){$ENV{PERL_MM_OPT}.= " INSTALLMAN1DIR=none INSTALLMAN3DIR=none";$ENV{PERL_MB_OPT}.= " --config installman1dir= --config installsiteman1dir= --config installman3dir= --config installsiteman3dir="}if ($self->{pure_perl}){$ENV{PERL_MM_OPT}.= " PUREPERL_ONLY=1";$ENV{PERL_MB_OPT}.= " --pureperl-only"}$cmd=$self->append_args($cmd,'configure')if$depth==0;local$self->{verbose}=$self->{verbose}|| $self->{interactive};$self->run_timeout($cmd,$self->{configure_timeout})}sub build {my($self,$cmd,$distname,$depth)=@_;local$ENV{PERL_MM_USE_DEFAULT}=!$self->{interactive};$cmd=$self->append_args($cmd,'build')if$depth==0;return 1 if$self->run_timeout($cmd,$self->{build_timeout});while (1){my$ans=lc$self->prompt("Building $distname failed.\nYou can s)kip, r)etry, e)xamine build log, or l)ook ?","s");return if$ans eq 's';return$self->build($cmd,$distname,$depth)if$ans eq 'r';$self->show_build_log if$ans eq 'e';$self->look if$ans eq 'l'}}sub test {my($self,$cmd,$distname,$depth)=@_;return 1 if$self->{notest};local$ENV{PERL_MM_USE_DEFAULT}=!$self->{interactive};local$ENV{NONINTERACTIVE_TESTING}=!$self->{interactive};$cmd=$self->append_args($cmd,'test')if$depth==0;return 1 if$self->run_timeout($cmd,$self->{test_timeout});if ($self->{force}){$self->diag_fail("Testing $distname failed but installing it anyway.");return 1}else {$self->diag_fail;while (1){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");return if$ans eq 's';return$self->test($cmd,$distname,$depth)if$ans eq 'r';return 1 if$ans eq 'f';$self->show_build_log if$ans eq 'e';$self->look if$ans eq 'l'}}}sub install {my($self,$cmd,$uninst_opts,$depth)=@_;if ($depth==0 && $self->{test_only}){return 1}if ($self->{sudo}){unshift @$cmd,"sudo"}if ($self->{uninstall_shadows}&&!$ENV{PERL_MM_OPT}){push @$cmd,@$uninst_opts}$cmd=$self->append_args($cmd,'install')if$depth==0;$self->run($cmd)}sub look {my$self=shift;my$shell=$ENV{SHELL};$shell ||= $ENV{COMSPEC}if WIN32;if ($shell){my$cwd=Cwd::cwd;$self->diag("Entering $cwd with $shell\n");system$shell}else {$self->diag_fail("You don't seem to have a SHELL :/")}}sub show_build_log {my$self=shift;my@pagers=($ENV{PAGER},(WIN32 ? (): ('less')),'more');my$pager;while (@pagers){$pager=shift@pagers;next unless$pager;$pager=$self->which($pager);next unless$pager;last}if ($pager){system("$pager < $self->{log}")}else {$self->diag_fail("You don't seem to have a PAGER :/")}}sub chdir {my$self=shift;Cwd::chdir(File::Spec->canonpath($_[0]))or die "$_[0]: $!"}sub configure_mirrors {my$self=shift;unless (@{$self->{mirrors}}){$self->{mirrors}=['http://www.cpan.org' ]}for (@{$self->{mirrors}}){s!^/!file:///!;s!/$!!}}sub self_upgrade {my$self=shift;$self->check_upgrade;$self->{argv}=['App::cpanminus' ];return}sub install_module {my($self,$module,$depth,$version)=@_;$self->check_libs;if ($self->{seen}{$module}++){$self->chat("Already tried $module. Skipping.\n");return 1}if ($self->{skip_satisfied}){my($ok,$local)=$self->check_module($module,$version || 0);if ($ok){$self->diag("You have $module ($local)\n",1);return 1}}my$dist=$self->resolve_name($module,$version);unless ($dist){my$what=$module .($version ? " ($version)" : "");$self->diag_fail("Couldn't find module or a distribution $what",1);return}if ($dist->{distvname}&& $self->{seen}{$dist->{distvname}}++){$self->chat("Already tried $dist->{distvname}. Skipping.\n");return 1}if ($self->{cmd}eq 'info'){print$self->format_dist($dist),"\n";return 1}$dist->{depth}=$depth;if ($dist->{module}){unless ($self->satisfy_version($dist->{module},$dist->{module_version},$version)){$self->diag("Found $dist->{module} $dist->{module_version} which doesn't satisfy $version.\n",1);return}my$cmp=$version ? "==" : "";my$requirement=$dist->{module_version}? "$cmp$dist->{module_version}" : 0;my($ok,$local)=$self->check_module($dist->{module},$requirement);if ($self->{skip_installed}&& $ok){$self->diag("$dist->{module} is up to date. ($local)\n",1);return 1}}if ($dist->{dist}eq 'perl'){$self->diag("skipping $dist->{pathname}\n");return 1}$self->diag("--> Working on $module\n");$dist->{dir}||= $self->fetch_module($dist);unless ($dist->{dir}){$self->diag_fail("Failed to fetch distribution $dist->{distvname}",1);return}$self->chat("Entering $dist->{dir}\n");$self->chdir($self->{base});$self->chdir($dist->{dir});if ($self->{cmd}eq 'look'){$self->look;return 1}return$self->build_stuff($module,$dist,$depth)}sub uninstall_search_path {my$self=shift;$self->{local_lib}? (local::lib->install_base_arch_path($self->{local_lib}),local::lib->install_base_perl_path($self->{local_lib})): @Config{qw(installsitearch installsitelib)}}sub uninstall_module {my ($self,$module)=@_;$self->check_libs;my@inc=$self->uninstall_search_path;my($metadata,$packlist)=$self->packlists_containing($module,\@inc);unless ($packlist){$self->diag_fail(<<DIAG,1);return}my@uninst_files=$self->uninstall_target($metadata,$packlist);$self->ask_permission($module,\@uninst_files)or return;$self->uninstall_files(@uninst_files,$packlist);$self->diag("Successfully uninstalled $module\n",1);return 1}sub packlists_containing {my($self,$module,$inc)=@_;require Module::Metadata;my$metadata=Module::Metadata->new_from_module($module,inc=>$inc)or return;my$packlist;my$wanted=sub {return unless $_ eq '.packlist' && -f $_;for my$file ($self->unpack_packlist($File::Find::name)){$packlist ||= $File::Find::name if$file eq $metadata->filename}};{require File::pushd;my$pushd=File::pushd::pushd();my@search=grep -d $_,map File::Spec->catdir($_,'auto'),@$inc;File::Find::find($wanted,@search)}return$metadata,$packlist}sub uninstall_target {my($self,$metadata,$packlist)=@_;if ($self->has_shadow_install($metadata)or $self->{local_lib}){grep$self->should_unlink($_),$self->unpack_packlist($packlist)}else {$self->unpack_packlist($packlist)}}sub has_shadow_install {my($self,$metadata)=@_;my@shadow=grep defined,map Module::Metadata->new_from_module($metadata->name,inc=>[$_]),@INC;@shadow >= 2}sub should_unlink {my($self,$file)=@_;if ($self->{local_lib}){$file =~ /^\Q$self->{local_lib}\E/}else {!(grep$file =~ /^\Q$_\E/,@Config{qw(installbin installscript installman1dir installman3dir)})}}sub ask_permission {my ($self,$module,$files)=@_;$self->diag("$module contains the following files:\n\n");for my$file (@$files){$self->diag(" $file\n")}$self->diag("\n");return 'force uninstall' if$self->{force};local$self->{prompt}=1;return$self->prompt_bool("Are you sure you want to uninstall $module?",'y')}sub unpack_packlist {my ($self,$packlist)=@_;open my$fh,'<',$packlist or die "$packlist: $!";map {chomp;$_}<$fh>}sub uninstall_files {my ($self,@files)=@_;$self->diag("\n");for my$file (@files){$self->diag("Unlink: $file\n");unlink$file or $self->diag_fail("$!: $file")}$self->diag("\n");return 1}sub format_dist {my($self,$dist)=@_;return "$dist->{cpanid}/$dist->{filename}"}sub trim {local $_=shift;tr/\n/ /d;s/^\s*|\s*$//g;$_}sub fetch_module {my($self,$dist)=@_;$self->chdir($self->{base});for my$uri (@{$dist->{uris}}){$self->mask_output(diag_progress=>"Fetching $uri");my$filename=$dist->{filename}|| $uri;my$name=File::Basename::basename($filename);my$cancelled;my$fetch=sub {my$file;eval {local$SIG{INT}=sub {$cancelled=1;die "SIGINT\n"};$self->mirror($uri,$name);$file=$name if -e $name};$self->diag("ERROR: " .trim("$@")."\n",1)if $@ && $@ ne "SIGINT\n";return$file};my($try,$file);while ($try++ < 3){$file=$fetch->();last if$cancelled or $file;$self->mask_output(diag_fail=>"Download $uri failed. Retrying ... ")}if ($cancelled){$self->diag_fail("Download cancelled.");return}unless ($file){$self->mask_output(diag_fail=>"Failed to download $uri");next}$self->diag_ok;$dist->{local_path}=File::Spec->rel2abs($name);my$dir=$self->unpack($file,$uri,$dist);next unless$dir;if (my$save=$self->{save_dists}){my$path=$dist->{pathname}? "$save/authors/id/$dist->{pathname}" : "$save/vendor/$file";$self->chat("Copying $name to $path\n");File::Path::mkpath([File::Basename::dirname($path)],0,0777);File::Copy::copy($file,$path)or warn $!}return$dist,$dir}}sub unpack {my($self,$file,$uri,$dist)=@_;if ($self->{verify}){$self->verify_archive($file,$uri,$dist)or return}$self->chat("Unpacking $file\n");my$dir=$file =~ /\.zip/i ? $self->unzip($file): $self->untar($file);unless ($dir){$self->diag_fail("Failed to unpack $file: no directory")}return$dir}sub verify_checksums_signature {my($self,$chk_file)=@_;require Module::Signature;$self->chat("Verifying the signature of CHECKSUMS\n");my$rv=eval {local$SIG{__WARN__}=sub {};my$v=Module::Signature::_verify($chk_file);$v==Module::Signature::SIGNATURE_OK()};if ($rv){$self->chat("Verified OK!\n")}else {$self->diag_fail("Verifying CHECKSUMS signature failed: $rv\n");return}return 1}sub verify_archive {my($self,$file,$uri,$dist)=@_;unless ($dist->{cpanid}){$self->chat("Archive '$file' does not seem to be from PAUSE. Skip verification.\n");return 1}(my$mirror=$uri)=~ s!/authors/id.*$!!;(my$chksum_uri=$uri)=~ s!/[^/]*$!/CHECKSUMS!;my$chk_file=$self->source_for($mirror)."/$dist->{cpanid}.CHECKSUMS";$self->mask_output(diag_progress=>"Fetching $chksum_uri");$self->mirror($chksum_uri,$chk_file);unless (-e $chk_file){$self->diag_fail("Fetching $chksum_uri failed.\n");return}$self->diag_ok;$self->verify_checksums_signature($chk_file)or return;$self->verify_checksum($file,$chk_file)}sub verify_checksum {my($self,$file,$chk_file)=@_;$self->chat("Verifying the SHA1 for $file\n");open my$fh,"<$chk_file" or die "$chk_file: $!";my$data=join '',<$fh>;$data =~ s/\015?\012/\n/g;require Safe;my$chksum=Safe->new->reval($data);if (!ref$chksum or ref$chksum ne 'HASH'){$self->diag_fail("! Checksum file downloaded from $chk_file is broken.\n");return}if (my$sha=$chksum->{$file}{sha256}){my$hex=$self->sha1_for($file);if ($hex eq $sha){$self->chat("Checksum for $file: Verified!\n")}else {$self->diag_fail("Checksum mismatch for $file\n");return}}else {$self->chat("Checksum for $file not found in CHECKSUMS.\n");return}}sub sha1_for {my($self,$file)=@_;require Digest::SHA;open my$fh,"<",$file or die "$file: $!";my$dg=Digest::SHA->new(256);my($data);while (read($fh,$data,4096)){$dg->add($data)}return$dg->hexdigest}sub verify_signature {my($self,$dist)=@_;$self->diag_progress("Verifying the SIGNATURE file");my$out=`$self->{cpansign} -v --skip 2>&1`;$self->log($out);if ($out =~ /Signature verified OK/){$self->diag_ok("Verified OK");return 1}else {$self->diag_fail("SIGNATURE verificaion for $dist->{filename} failed\n");return}}sub resolve_name {my($self,$module,$version)=@_;if ($module =~ /(?:^git:|\.git(?:@.+)?$)/){return$self->git_uri($module)}if ($module =~ /^(ftp|https?|file):/){if ($module =~ m!authors/id/(.*)!){return$self->cpan_dist($1,$module)}else {return {uris=>[$module ]}}}if ($module =~ m!^[\./]! && -d $module){return {source=>'local',dir=>Cwd::abs_path($module),}}if (-f $module){return {source=>'local',uris=>["file://" .Cwd::abs_path($module)],}}if ($module =~ s!^cpan:///distfile/!!){return$self->cpan_dist($module)}if ($module =~ m!^(?:[A-Z]/[A-Z]{2}/)?([A-Z]{2}[\-A-Z0-9]*/.*)$!){return$self->cpan_dist($1)}return$self->search_module($module,$version)}sub cpan_module {my($self,$module,$dist,$version)=@_;my$dist=$self->cpan_dist($dist);$dist->{module}=$module;$dist->{module_version}=$version if$version && $version ne 'undef';return$dist}sub cpan_dist {my($self,$dist,$url)=@_;$dist =~ s!^([A-Z]{2})!substr($1,0,1)."/".substr($1,0,2)."/".$1!e;require CPAN::DistnameInfo;my$d=CPAN::DistnameInfo->new($dist);if ($url){$url=[$url ]unless ref$url eq 'ARRAY'}else {my$id=$d->cpanid;my$fn=substr($id,0,1)."/" .substr($id,0,2)."/" .$id ."/" .$d->filename;my@mirrors=@{$self->{mirrors}};my@urls=map "$_/authors/id/$fn",@mirrors;$url=\@urls,}return {$d->properties,source=>'cpan',uris=>$url,}}sub git_uri {my ($self,$uri)=@_;($uri,my$commitish)=split /(?<=\.git)@/i,$uri,2;my$dir=File::Temp::tempdir(CLEANUP=>1);$self->mask_output(diag_progress=>"Cloning $uri");$self->run(['git','clone',$uri,$dir ]);unless (-e "$dir/.git"){$self->diag_fail("Failed cloning git repository $uri",1);return}if ($commitish){require File::pushd;my$dir=File::pushd::pushd($dir);unless ($self->run(['git','checkout',$commitish ])){$self->diag_fail("Failed to checkout '$commitish' in git repository $uri\n");return}}$self->diag_ok;return {source=>'local',dir=>$dir,}}sub setup_module_build_patch {my$self=shift;open my$out,">$self->{base}/ModuleBuildSkipMan.pm" or die $!;print$out <<EOF}sub core_version_for {my($self,$module)=@_;require Module::CoreList;unless (exists$Module::CoreList::version{$]+0}){die sprintf("Module::CoreList %s (loaded from %s) doesn't seem to have entries for perl $]. " ."You're strongly recommended to upgrade Module::CoreList from CPAN.\n",$Module::CoreList::VERSION,$INC{"Module/CoreList.pm"})}unless (exists$Module::CoreList::version{$]+0}{$module}){return -1}return$Module::CoreList::version{$]+0}{$module}}sub search_inc {my$self=shift;$self->{search_inc}||= do {if (defined$::Bin){[grep!/^\Q$::Bin\E\/..\/(?:fat)?lib$/,@INC]}else {[@INC]}}}sub check_module {my($self,$mod,$want_ver)=@_;require Module::Metadata;my$meta=Module::Metadata->new_from_module($mod,inc=>$self->search_inc)or return 0,undef;my$version=$meta->version;if ($self->{self_contained}&& $self->loaded_from_perl_lib($meta)){$version=$self->core_version_for($mod);return 0,undef if$version && $version==-1}$self->{local_versions}{$mod}=$version;if ($self->is_deprecated($meta)){return 0,$version}elsif ($self->satisfy_version($mod,$version,$want_ver)){return 1,($version || 'undef')}else {return 0,$version}}sub satisfy_version {my($self,$mod,$version,$want_ver)=@_;$want_ver='0' unless defined($want_ver)&& length($want_ver);require CPAN::Meta::Requirements;my$requirements=CPAN::Meta::Requirements->new;$requirements->add_string_requirement($mod,$want_ver);$requirements->accepts_module($mod,$version)}sub unsatisfy_how {my($self,$ver,$want_ver)=@_;if ($want_ver =~ /^[v0-9\.\_]+$/){return "$ver < $want_ver"}else {return "$ver doesn't satisfy $want_ver"}}sub is_deprecated {my($self,$meta)=@_;my$deprecated=eval {require Module::CoreList;Module::CoreList::is_deprecated($meta->{module})};return$deprecated && $self->loaded_from_perl_lib($meta)}sub loaded_from_perl_lib {my($self,$meta)=@_;require Config;my@dirs=qw(archlibexp privlibexp);if ($self->{self_contained}&&!$self->{exclude_vendor}&& $Config{vendorarch}){unshift@dirs,qw(vendorarch vendorlibexp)}for my$dir (@dirs){my$confdir=$Config{$dir};if ($confdir eq substr($meta->filename,0,length($confdir))){return 1}}return}sub should_install {my($self,$mod,$ver)=@_;$self->chat("Checking if you have $mod $ver ... ");my($ok,$local)=$self->check_module($mod,$ver);if ($ok){$self->chat("Yes ($local)\n")}elsif ($local){$self->chat("No (" .$self->unsatisfy_how($local,$ver).")\n")}else {$self->chat("No\n")}return$mod unless$ok;return}sub check_perl_version {my($self,$version)=@_;require CPAN::Meta::Requirements;my$req=CPAN::Meta::Requirements->from_string_hash({perl=>$version });$req->accepts_module(perl=>$])}sub install_deps {my($self,$dir,$depth,@deps)=@_;my(@install,%seen,@fail);for my$dep (@deps){next if$seen{$dep->module};if ($dep->module eq 'perl'){if ($dep->is_requirement &&!$self->check_perl_version($dep->version)){$self->diag("Needs perl @{[$dep->version]}, you have $]\n");push@fail,'perl'}}elsif ($self->should_install($dep->module,$dep->version)){push@install,$dep;$seen{$dep->module}=1}}if (@install){$self->diag("==> Found dependencies: " .join(", ",map $_->module,@install)."\n")}for my$dep (@install){$self->install_module($dep->module,$depth + 1,$dep->version)}$self->chdir($self->{base});$self->chdir($dir)if$dir;if ($self->{scandeps}){return 1}my@not_ok=$self->unsatisfied_deps(@deps);if (@not_ok){return 0,\@not_ok}else {return 1}}sub unsatisfied_deps {my($self,@deps)=@_;require CPAN::Meta::Check;require CPAN::Meta::Requirements;my$reqs=CPAN::Meta::Requirements->new;for my$dep (grep $_->is_requirement,@deps){$reqs->add_string_requirement($dep->module=>$dep->requires_version || '0')}my$ret=CPAN::Meta::Check::check_requirements($reqs,'requires',$self->{search_inc});grep defined,values %$ret}sub install_deps_bailout {my($self,$target,$dir,$depth,@deps)=@_;my($ok,$fail)=$self->install_deps($dir,$depth,@deps);if (!$ok){$self->diag_fail("Installing the dependencies failed: " .join(", ",@$fail),1);unless ($self->prompt_bool("Do you want to continue building $target anyway?","n")){$self->diag_fail("Bailing out the installation for $target.",1);return}}return 1}sub build_stuff {my($self,$stuff,$dist,$depth)=@_;if ($self->{verify}&& -e 'SIGNATURE'){$self->verify_signature($dist)or return}require CPAN::Meta;my($meta_file)=grep -f,qw(META.json META.yml);if ($meta_file){$self->chat("Checking configure dependencies from $meta_file\n");$dist->{cpanmeta}=eval {CPAN::Meta->load_file($meta_file)}}elsif ($dist->{dist}&& $dist->{version}){$self->chat("META.yml/json not found. Creating skeleton for it.\n");$dist->{cpanmeta}=CPAN::Meta->new({name=>$dist->{dist},version=>$dist->{version}})}$dist->{meta}=$dist->{cpanmeta}? $dist->{cpanmeta}->as_struct : {};my@config_deps;if ($dist->{cpanmeta}){push@config_deps,App::cpanminus::Dependency->from_prereqs($dist->{cpanmeta}->effective_prereqs,['configure'],$self->{install_types},)}if (-e 'Build.PL' &&!$self->should_use_mm($dist->{dist})&&!@config_deps){push@config_deps,App::cpanminus::Dependency->from_versions({'Module::Build'=>'0.38' },'configure',)}$self->upgrade_toolchain(\@config_deps);my$target=$dist->{meta}{name}? "$dist->{meta}{name}-$dist->{meta}{version}" : $dist->{dir};{$self->install_deps_bailout($target,$dist->{dir},$depth,@config_deps)or return}$self->diag_progress("Configuring $target");my$configure_state=$self->configure_this($dist,$depth);$self->diag_ok($configure_state->{configured_ok}? "OK" : "N/A");if ($dist->{cpanmeta}&& $dist->{source}eq 'cpan'){$dist->{provides}=$dist->{cpanmeta}{provides}|| $self->extract_packages($dist->{cpanmeta},".")}my$root_target=(($self->{installdeps}or $self->{showdeps})and $depth==0);$dist->{want_phases}=$self->{notest}&&!$root_target ? [qw(build runtime)]: [qw(build test runtime)];push @{$dist->{want_phases}},'develop' if$self->{with_develop}&& $depth==0;my@deps=$self->find_prereqs($dist);my$module_name=$self->find_module_name($configure_state)|| $dist->{meta}{name};$module_name =~ s/-/::/g;if ($self->{showdeps}){for my$dep (@config_deps,@deps){print$dep->module,($dep->version ? ("~".$dep->version): ""),"\n"}return 1}my$distname=$dist->{meta}{name}? "$dist->{meta}{name}-$dist->{meta}{version}" : $stuff;my$walkup;if ($self->{scandeps}){$walkup=$self->scandeps_append_child($dist)}$self->install_deps_bailout($distname,$dist->{dir},$depth,@deps)or return;if ($self->{scandeps}){unless ($configure_state->{configured_ok}){my$diag=<<DIAG;if (@config_deps){my@tree=@{$self->{scandeps_tree}};$diag .= "!\n" .join("",map "! * $_->[0]{module}\n",@tree[0..$#tree-1])if@tree}$self->diag("!\n$diag!\n",1)}$walkup->();return 1}if ($self->{installdeps}&& $depth==0){if ($configure_state->{configured_ok}){$self->diag("<== Installed dependencies for $stuff. Finishing.\n");return 1}else {$self->diag("! Configuring $distname failed. See $self->{log} for details.\n",1);return}}my$installed;if ($configure_state->{use_module_build}&& -e 'Build' && -f _){$self->diag_progress("Building " .($self->{notest}? "" : "and testing ").$distname);$self->build([$self->{perl},"./Build" ],$distname,$depth)&& $self->test([$self->{perl},"./Build","test" ],$distname,$depth)&& $self->install([$self->{perl},"./Build","install" ],["--uninst",1 ],$depth)&& $installed++}elsif ($self->{make}&& -e 'Makefile'){$self->diag_progress("Building " .($self->{notest}? "" : "and testing ").$distname);$self->build([$self->{make}],$distname,$depth)&& $self->test([$self->{make},"test" ],$distname,$depth)&& $self->install([$self->{make},"install" ],["UNINST=1" ],$depth)&& $installed++}else {my$why;my$configure_failed=$configure_state->{configured}&&!$configure_state->{configured_ok};if ($configure_failed){$why="Configure failed for $distname."}elsif ($self->{make}){$why="The distribution doesn't have a proper Makefile.PL/Build.PL"}else {$why="Can't configure the distribution. You probably need to have 'make'."}$self->diag_fail("$why See $self->{log} for details.",1);return}if ($installed && $self->{test_only}){$self->diag_ok;$self->diag("Successfully tested $distname\n",1)}elsif ($installed){my$local=$self->{local_versions}{$dist->{module}|| ''};my$version=$dist->{module_version}|| $dist->{meta}{version}|| $dist->{version};my$reinstall=$local && ($local eq $version);my$action=$local &&!$reinstall ? $self->numify_ver($version)< $self->numify_ver($local)? "downgraded" : "upgraded" : undef;my$how=$reinstall ? "reinstalled $distname" : $local ? "installed $distname ($action from $local)" : "installed $distname" ;my$msg="Successfully $how";$self->diag_ok;$self->diag("$msg\n",1);$self->{installed_dists}++;$self->save_meta($stuff,$dist,$module_name,\@config_deps,\@deps);return 1}else {my$what=$self->{test_only}? "Testing" : "Installing";$self->diag_fail("$what $stuff failed. See $self->{log} for details. Retry with --force to force install it.",1);return}}sub perl_requirements {my($self,@requires)=@_;my@perl;for my$requires (grep defined,@requires){if (exists$requires->{perl}){push@perl,App::cpanminus::Dependency->new(perl=>$requires->{perl})}}return@perl}sub should_use_mm {my($self,$dist)=@_;my%should_use_mm=map {$_=>1}qw(version ExtUtils-ParseXS ExtUtils-Install ExtUtils-Manifest);$should_use_mm{$dist}}sub configure_this {my($self,$dist,$depth)=@_;if (-e $self->{cpanfile_path}&& $self->{installdeps}&& $depth==0){require Module::CPANfile;$dist->{cpanfile}=eval {Module::CPANfile->load($self->{cpanfile_path})};$self->diag_fail($@,1)if $@;return {configured=>1,configured_ok=>!!$dist->{cpanfile},use_module_build=>0,}}if ($self->{skip_configure}){my$eumm=-e 'Makefile';my$mb=-e 'Build' && -f _;return {configured=>1,configured_ok=>$eumm || $mb,use_module_build=>$mb,}}my$state={};my$try_eumm=sub {if (-e 'Makefile.PL'){$self->chat("Running Makefile.PL\n");if ($self->configure([$self->{perl},"Makefile.PL" ],$depth)){$state->{configured_ok}=-e 'Makefile'}$state->{configured}++}};my$try_mb=sub {if (-e 'Build.PL'){$self->chat("Running Build.PL\n");if ($self->configure([$self->{perl},"Build.PL" ],$depth)){$state->{configured_ok}=-e 'Build' && -f _}$state->{use_module_build}++;$state->{configured}++}};my@try;if ($dist->{dist}&& $self->should_use_mm($dist->{dist})){@try=($try_eumm,$try_mb)}else {@try=($try_mb,$try_eumm)}for my$try (@try){$try->();last if$state->{configured_ok}}unless ($state->{configured_ok}){while (1){my$ans=lc$self->prompt("Configuring $dist->{dist} failed.\nYou can s)kip, r)etry, e)xamine build log, or l)ook ?","s");last if$ans eq 's';return$self->configure_this($dist,$depth)if$ans eq 'r';$self->show_build_log if$ans eq 'e';$self->look if$ans eq 'l'}}return$state}sub find_module_name {my($self,$state)=@_;return unless$state->{configured_ok};if ($state->{use_module_build}&& -e "_build/build_params"){my$params=do {open my$in,"_build/build_params";$self->safe_eval(join "",<$in>)};return eval {$params->[2]{module_name}}|| undef}elsif (-e "Makefile"){open my$mf,"Makefile";while (<$mf>){if (/^\#\s+NAME\s+=>\s+(.*)/){return$self->safe_eval($1)}}}return}sub list_files {my$self=shift;if (-e 'MANIFEST'){require ExtUtils::Manifest;my$manifest=eval {ExtUtils::Manifest::manifind()}|| {};return sort {lc$a cmp lc$b}keys %$manifest}else {require File::Find;my@files;my$finder=sub {my$name=$File::Find::name;$name =~ s!\.[/\\]!!;push@files,$name};File::Find::find($finder,".");return sort {lc$a cmp lc$b}@files}}sub extract_packages {my($self,$meta,$dir)=@_;my$try=sub {my$file=shift;return 0 if$file =~ m!^(?:x?t|inc|local|perl5|fatlib|_build)/!;return 1 unless$meta->{no_index};return 0 if grep {$file =~ m!^$_/!}@{$meta->{no_index}{directory}|| []};return 0 if grep {$file eq $_}@{$meta->{no_index}{file}|| []};return 1};require Parse::PMFile;my@files=grep {/\.pm(?:\.PL)?$/ && $try->($_)}$self->list_files;my$provides={};for my$file (@files){my$parser=Parse::PMFile->new($meta,{UNSAFE=>1,ALLOW_DEV_VERSION=>1 });my$packages=$parser->parse($file);while (my($package,$meta)=each %$packages){$provides->{$package}||= {file=>$meta->{infile},($meta->{version}eq 'undef')? (): (version=>$meta->{version}),}}}return$provides}sub save_meta {my($self,$module,$dist,$module_name,$config_deps,$build_deps)=@_;return unless$dist->{distvname}&& $dist->{source}eq 'cpan';my$base=($ENV{PERL_MM_OPT}|| '')=~ /INSTALL_BASE=/ ? ($self->install_base($ENV{PERL_MM_OPT})."/lib/perl5"): $Config{sitelibexp};my$provides=$dist->{provides};File::Path::mkpath("blib/meta",0,0777);my$local={name=>$module_name,target=>$module,version=>exists$provides->{$module_name}? ($provides->{$module_name}{version}|| $dist->{version}): $dist->{version},dist=>$dist->{distvname},pathname=>$dist->{pathname},provides=>$provides,};require JSON::PP;open my$fh,">","blib/meta/install.json" or die $!;print$fh JSON::PP::encode_json($local);if (-e "MYMETA.json"){File::Copy::copy("MYMETA.json","blib/meta/MYMETA.json")}my@cmd=(($self->{sudo}? 'sudo' : ()),$^X,'-MExtUtils::Install=install','-e',qq[install({ 'blib/meta' => '$base/$Config{archname}/.meta/$dist->{distvname}' })],);$self->run(\@cmd)}sub _merge_hashref {my($self,@hashrefs)=@_;my%hash;for my$h (@hashrefs){%hash=(%hash,%$h)}return \%hash}sub install_base {my($self,$mm_opt)=@_;$mm_opt =~ /INSTALL_BASE=(\S+)/ and return $1;die "Your PERL_MM_OPT doesn't contain INSTALL_BASE"}sub safe_eval {my($self,$code)=@_;eval$code}sub configure_features {my($self,$dist,@features)=@_;map $_->identifier,grep {$self->effective_feature($dist,$_)}@features}sub effective_feature {my($self,$dist,$feature)=@_;if ($dist->{depth}==0){my$value=$self->{features}{$feature->identifier};return$value if defined$value;return 1 if$self->{features}{__all}}if ($self->{interactive}){require CPAN::Meta::Requirements;$self->diag("[@{[ $feature->description ]}]\n",1);my$req=CPAN::Meta::Requirements->new;for my$phase (@{$dist->{want_phases}}){for my$type (@{$self->{install_types}}){$req->add_requirements($feature->prereqs->requirements_for($phase,$type))}}my$reqs=$req->as_string_hash;my@missing;for my$module (keys %$reqs){if ($self->should_install($module,$req->{$module})){push@missing,$module}}if (@missing){my$howmany=@missing;$self->diag("==> Found missing dependencies: " .join(", ",@missing)."\n",1);local$self->{prompt}=1;return$self->prompt_bool("Install the $howmany optional module(s)?","y")}}return}sub find_prereqs {my($self,$dist)=@_;my@deps=$self->extract_meta_prereqs($dist);if ($dist->{module}=~ /^Bundle::/i){push@deps,$self->bundle_deps($dist)}if ($self->{cpanfile_requirements}&&!$dist->{cpanfile}){for my$dep (@deps){$dep->merge_with($self->{cpanfile_requirements})}}return@deps}sub extract_meta_prereqs {my($self,$dist)=@_;if ($dist->{cpanfile}){my@features=$self->configure_features($dist,$dist->{cpanfile}->features);my$prereqs=$dist->{cpanfile}->prereqs_with(@features);$self->{cpanfile_requirements}=$prereqs->merged_requirements($dist->{want_phases},['requires']);return App::cpanminus::Dependency->from_prereqs($prereqs,$dist->{want_phases},$self->{install_types})}require CPAN::Meta;my@deps;my($meta_file)=grep -f,qw(MYMETA.json MYMETA.yml);if ($meta_file){$self->chat("Checking dependencies from $meta_file ...\n");my$mymeta=eval {CPAN::Meta->load_file($meta_file,{lazy_validation=>1 })};if ($mymeta){$dist->{meta}{name}=$mymeta->name;$dist->{meta}{version}=$mymeta->version;return$self->extract_prereqs($mymeta,$dist)}}if (-e '_build/prereqs'){$self->chat("Checking dependencies from _build/prereqs ...\n");my$prereqs=do {open my$in,"_build/prereqs";$self->safe_eval(join "",<$in>)};my$meta=CPAN::Meta->new({name=>$dist->{meta}{name},version=>$dist->{meta}{version},%$prereqs },{lazy_validation=>1 },);@deps=$self->extract_prereqs($meta,$dist)}elsif (-e 'Makefile'){$self->chat("Finding PREREQ from Makefile ...\n");open my$mf,"Makefile";while (<$mf>){if (/^\#\s+PREREQ_PM => \{\s*(.*?)\s*\}/){my@all;my@pairs=split ', ',$1;for (@pairs){my ($pkg,$v)=split '=>',$_;push@all,[$pkg,$v ]}my$list=join ", ",map {"'$_->[0]' => $_->[1]"}@all;my$prereq=$self->safe_eval("no strict; +{ $list }");push@deps,App::cpanminus::Dependency->from_versions($prereq)if$prereq;last}}}return@deps}sub bundle_deps {my($self,$dist)=@_;my@files;File::Find::find({wanted=>sub {push@files,File::Spec->rel2abs($_)if /\.pm/i},no_chdir=>1,},'.');my@deps;for my$file (@files){open my$pod,"<",$file or next;my$in_contents;while (<$pod>){if (/^=head\d\s+CONTENTS/){$in_contents=1}elsif (/^=/){$in_contents=0}elsif ($in_contents){/^(\S+)\s*(\S+)?/ and push@deps,App::cpanminus::Dependency->new($1,$self->maybe_version($2))}}}return@deps}sub maybe_version {my($self,$string)=@_;return$string && $string =~ /^\.?\d/ ? $string : undef}sub extract_prereqs {my($self,$meta,$dist)=@_;my@features=$self->configure_features($dist,$meta->features);my$prereqs=$self->soften_makemaker_prereqs($meta->effective_prereqs(\@features)->clone);return App::cpanminus::Dependency->from_prereqs($prereqs,$dist->{want_phases},$self->{install_types})}sub soften_makemaker_prereqs {my($self,$prereqs)=@_;return$prereqs unless -e "inc/Module/Install.pm";for my$phase (qw(build test runtime)){my$reqs=$prereqs->requirements_for($phase,'requires');if ($reqs->requirements_for_module('ExtUtils::MakeMaker')){$reqs->clear_requirement('ExtUtils::MakeMaker');$reqs->add_minimum('ExtUtils::MakeMaker'=>0)}}$prereqs}sub cleanup_workdirs {my$self=shift;my$expire=time - 24 * 60 * 60 * $self->{auto_cleanup};my@targets;opendir my$dh,"$self->{home}/work";while (my$e=readdir$dh){next if$e !~ /^(\d+)\.\d+$/;my$time=$1;if ($time < $expire){push@targets,"$self->{home}/work/$e"}}if (@targets){if (@targets >= 64){$self->diag("Expiring " .scalar(@targets)." work directories. This might take a while...\n")}else {$self->chat("Expiring " .scalar(@targets)." work directories.\n")}File::Path::rmtree(\@targets,0,0)}}sub scandeps_append_child {my($self,$dist)=@_;my$new_node=[$dist,[]];my$curr_node=$self->{scandeps_current}|| [undef,$self->{scandeps_tree}];push @{$curr_node->[1]},$new_node;$self->{scandeps_current}=$new_node;return sub {$self->{scandeps_current}=$curr_node}}sub dump_scandeps {my$self=shift;if ($self->{format}eq 'tree'){$self->walk_down(sub {my($dist,$depth)=@_;if ($depth==0){print "$dist->{distvname}\n"}else {print " " x ($depth - 1);print "\\_ $dist->{distvname}\n"}},1)}elsif ($self->{format}=~ /^dists?$/){$self->walk_down(sub {my($dist,$depth)=@_;print$self->format_dist($dist),"\n"},0)}elsif ($self->{format}eq 'json'){require JSON::PP;print JSON::PP::encode_json($self->{scandeps_tree})}elsif ($self->{format}eq 'yaml'){require YAML;print YAML::Dump($self->{scandeps_tree})}else {$self->diag("Unknown format: $self->{format}\n")}}sub walk_down {my($self,$cb,$pre)=@_;$self->_do_walk_down($self->{scandeps_tree},$cb,0,$pre)}sub _do_walk_down {my($self,$children,$cb,$depth,$pre)=@_;for my$node (@$children){$cb->($node->[0],$depth)if$pre;$self->_do_walk_down($node->[1],$cb,$depth + 1,$pre);$cb->($node->[0],$depth)unless$pre}}sub DESTROY {my$self=shift;$self->{at_exit}->($self)if$self->{at_exit}}sub shell_quote {my($self,@stuff)=@_;if (WIN32){join ' ',map {/^${quote}.+${quote}$/ ? $_ : ($quote .$_ .$quote)}@stuff}else {String::ShellQuote::shell_quote_best_effort(@stuff)}}sub which {my($self,$name)=@_;if (File::Spec->file_name_is_absolute($name)){if (-x $name &&!-d _){return$name}}my$exe_ext=$Config{_exe};for my$dir (File::Spec->path){my$fullpath=File::Spec->catfile($dir,$name);if ((-x $fullpath || -x ($fullpath .= $exe_ext))&&!-d _){if ($fullpath =~ /\s/){$fullpath=$self->shell_quote($fullpath)}return$fullpath}}return}sub get {my($self,$uri)=@_;if ($uri =~ /^file:/){$self->file_get($uri)}else {$self->{_backends}{get}->(@_)}}sub mirror {my($self,$uri,$local)=@_;if ($uri =~ /^file:/){$self->file_mirror($uri,$local)}else {$self->{_backends}{mirror}->(@_)}}sub untar {$_[0]->{_backends}{untar}->(@_)};sub unzip {$_[0]->{_backends}{unzip}->(@_)};sub uri_to_file {my($self,$uri)=@_;if ($uri =~ s!file:/+!!){$uri="/$uri" unless$uri =~ m![a-zA-Z]:!}return$uri}sub file_get {my($self,$uri)=@_;my$file=$self->uri_to_file($uri);open my$fh,"<$file" or return;join '',<$fh>}sub file_mirror {my($self,$uri,$path)=@_;my$file=$self->uri_to_file($uri);File::Copy::copy($file,$path)}sub has_working_lwp {my($self,$mirrors)=@_;my$https=grep /^https:/,@$mirrors;eval {require LWP::UserAgent;LWP::UserAgent->VERSION(5.802);require LWP::Protocol::https if$https;1}}sub init_tools {my$self=shift;return if$self->{initialized}++;if ($self->{make}=$self->which($Config{make})){$self->chat("You have make $self->{make}\n")}if ($self->{try_lwp}&& $self->has_working_lwp($self->{mirrors})){$self->chat("You have LWP $LWP::VERSION\n");my$ua=sub {LWP::UserAgent->new(parse_head=>0,env_proxy=>1,agent=>$self->agent,timeout=>30,@_,)};$self->{_backends}{get}=sub {my$self=shift;my$res=$ua->()->request(HTTP::Request->new(GET=>$_[0]));return unless$res->is_success;return$res->decoded_content};$self->{_backends}{mirror}=sub {my$self=shift;my$res=$ua->()->mirror(@_);die$res->content if$res->code==501;$res->code}}elsif ($self->{try_wget}and my$wget=$self->which('wget')){$self->chat("You have $wget\n");my@common=('--user-agent',$self->agent,'--retry-connrefused',($self->{verbose}? (): ('-q')),);$self->{_backends}{get}=sub {my($self,$uri)=@_;$self->safeexec(my$fh,$wget,$uri,@common,'-O','-')or die "wget $uri: $!";local $/;<$fh>};$self->{_backends}{mirror}=sub {my($self,$uri,$path)=@_;$self->safeexec(my$fh,$wget,$uri,@common,'-O',$path)or die "wget $uri: $!";local $/;<$fh>}}elsif ($self->{try_curl}and my$curl=$self->which('curl')){$self->chat("You have $curl\n");my@common=('--location','--user-agent',$self->agent,($self->{verbose}? (): '-s'),);$self->{_backends}{get}=sub {my($self,$uri)=@_;$self->safeexec(my$fh,$curl,@common,$uri)or die "curl $uri: $!";local $/;<$fh>};$self->{_backends}{mirror}=sub {my($self,$uri,$path)=@_;$self->safeexec(my$fh,$curl,@common,$uri,'-#','-o',$path)or die "curl $uri: $!";local $/;<$fh>}}else {require HTTP::Tiny;$self->chat("Falling back to HTTP::Tiny $HTTP::Tiny::VERSION\n");my%common=(agent=>$self->agent,);$self->{_backends}{get}=sub {my$self=shift;my$res=HTTP::Tiny->new(%common)->get($_[0]);return unless$res->{success};return$res->{content}};$self->{_backends}{mirror}=sub {my$self=shift;my$res=HTTP::Tiny->new(%common)->mirror(@_);return$res->{status}}}my$tar=$self->which('tar');my$tar_ver;my$maybe_bad_tar=sub {WIN32 || BAD_TAR || (($tar_ver=`$tar --version 2>/dev/null`)=~ /GNU.*1\.13/i)};if ($tar &&!$maybe_bad_tar->()){chomp$tar_ver;$self->chat("You have $tar: $tar_ver\n");$self->{_backends}{untar}=sub {my($self,$tarfile)=@_;my$xf=($self->{verbose}? 'v' : '')."xf";my$ar=$tarfile =~ /bz2$/ ? 'j' : 'z';my($root,@others)=`$tar ${ar}tf $tarfile` or return undef;FILE: {chomp$root;$root =~ s!^\./!!;$root =~ s{^(.+?)/.*$}{$1};if (!length($root)){$root=shift(@others);redo FILE if$root}}system "$tar $ar$xf $tarfile";return$root if -d $root;$self->diag_fail("Bad archive: $tarfile");return undef}}elsif ($tar and my$gzip=$self->which('gzip')and my$bzip2=$self->which('bzip2')){$self->chat("You have $tar, $gzip and $bzip2\n");$self->{_backends}{untar}=sub {my($self,$tarfile)=@_;my$x="x" .($self->{verbose}? 'v' : '')."f -";my$ar=$tarfile =~ /bz2$/ ? $bzip2 : $gzip;my($root,@others)=`$ar -dc $tarfile | $tar tf -` or return undef;FILE: {chomp$root;$root =~ s!^\./!!;$root =~ s{^(.+?)/.*$}{$1};if (!length($root)){$root=shift(@others);redo FILE if$root}}system "$ar -dc $tarfile | $tar $x";return$root if -d $root;$self->diag_fail("Bad archive: $tarfile");return undef}}elsif (eval {require Archive::Tar}){$self->chat("Falling back to Archive::Tar $Archive::Tar::VERSION\n");$self->{_backends}{untar}=sub {my$self=shift;my$t=Archive::Tar->new($_[0]);my($root,@others)=$t->list_files;FILE: {$root =~ s!^\./!!;$root =~ s{^(.+?)/.*$}{$1};if (!length($root)){$root=shift(@others);redo FILE if$root}}$t->extract;return -d $root ? $root : undef}}else {$self->{_backends}{untar}=sub {die "Failed to extract $_[1] - You need to have tar or Archive::Tar installed.\n"}}if (my$unzip=$self->which('unzip')){$self->chat("You have $unzip\n");$self->{_backends}{unzip}=sub {my($self,$zipfile)=@_;my$opt=$self->{verbose}? '' : '-q';my(undef,$root,@others)=`$unzip -t $zipfile` or return undef;chomp$root;$root =~ s{^\s+testing:\s+([^/]+)/.*?\s+OK$}{$1};system "$unzip $opt $zipfile";return$root if -d $root;$self->diag_fail("Bad archive: [$root] $zipfile");return undef}}else {$self->{_backends}{unzip}=sub {eval {require Archive::Zip}or die "Failed to extract $_[1] - You need to have unzip or Archive::Zip installed.\n";my($self,$file)=@_;my$zip=Archive::Zip->new();my$status;$status=$zip->read($file);$self->diag_fail("Read of file[$file] failed")if$status!=Archive::Zip::AZ_OK();my@members=$zip->members();for my$member (@members){my$af=$member->fileName();next if ($af =~ m!^(/|\.\./)!);$status=$member->extractToFileNamed($af);$self->diag_fail("Extracting of file[$af] from zipfile[$file failed")if$status!=Archive::Zip::AZ_OK()}my ($root)=$zip->membersMatching(qr<^[^/]+/$>);$root &&= $root->fileName;return -d $root ? $root : undef}}}sub safeexec {my$self=shift;my$rdr=$_[0]||= Symbol::gensym();if (WIN32){my$cmd=$self->shell_quote(@_[1..$#_]);return open($rdr,"$cmd |")}if (my$pid=open($rdr,'-|')){return$pid}elsif (defined$pid){exec(@_[1 .. $#_ ]);exit 1}else {return}}sub mask_uri_passwords {my($self,@strings)=@_;s{ (https?://) ([^:/]+) : [^@/]+ @ }{$1$2:********@}gx for@strings;return@strings}1;
|
479
|
33
|
It appears your cpanm executable was installed via `perlbrew install-cpanm`.
|
480
|
34
|
cpanm --self-upgrade won't upgrade the version of cpanm you're running.
|
481
|
35
|
|
...
|
...
|
@@ -483,9 +37,7 @@ $fatpacked{"App/cpanminus/script.pm"} = <<'APP_CPANMINUS_SCRIPT';
|
483
|
37
|
|
484
|
38
|
perlbrew install-cpanm
|
485
|
39
|
|
486
|
|
- WARN
|
487
|
|
- } else {
|
488
|
|
- warn <<WARN;
|
|
40
|
+ DIE
|
489
|
41
|
You are running cpanm from the path where your current perl won't install executables to.
|
490
|
42
|
Because of that, cpanm --self-upgrade won't upgrade the version of cpanm you're running.
|
491
|
43
|
|
...
|
...
|
@@ -494,11698 +46,463 @@ $fatpacked{"App/cpanminus/script.pm"} = <<'APP_CPANMINUS_SCRIPT';
|
494
|
46
|
|
495
|
47
|
It means you either installed cpanm globally with system perl, or use distro packages such
|
496
|
48
|
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;
|
|
49
|
+ DIE
|
|
50
|
+ Usage: cpanm [options] Module [...]
|
729
|
51
|
|
730
|
|
- my $requirements = CPAN::Meta::Requirements->new;
|
731
|
|
- $requirements->add_string_requirement($module, $version || '0');
|
|
52
|
+ Try `cpanm --help` or `man cpanm` for more options.
|
|
53
|
+ USAGE
|
|
54
|
+ Usage: cpanm [options] Module [...]
|
732
|
55
|
|
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
|
|
56
|
+ Options:
|
|
57
|
+ -v,--verbose Turns on chatty output
|
|
58
|
+ -q,--quiet Turns off the most output
|
|
59
|
+ --interactive Turns on interactive configure (required for Task:: modules)
|
|
60
|
+ -f,--force force install
|
|
61
|
+ -n,--notest Do not run unit tests
|
|
62
|
+ --test-only Run tests only, do not install
|
|
63
|
+ -S,--sudo sudo to run install commands
|
|
64
|
+ --installdeps Only install dependencies
|
|
65
|
+ --showdeps Only display direct dependencies
|
|
66
|
+ --reinstall Reinstall the distribution even if you already have the latest version installed
|
|
67
|
+ --mirror Specify the base URL for the mirror (e.g. http://cpan.cpantesters.org/)
|
|
68
|
+ --mirror-only Use the mirror's index file instead of the CPAN Meta DB
|
|
69
|
+ -M,--from Use only this mirror base URL and its index file
|
|
70
|
+ --prompt Prompt when configure/build/test fails
|
|
71
|
+ -l,--local-lib Specify the install base to install modules
|
|
72
|
+ -L,--local-lib-contained Specify the install base to install all non-core modules
|
|
73
|
+ --self-contained Install all non-core modules, even if they're already installed.
|
|
74
|
+ --auto-cleanup Number of days that cpanm's work directories expire in. Defaults to 7
|
1006
|
75
|
|
1007
|
76
|
Commands:
|
1008
|
77
|
--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
|
|
- }
|
|
78
|
+ --info Displays distribution info on CPAN
|
|
79
|
+ --look Opens the distribution with your SHELL
|
|
80
|
+ -U,--uninstall Uninstalls the modules (EXPERIMENTAL)
|
|
81
|
+ -V,--version Displays software version
|
12013
|
82
|
|
12014
|
|
- sub qv {
|
12015
|
|
- my $value = shift;
|
12016
|
|
- my $class = 'version';
|
12017
|
|
- if (@_) {
|
12018
|
|
- $class = ref($value) || $value;
|
12019
|
|
- $value = shift;
|
12020
|
|
- }
|
|
83
|
+ Examples:
|
12021
|
84
|
|
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
|
|
- }
|
|
85
|
+ cpanm Test::More # install Test::More
|
|
86
|
+ cpanm MIYAGAWA/Plack-0.99_05.tar.gz # full distribution path
|
|
87
|
+ cpanm http://example.org/LDS/CGI.pm-3.20.tar.gz # install from URL
|
|
88
|
+ cpanm ~/dists/MyCompany-Enterprise-1.00.tar.gz # install from a local file
|
|
89
|
+ cpanm --interactive Task::Kensho # Configure interactively
|
|
90
|
+ cpanm . # install from local directory
|
|
91
|
+ cpanm --installdeps . # install all the deps for the current directory
|
|
92
|
+ cpanm -L extlib Plack # install Plack and all non-core deps into extlib
|
|
93
|
+ cpanm --mirror http://cpan.cpantesters.org/ DBI # use the fast-syncing mirror
|
|
94
|
+ cpanm -M https://cpan.metacpan.org App::perlbrew # use only this secure mirror and its index
|
12027
|
95
|
|
12028
|
|
- *declare = \&qv;
|
|
96
|
+ You can also specify the default options in PERL_CPANM_OPT environment variable in the shell rc:
|
12029
|
97
|
|
12030
|
|
- sub is_qv {
|
12031
|
|
- my ($self) = @_;
|
12032
|
|
- return (exists $self->{qv});
|
12033
|
|
- }
|
|
98
|
+ export PERL_CPANM_OPT="--prompt --reinstall -l ~/perl --mirror http://cpan.cpantesters.org"
|
12034
|
99
|
|
|
100
|
+ Type `man cpanm` or `perldoc cpanm` for the more detailed explanation of the options.
|
12035
|
101
|
|
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
|
|
- }
|
|
102
|
+ HELP
|
|
103
|
+ !
|
|
104
|
+ ! Can't write to $Config{installsitelib} and $Config{installsitebin}: Installing modules to $ENV{HOME}/perl5
|
|
105
|
+ ! To turn off this warning, you have to do one of the following:
|
|
106
|
+ ! - run me as a root or with --sudo option (to install to $Config{installsitelib} and $Config{installsitebin})
|
|
107
|
+ ! - Configure local::lib in your existing shell to set PERL_MM_OPT etc.
|
|
108
|
+ ! - Install local::lib by running the following commands
|
|
109
|
+ !
|
|
110
|
+ ! cpanm --local-lib=~/perl5 local::lib && eval \$(perl -I ~/perl5/lib/perl5/ -Mlocal::lib)
|
|
111
|
+ !
|
|
112
|
+ DIAG
|
|
113
|
+ WARNING: Your lib directory name ($base) contains a space in it. It's known to cause issues with perl builder tools such as local::lib and MakeMaker. You're recommended to rename your directory.
|
|
114
|
+ WARN
|
|
115
|
+ $module is not found in the following directories and can't be uninstalled.
|
12048
|
116
|
|
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
|
|
- }
|
|
117
|
+ @{[ join(" \n", map " $_", @inc) ]}
|
12059
|
118
|
|
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;
|
|
119
|
+ DIAG
|
|
120
|
+ package ModuleBuildSkipMan;
|
|
121
|
+ CHECK {
|
|
122
|
+ if (%Module::Build::) {
|
|
123
|
+ no warnings 'redefine';
|
|
124
|
+ *Module::Build::Base::ACTION_manpages = sub {};
|
|
125
|
+ *Module::Build::Base::ACTION_docs = sub {};
|
|
126
|
+ }
|
12079
|
127
|
}
|
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
|
|
- }
|
|
128
|
+ 1;
|
|
129
|
+ EOF
|
|
130
|
+ ! Configuring $distname failed. See $self->{log} for details.
|
|
131
|
+ ! You might have to install the following modules first to get --scandeps working correctly.
|
|
132
|
+ DIAG
|
|
133
|
+APP_CPANMINUS_SCRIPT
|
|
134
|
+
|
|
135
|
+$fatpacked{"CPAN/DistnameInfo.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_DISTNAMEINFO';
|
|
136
|
+ package CPAN::DistnameInfo;$VERSION="0.12";use strict;sub distname_info {my$file=shift or return;my ($dist,$version)=$file =~ /^
|
|
137
|
+ ((?:[-+.]*(?:[A-Za-z0-9]+|(?<=\D)_|_(?=\D))*
|
|
138
|
+ (?:
|
|
139
|
+ [A-Za-z](?=[^A-Za-z]|$)
|
|
140
|
+ |
|
|
141
|
+ \d(?=-)
|
|
142
|
+ )(?<![._-][vV])
|
|
143
|
+ )+)(.*)
|
|
144
|
+ $/xs or return ($file,undef,undef);if ($dist =~ /-undef\z/ and!length$version){$dist =~ s/-undef\z//}$version =~ s/-withoutworldwriteables$//;if ($version =~ /^(-[Vv].*)-(\d.*)/){$dist .= $1;$version=$2}if ($version =~ /(.+_.*)-(\d.*)/){$dist .= $1;$version=$2}$dist =~ s{\.pm$}{};$version=$1 if!length$version and $dist =~ s/-(\d+\w)$//;$version=$1 .$version if$version =~ /^\d+$/ and $dist =~ s/-(\w+)$//;if ($version =~ /\d\.\d/){$version =~ s/^[-_.]+//}else {$version =~ s/^[-_]+//}my$dev;if (length$version){if ($file =~ /^perl-?\d+\.(\d+)(?:\D(\d+))?(-(?:TRIAL|RC)\d+)?$/){$dev=1 if (($1 > 6 and $1 & 1)or ($2 and $2 >= 50))or $3}elsif ($version =~ /\d\D\d+_\d/ or $version =~ /-TRIAL/){$dev=1}}else {$version=undef}($dist,$version,$dev)}sub new {my$class=shift;my$distfile=shift;$distfile =~ s,//+,/,g;my%info=(pathname=>$distfile);($info{filename}=$distfile)=~ s,^(((.*?/)?authors/)?id/)?([A-Z])/(\4[A-Z])/(\5[-A-Z0-9]*)/,, and $info{cpanid}=$6;if ($distfile =~ m,([^/]+)\.(tar\.(?:g?z|bz2)|zip|tgz)$,i){$info{distvname}=$1;$info{extension}=$2}@info{qw(dist version beta)}=distname_info($info{distvname});$info{maturity}=delete$info{beta}? 'developer' : 'released';return bless \%info,$class}sub dist {shift->{dist}}sub version {shift->{version}}sub maturity {shift->{maturity}}sub filename {shift->{filename}}sub cpanid {shift->{cpanid}}sub distvname {shift->{distvname}}sub extension {shift->{extension}}sub pathname {shift->{pathname}}sub properties {%{$_[0]}}1;
|
|
145
|
+CPAN_DISTNAMEINFO
|
|
146
|
+
|
|
147
|
+$fatpacked{"CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META';
|
|
148
|
+ use 5.006;use strict;use warnings;package CPAN::Meta;our$VERSION='2.150005';use Carp qw(carp croak);use CPAN::Meta::Feature;use CPAN::Meta::Prereqs;use CPAN::Meta::Converter;use CPAN::Meta::Validator;use Parse::CPAN::Meta 1.4414 ();BEGIN {*_dclone=\&CPAN::Meta::Converter::_dclone}BEGIN {my@STRING_READERS=qw(abstract description dynamic_config generated_by name release_status version);no strict 'refs';for my$attr (@STRING_READERS){*$attr=sub {$_[0]{$attr }}}}BEGIN {my@LIST_READERS=qw(author keywords license);no strict 'refs';for my$attr (@LIST_READERS){*$attr=sub {my$value=$_[0]{$attr };croak "$attr must be called in list context" unless wantarray;return @{_dclone($value)}if ref$value;return$value}}}sub authors {$_[0]->author}sub licenses {$_[0]->license}BEGIN {my@MAP_READERS=qw(meta-spec resources provides no_index prereqs optional_features);no strict 'refs';for my$attr (@MAP_READERS){(my$subname=$attr)=~ s/-/_/;*$subname=sub {my$value=$_[0]{$attr };return _dclone($value)if$value;return {}}}}sub custom_keys {return grep {/^x_/i}keys %{$_[0]}}sub custom {my ($self,$attr)=@_;my$value=$self->{$attr};return _dclone($value)if ref$value;return$value}sub _new {my ($class,$struct,$options)=@_;my$self;if ($options->{lazy_validation}){my$cmc=CPAN::Meta::Converter->new($struct);$self=$cmc->convert(version=>2);return bless$self,$class}else {my$cmv=CPAN::Meta::Validator->new($struct);unless ($cmv->is_valid){die "Invalid metadata structure. Errors: " .join(", ",$cmv->errors)."\n"}}my$version=$struct->{'meta-spec'}{version}|| '1.0';if ($version==2){$self=$struct}else {my$cmc=CPAN::Meta::Converter->new($struct);$self=$cmc->convert(version=>2)}return bless$self,$class}sub new {my ($class,$struct,$options)=@_;my$self=eval {$class->_new($struct,$options)};croak($@)if $@;return$self}sub create {my ($class,$struct,$options)=@_;my$version=__PACKAGE__->VERSION || 2;$struct->{generated_by}||= __PACKAGE__ ." version $version" ;$struct->{'meta-spec'}{version}||= int($version);my$self=eval {$class->_new($struct,$options)};croak ($@)if $@;return$self}sub load_file {my ($class,$file,$options)=@_;$options->{lazy_validation}=1 unless exists$options->{lazy_validation};croak "load_file() requires a valid, readable filename" unless -r $file;my$self;eval {my$struct=Parse::CPAN::Meta->load_file($file);$self=$class->_new($struct,$options)};croak($@)if $@;return$self}sub load_yaml_string {my ($class,$yaml,$options)=@_;$options->{lazy_validation}=1 unless exists$options->{lazy_validation};my$self;eval {my ($struct)=Parse::CPAN::Meta->load_yaml_string($yaml);$self=$class->_new($struct,$options)};croak($@)if $@;return$self}sub load_json_string {my ($class,$json,$options)=@_;$options->{lazy_validation}=1 unless exists$options->{lazy_validation};my$self;eval {my$struct=Parse::CPAN::Meta->load_json_string($json);$self=$class->_new($struct,$options)};croak($@)if $@;return$self}sub load_string {my ($class,$string,$options)=@_;$options->{lazy_validation}=1 unless exists$options->{lazy_validation};my$self;eval {my$struct=Parse::CPAN::Meta->load_string($string);$self=$class->_new($struct,$options)};croak($@)if $@;return$self}sub save {my ($self,$file,$options)=@_;my$version=$options->{version}|| '2';my$layer=$] ge '5.008001' ? ':utf8' : '';if ($version ge '2'){carp "'$file' should end in '.json'" unless$file =~ m{\.json$}}else {carp "'$file' should end in '.yml'" unless$file =~ m{\.yml$}}my$data=$self->as_string($options);open my$fh,">$layer",$file or die "Error opening '$file' for writing: $!\n";print {$fh}$data;close$fh or die "Error closing '$file': $!\n";return 1}sub meta_spec_version {my ($self)=@_;return$self->meta_spec->{version}}sub effective_prereqs {my ($self,$features)=@_;$features ||= [];my$prereq=CPAN::Meta::Prereqs->new($self->prereqs);return$prereq unless @$features;my@other=map {;$self->feature($_)->prereqs}@$features;return$prereq->with_merged_prereqs(\@other)}sub should_index_file {my ($self,$filename)=@_;for my$no_index_file (@{$self->no_index->{file}|| []}){return if$filename eq $no_index_file}for my$no_index_dir (@{$self->no_index->{directory}}){$no_index_dir =~ s{$}{/} unless$no_index_dir =~ m{/\z};return if index($filename,$no_index_dir)==0}return 1}sub should_index_package {my ($self,$package)=@_;for my$no_index_pkg (@{$self->no_index->{package}|| []}){return if$package eq $no_index_pkg}for my$no_index_ns (@{$self->no_index->{namespace}}){return if index($package,"${no_index_ns}::")==0}return 1}sub features {my ($self)=@_;my$opt_f=$self->optional_features;my@features=map {;CPAN::Meta::Feature->new($_=>$opt_f->{$_ })}keys %$opt_f;return@features}sub feature {my ($self,$ident)=@_;croak "no feature named $ident" unless my$f=$self->optional_features->{$ident };return CPAN::Meta::Feature->new($ident,$f)}sub as_struct {my ($self,$options)=@_;my$struct=_dclone($self);if ($options->{version}){my$cmc=CPAN::Meta::Converter->new($struct);$struct=$cmc->convert(version=>$options->{version})}return$struct}sub as_string {my ($self,$options)=@_;my$version=$options->{version}|| '2';my$struct;if ($self->meta_spec_version ne $version){my$cmc=CPAN::Meta::Converter->new($self->as_struct);$struct=$cmc->convert(version=>$version)}else {$struct=$self->as_struct}my ($data,$backend);if ($version ge '2'){$backend=Parse::CPAN::Meta->json_backend();local$struct->{x_serialization_backend}=sprintf '%s version %s',$backend,$backend->VERSION;$data=$backend->new->pretty->canonical->encode($struct)}else {$backend=Parse::CPAN::Meta->yaml_backend();local$struct->{x_serialization_backend}=sprintf '%s version %s',$backend,$backend->VERSION;$data=eval {no strict 'refs';&{"$backend\::Dump"}($struct)};if ($@){croak$backend->can('errstr')? $backend->errstr : $@}}return$data}sub TO_JSON {return {%{$_[0]}}}1;
|
|
149
|
+CPAN_META
|
|
150
|
+
|
|
151
|
+$fatpacked{"CPAN/Meta/Check.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_CHECK';
|
|
152
|
+ package CPAN::Meta::Check;$CPAN::Meta::Check::VERSION='0.012';use strict;use warnings;use base 'Exporter';our@EXPORT=qw//;our@EXPORT_OK=qw/check_requirements requirements_for verify_dependencies/;our%EXPORT_TAGS=(all=>[@EXPORT,@EXPORT_OK ]);use CPAN::Meta::Prereqs '2.132830';use CPAN::Meta::Requirements 2.121;use Module::Metadata 1.000023;sub _check_dep {my ($reqs,$module,$dirs)=@_;$module eq 'perl' and return ($reqs->accepts_module($module,$])? (): sprintf "Your Perl (%s) is not in the range '%s'",$],$reqs->requirements_for_module($module));my$metadata=Module::Metadata->new_from_module($module,inc=>$dirs);return "Module '$module' is not installed" if not defined$metadata;my$version=eval {$metadata->version};return "Missing version info for module '$module'" if$reqs->requirements_for_module($module)and not $version;return sprintf 'Installed version (%s) of %s is not in range \'%s\'',$version,$module,$reqs->requirements_for_module($module)if not $reqs->accepts_module($module,$version || 0);return}sub _check_conflict {my ($reqs,$module,$dirs)=@_;my$metadata=Module::Metadata->new_from_module($module,inc=>$dirs);return if not defined$metadata;my$version=eval {$metadata->version};return "Missing version info for module '$module'" if not $version;return sprintf 'Installed version (%s) of %s is in range \'%s\'',$version,$module,$reqs->requirements_for_module($module)if$reqs->accepts_module($module,$version);return}sub requirements_for {my ($meta,$phases,$type)=@_;my$prereqs=ref($meta)eq 'CPAN::Meta' ? $meta->effective_prereqs : $meta;return$prereqs->merged_requirements(ref($phases)? $phases : [$phases ],[$type ])}sub check_requirements {my ($reqs,$type,$dirs)=@_;return +{map {$_=>$type ne 'conflicts' ? scalar _check_dep($reqs,$_,$dirs): scalar _check_conflict($reqs,$_,$dirs)}$reqs->required_modules }}sub verify_dependencies {my ($meta,$phases,$type,$dirs)=@_;my$reqs=requirements_for($meta,$phases,$type);my$issues=check_requirements($reqs,$type,$dirs);return grep {defined}values %{$issues}}1;
|
|
153
|
+CPAN_META_CHECK
|
|
154
|
+
|
|
155
|
+$fatpacked{"CPAN/Meta/Converter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_CONVERTER';
|
|
156
|
+ use 5.006;use strict;use warnings;package CPAN::Meta::Converter;our$VERSION='2.150005';use CPAN::Meta::Validator;use CPAN::Meta::Requirements;use Parse::CPAN::Meta 1.4400 ();BEGIN {eval "use version ()";if (my$err=$@){eval "use ExtUtils::MakeMaker::version" or die$err}}*_is_qv=version->can('is_qv')? sub {$_[0]->is_qv}: sub {exists $_[0]->{qv}};sub _dclone {my$ref=shift;no warnings 'once';no warnings 'redefine';local*UNIVERSAL::TO_JSON=sub {"$_[0]"};my$json=Parse::CPAN::Meta->json_backend()->new ->utf8 ->allow_blessed ->convert_blessed;$json->decode($json->encode($ref))}my%known_specs=('2'=>'http://search.cpan.org/perldoc?CPAN::Meta::Spec','1.4'=>'http://module-build.sourceforge.net/META-spec-v1.4.html','1.3'=>'http://module-build.sourceforge.net/META-spec-v1.3.html','1.2'=>'http://module-build.sourceforge.net/META-spec-v1.2.html','1.1'=>'http://module-build.sourceforge.net/META-spec-v1.1.html','1.0'=>'http://module-build.sourceforge.net/META-spec-v1.0.html');my@spec_list=sort {$a <=> $b}keys%known_specs;my ($LOWEST,$HIGHEST)=@spec_list[0,-1];sub _keep {$_[0]}sub _keep_or_one {defined($_[0])? $_[0]: 1}sub _keep_or_zero {defined($_[0])? $_[0]: 0}sub _keep_or_unknown {defined($_[0])&& length($_[0])? $_[0]: "unknown"}sub _generated_by {my$gen=shift;my$sig=__PACKAGE__ ." version " .(__PACKAGE__->VERSION || "<dev>");return$sig unless defined$gen and length$gen;return$gen if$gen =~ /\Q$sig/;return "$gen, $sig"}sub _listify {!defined $_[0]? undef : ref $_[0]eq 'ARRAY' ? $_[0]: [$_[0]]}sub _prefix_custom {my$key=shift;$key =~ s/^(?!x_) # Unless it already starts with x_
|
|
157
|
+ (?:x-?)? # Remove leading x- or x (if present)
|
|
158
|
+ /x_/ix;return$key}sub _ucfirst_custom {my$key=shift;$key=ucfirst$key unless$key =~ /[A-Z]/;return$key}sub _no_prefix_ucfirst_custom {my$key=shift;$key =~ s/^x_//;return _ucfirst_custom($key)}sub _change_meta_spec {my ($element,undef,undef,$version)=@_;return {version=>$version,url=>$known_specs{$version},}}my@open_source=('perl','gpl','apache','artistic','artistic_2','lgpl','bsd','gpl','mit','mozilla','open_source',);my%is_open_source=map {;$_=>1}@open_source;my@valid_licenses_1=(@open_source,'unrestricted','restrictive','unknown',);my%license_map_1=((map {$_=>$_}@valid_licenses_1),artistic2=>'artistic_2',);sub _license_1 {my ($element)=@_;return 'unknown' unless defined$element;if ($license_map_1{lc$element}){return$license_map_1{lc$element}}else {return 'unknown'}}my@valid_licenses_2=qw(agpl_3 apache_1_1 apache_2_0 artistic_1 artistic_2 bsd freebsd gfdl_1_2 gfdl_1_3 gpl_1 gpl_2 gpl_3 lgpl_2_1 lgpl_3_0 mit mozilla_1_0 mozilla_1_1 openssl perl_5 qpl_1_0 ssleay sun zlib open_source restricted unrestricted unknown);my%license_map_2=((map {$_=>$_}@valid_licenses_2),apache=>'apache_2_0',artistic=>'artistic_1',artistic2=>'artistic_2',gpl=>'open_source',lgpl=>'open_source',mozilla=>'open_source',perl=>'perl_5',restrictive=>'restricted',);sub _license_2 {my ($element)=@_;return ['unknown' ]unless defined$element;$element=[$element ]unless ref$element eq 'ARRAY';my@new_list;for my$lic (@$element){next unless defined$lic;if (my$new=$license_map_2{lc$lic}){push@new_list,$new}}return@new_list ? \@new_list : ['unknown' ]}my%license_downgrade_map=qw(agpl_3 open_source apache_1_1 apache apache_2_0 apache artistic_1 artistic artistic_2 artistic_2 bsd bsd freebsd open_source gfdl_1_2 open_source gfdl_1_3 open_source gpl_1 gpl gpl_2 gpl gpl_3 gpl lgpl_2_1 lgpl lgpl_3_0 lgpl mit mit mozilla_1_0 mozilla mozilla_1_1 mozilla openssl open_source perl_5 perl qpl_1_0 open_source ssleay open_source sun open_source zlib open_source open_source open_source restricted restrictive unrestricted unrestricted unknown unknown);sub _downgrade_license {my ($element)=@_;if (!defined$element){return "unknown"}elsif(ref$element eq 'ARRAY'){if (@$element > 1){if (grep {!$is_open_source{$license_downgrade_map{lc $_}|| 'unknown' }}@$element){return 'unknown'}else {return 'open_source'}}elsif (@$element==1){return$license_downgrade_map{lc$element->[0]}|| "unknown"}}elsif (!ref$element){return$license_downgrade_map{lc$element}|| "unknown"}return "unknown"}my$no_index_spec_1_2={'file'=>\&_listify,'dir'=>\&_listify,'package'=>\&_listify,'namespace'=>\&_listify,};my$no_index_spec_1_3={'file'=>\&_listify,'directory'=>\&_listify,'package'=>\&_listify,'namespace'=>\&_listify,};my$no_index_spec_2={'file'=>\&_listify,'directory'=>\&_listify,'package'=>\&_listify,'namespace'=>\&_listify,':custom'=>\&_prefix_custom,};sub _no_index_1_2 {my (undef,undef,$meta)=@_;my$no_index=$meta->{no_index}|| $meta->{private};return unless$no_index;if (!ref$no_index){my$item=$no_index;$no_index={dir=>[$item ],file=>[$item ]}}elsif (ref$no_index eq 'ARRAY'){my$list=$no_index;$no_index={dir=>[@$list ],file=>[@$list ]}}if (exists$no_index->{files}){$no_index->{file}=delete$no_index->{files}}if (exists$no_index->{modules}){$no_index->{module}=delete$no_index->{modules}}return _convert($no_index,$no_index_spec_1_2)}sub _no_index_directory {my ($element,$key,$meta,$version)=@_;return unless$element;if (!ref$element){my$item=$element;$element={directory=>[$item ],file=>[$item ]}}elsif (ref$element eq 'ARRAY'){my$list=$element;$element={directory=>[@$list ],file=>[@$list ]}}if (exists$element->{dir}){$element->{directory}=delete$element->{dir}}if (exists$element->{files}){$element->{file}=delete$element->{files}}if (exists$element->{modules}){$element->{module}=delete$element->{modules}}my$spec=$version==2 ? $no_index_spec_2 : $no_index_spec_1_3;return _convert($element,$spec)}sub _is_module_name {my$mod=shift;return unless defined$mod && length$mod;return$mod =~ m{^[A-Za-z][A-Za-z0-9_]*(?:::[A-Za-z0-9_]+)*$}}sub _clean_version {my ($element)=@_;return 0 if!defined$element;$element =~ s{^\s*}{};$element =~ s{\s*$}{};$element =~ s{^\.}{0.};return 0 if!length$element;return 0 if ($element eq 'undef' || $element eq '<undef>');my$v=eval {version->new($element)};if (defined$v){return _is_qv($v)? $v->normal : $element}else {return 0}}sub _bad_version_hook {my ($v)=@_;$v =~ s{^\s*}{};$v =~ s{\s*$}{};$v =~ s{[a-z]+$}{};my$vobj=eval {version->new($v)};return defined($vobj)? $vobj : version->new(0)}sub _version_map {my ($element)=@_;return unless defined$element;if (ref$element eq 'HASH'){my$new_map=CPAN::Meta::Requirements->new({bad_version_hook=>\&_bad_version_hook });while (my ($k,$v)=each %$element){next unless _is_module_name($k);if (!defined($v)||!length($v)|| $v eq 'undef' || $v eq '<undef>'){$v=0}if (_is_module_name($v)&&!version::is_lax($v)){$new_map->add_minimum($k=>0);$new_map->add_minimum($v=>0)}$new_map->add_string_requirement($k=>$v)}return$new_map->as_string_hash}elsif (ref$element eq 'ARRAY'){my$hashref={map {$_=>0}@$element };return _version_map($hashref)}elsif (ref$element eq '' && length$element){return {$element=>0 }}return}sub _prereqs_from_1 {my (undef,undef,$meta)=@_;my$prereqs={};for my$phase (qw/build configure/){my$key="${phase}_requires";$prereqs->{$phase}{requires}=_version_map($meta->{$key})if$meta->{$key}}for my$rel (qw/requires recommends conflicts/){$prereqs->{runtime}{$rel}=_version_map($meta->{$rel})if$meta->{$rel}}return$prereqs}my$prereqs_spec={configure=>\&_prereqs_rel,build=>\&_prereqs_rel,test=>\&_prereqs_rel,runtime=>\&_prereqs_rel,develop=>\&_prereqs_rel,':custom'=>\&_prefix_custom,};my$relation_spec={requires=>\&_version_map,recommends=>\&_version_map,suggests=>\&_version_map,conflicts=>\&_version_map,':custom'=>\&_prefix_custom,};sub _cleanup_prereqs {my ($prereqs,$key,$meta,$to_version)=@_;return unless$prereqs && ref$prereqs eq 'HASH';return _convert($prereqs,$prereqs_spec,$to_version)}sub _prereqs_rel {my ($relation,$key,$meta,$to_version)=@_;return unless$relation && ref$relation eq 'HASH';return _convert($relation,$relation_spec,$to_version)}BEGIN {my@old_prereqs=qw(requires configure_requires recommends conflicts);for (@old_prereqs){my$sub="_get_$_";my ($phase,$type)=split qr/_/,$_;if (!defined$type){$type=$phase;$phase='runtime'}no strict 'refs';*{$sub}=sub {_extract_prereqs($_[2]->{prereqs},$phase,$type)}}}sub _get_build_requires {my ($data,$key,$meta)=@_;my$test_h=_extract_prereqs($_[2]->{prereqs},qw(test requires))|| {};my$build_h=_extract_prereqs($_[2]->{prereqs},qw(build requires))|| {};my$test_req=CPAN::Meta::Requirements->from_string_hash($test_h);my$build_req=CPAN::Meta::Requirements->from_string_hash($build_h);$test_req->add_requirements($build_req)->as_string_hash}sub _extract_prereqs {my ($prereqs,$phase,$type)=@_;return unless ref$prereqs eq 'HASH';return scalar _version_map($prereqs->{$phase}{$type})}sub _downgrade_optional_features {my (undef,undef,$meta)=@_;return unless exists$meta->{optional_features};my$origin=$meta->{optional_features};my$features={};for my$name (keys %$origin){$features->{$name}={description=>$origin->{$name}{description},requires=>_extract_prereqs($origin->{$name}{prereqs},'runtime','requires'),configure_requires=>_extract_prereqs($origin->{$name}{prereqs},'runtime','configure_requires'),build_requires=>_extract_prereqs($origin->{$name}{prereqs},'runtime','build_requires'),recommends=>_extract_prereqs($origin->{$name}{prereqs},'runtime','recommends'),conflicts=>_extract_prereqs($origin->{$name}{prereqs},'runtime','conflicts'),};for my$k (keys %{$features->{$name}}){delete$features->{$name}{$k}unless defined$features->{$name}{$k}}}return$features}sub _upgrade_optional_features {my (undef,undef,$meta)=@_;return unless exists$meta->{optional_features};my$origin=$meta->{optional_features};my$features={};for my$name (keys %$origin){$features->{$name}={description=>$origin->{$name}{description},prereqs=>_prereqs_from_1(undef,undef,$origin->{$name}),};delete$features->{$name}{prereqs}{configure}}return$features}my$optional_features_2_spec={description=>\&_keep,prereqs=>\&_cleanup_prereqs,':custom'=>\&_prefix_custom,};sub _feature_2 {my ($element,$key,$meta,$to_version)=@_;return unless$element && ref$element eq 'HASH';_convert($element,$optional_features_2_spec,$to_version)}sub _cleanup_optional_features_2 {my ($element,$key,$meta,$to_version)=@_;return unless$element && ref$element eq 'HASH';my$new_data={};for my$k (keys %$element){$new_data->{$k}=_feature_2($element->{$k},$k,$meta,$to_version)}return unless keys %$new_data;return$new_data}sub _optional_features_1_4 {my ($element)=@_;return unless$element;$element=_optional_features_as_map($element);for my$name (keys %$element){for my$drop (qw/requires_packages requires_os excluded_os/){delete$element->{$name}{$drop}}}return$element}sub _optional_features_as_map {my ($element)=@_;return unless$element;if (ref$element eq 'ARRAY'){my%map;for my$feature (@$element){my (@parts)=%$feature;$map{$parts[0]}=$parts[1]}$element=\%map}return$element}sub _is_urlish {defined $_[0]&& $_[0]=~ m{\A[-+.a-z0-9]+:.+}i}sub _url_or_drop {my ($element)=@_;return$element if _is_urlish($element);return}sub _url_list {my ($element)=@_;return unless$element;$element=_listify($element);$element=[grep {_is_urlish($_)}@$element ];return unless @$element;return$element}sub _author_list {my ($element)=@_;return ['unknown' ]unless$element;$element=_listify($element);$element=[map {defined $_ && length $_ ? $_ : 'unknown'}@$element ];return ['unknown' ]unless @$element;return$element}my$resource2_upgrade={license=>sub {return _is_urlish($_[0])? _listify($_[0]): undef},homepage=>\&_url_or_drop,bugtracker=>sub {my ($item)=@_;return unless$item;if ($item =~ m{^mailto:(.*)$}){return {mailto=>$1 }}elsif(_is_urlish($item)){return {web=>$item }}else {return}},repository=>sub {return _is_urlish($_[0])? {url=>$_[0]}: undef},':custom'=>\&_prefix_custom,};sub _upgrade_resources_2 {my (undef,undef,$meta,$version)=@_;return unless exists$meta->{resources};return _convert($meta->{resources},$resource2_upgrade)}my$bugtracker2_spec={web=>\&_url_or_drop,mailto=>\&_keep,':custom'=>\&_prefix_custom,};sub _repo_type {my ($element,$key,$meta,$to_version)=@_;return$element if defined$element;return unless exists$meta->{url};my$repo_url=$meta->{url};for my$type (qw/git svn/){return$type if$repo_url =~ m{\A$type}}return}my$repository2_spec={web=>\&_url_or_drop,url=>\&_url_or_drop,type=>\&_repo_type,':custom'=>\&_prefix_custom,};my$resources2_cleanup={license=>\&_url_list,homepage=>\&_url_or_drop,bugtracker=>sub {ref $_[0]? _convert($_[0],$bugtracker2_spec): undef},repository=>sub {my$data=shift;ref$data ? _convert($data,$repository2_spec): undef},':custom'=>\&_prefix_custom,};sub _cleanup_resources_2 {my ($resources,$key,$meta,$to_version)=@_;return unless$resources && ref$resources eq 'HASH';return _convert($resources,$resources2_cleanup,$to_version)}my$resource1_spec={license=>\&_url_or_drop,homepage=>\&_url_or_drop,bugtracker=>\&_url_or_drop,repository=>\&_url_or_drop,':custom'=>\&_keep,};sub _resources_1_3 {my (undef,undef,$meta,$version)=@_;return unless exists$meta->{resources};return _convert($meta->{resources},$resource1_spec)}*_resources_1_4=*_resources_1_3;sub _resources_1_2 {my (undef,undef,$meta)=@_;my$resources=$meta->{resources}|| {};if ($meta->{license_url}&&!$resources->{license}){$resources->{license}=$meta->{license_url}if _is_urlish($meta->{license_url})}return unless keys %$resources;return _convert($resources,$resource1_spec)}my$resource_downgrade_spec={license=>sub {return ref $_[0]? $_[0]->[0]: $_[0]},homepage=>\&_url_or_drop,bugtracker=>sub {return $_[0]->{web}},repository=>sub {return $_[0]->{url}|| $_[0]->{web}},':custom'=>\&_no_prefix_ucfirst_custom,};sub _downgrade_resources {my (undef,undef,$meta,$version)=@_;return unless exists$meta->{resources};return _convert($meta->{resources},$resource_downgrade_spec)}sub _release_status {my ($element,undef,$meta)=@_;return$element if$element && $element =~ m{\A(?:stable|testing|unstable)\z};return _release_status_from_version(undef,undef,$meta)}sub _release_status_from_version {my (undef,undef,$meta)=@_;my$version=$meta->{version}|| '';return ($version =~ /_/)? 'testing' : 'stable'}my$provides_spec={file=>\&_keep,version=>\&_keep,};my$provides_spec_2={file=>\&_keep,version=>\&_keep,':custom'=>\&_prefix_custom,};sub _provides {my ($element,$key,$meta,$to_version)=@_;return unless defined$element && ref$element eq 'HASH';my$spec=$to_version==2 ? $provides_spec_2 : $provides_spec;my$new_data={};for my$k (keys %$element){$new_data->{$k}=_convert($element->{$k},$spec,$to_version);$new_data->{$k}{version}=_clean_version($element->{$k}{version})if exists$element->{$k}{version}}return$new_data}sub _convert {my ($data,$spec,$to_version,$is_fragment)=@_;my$new_data={};for my$key (keys %$spec){next if$key eq ':custom' || $key eq ':drop';next unless my$fcn=$spec->{$key};if ($is_fragment && $key eq 'generated_by'){$fcn=\&_keep}die "spec for '$key' is not a coderef" unless ref$fcn && ref$fcn eq 'CODE';my$new_value=$fcn->($data->{$key},$key,$data,$to_version);$new_data->{$key}=$new_value if defined$new_value}my$drop_list=$spec->{':drop'};my$customizer=$spec->{':custom'}|| \&_keep;for my$key (keys %$data){next if$drop_list && grep {$key eq $_}@$drop_list;next if exists$spec->{$key};$new_data->{$customizer->($key)}=$data->{$key}}return$new_data}my%up_convert=('2-from-1.4'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_2,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'release_status'=>\&_release_status,'keywords'=>\&_keep,'no_index'=>\&_no_index_directory,'optional_features'=>\&_upgrade_optional_features,'provides'=>\&_provides,'resources'=>\&_upgrade_resources_2,'description'=>\&_keep,'prereqs'=>\&_prereqs_from_1,':drop'=>[qw(build_requires configure_requires conflicts distribution_type license_url private recommends requires) ],':custom'=>\&_prefix_custom,},'1.4-from-1.3'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'keywords'=>\&_keep,'no_index'=>\&_no_index_directory,'optional_features'=>\&_optional_features_1_4,'provides'=>\&_provides,'recommends'=>\&_version_map,'requires'=>\&_version_map,'resources'=>\&_resources_1_4,'configure_requires'=>\&_keep,':drop'=>[qw(license_url private)],':custom'=>\&_keep },'1.3-from-1.2'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'keywords'=>\&_keep,'no_index'=>\&_no_index_directory,'optional_features'=>\&_optional_features_as_map,'provides'=>\&_provides,'recommends'=>\&_version_map,'requires'=>\&_version_map,'resources'=>\&_resources_1_3,':drop'=>[qw(license_url private)],':custom'=>\&_keep },'1.2-from-1.1'=>{'version'=>\&_keep,'license'=>\&_license_1,'name'=>\&_keep,'generated_by'=>\&_generated_by,'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'meta-spec'=>\&_change_meta_spec,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'recommends'=>\&_version_map,'requires'=>\&_version_map,'keywords'=>\&_keep,'no_index'=>\&_no_index_1_2,'optional_features'=>\&_optional_features_as_map,'provides'=>\&_provides,'resources'=>\&_resources_1_2,':drop'=>[qw(license_url private)],':custom'=>\&_keep },'1.1-from-1.0'=>{'version'=>\&_keep,'name'=>\&_keep,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'recommends'=>\&_version_map,'requires'=>\&_version_map,'license_url'=>\&_url_or_drop,'private'=>\&_keep,':custom'=>\&_keep },);my%down_convert=('1.4-from-2'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_downgrade_license,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'build_requires'=>\&_get_build_requires,'configure_requires'=>\&_get_configure_requires,'conflicts'=>\&_get_conflicts,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'keywords'=>\&_keep,'no_index'=>\&_no_index_directory,'optional_features'=>\&_downgrade_optional_features,'provides'=>\&_provides,'recommends'=>\&_get_recommends,'requires'=>\&_get_requires,'resources'=>\&_downgrade_resources,':drop'=>[qw(description prereqs release_status)],':custom'=>\&_keep },'1.3-from-1.4'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'keywords'=>\&_keep,'no_index'=>\&_no_index_directory,'optional_features'=>\&_optional_features_as_map,'provides'=>\&_provides,'recommends'=>\&_version_map,'requires'=>\&_version_map,'resources'=>\&_resources_1_3,':drop'=>[qw(configure_requires)],':custom'=>\&_keep,},'1.2-from-1.3'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'keywords'=>\&_keep,'no_index'=>\&_no_index_1_2,'optional_features'=>\&_optional_features_as_map,'provides'=>\&_provides,'recommends'=>\&_version_map,'requires'=>\&_version_map,'resources'=>\&_resources_1_3,':custom'=>\&_keep,},'1.1-from-1.2'=>{'version'=>\&_keep,'name'=>\&_keep,'meta-spec'=>\&_change_meta_spec,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'private'=>\&_keep,'recommends'=>\&_version_map,'requires'=>\&_version_map,':drop'=>[qw(abstract author provides no_index keywords resources)],':custom'=>\&_keep,},'1.0-from-1.1'=>{'name'=>\&_keep,'meta-spec'=>\&_change_meta_spec,'version'=>\&_keep,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'recommends'=>\&_version_map,'requires'=>\&_version_map,':custom'=>\&_keep,},);my%cleanup=('2'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_2,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'release_status'=>\&_release_status,'keywords'=>\&_keep,'no_index'=>\&_no_index_directory,'optional_features'=>\&_cleanup_optional_features_2,'provides'=>\&_provides,'resources'=>\&_cleanup_resources_2,'description'=>\&_keep,'prereqs'=>\&_cleanup_prereqs,':drop'=>[qw(build_requires configure_requires conflicts distribution_type license_url private recommends requires) ],':custom'=>\&_prefix_custom,},'1.4'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'keywords'=>\&_keep,'no_index'=>\&_no_index_directory,'optional_features'=>\&_optional_features_1_4,'provides'=>\&_provides,'recommends'=>\&_version_map,'requires'=>\&_version_map,'resources'=>\&_resources_1_4,'configure_requires'=>\&_keep,':custom'=>\&_keep },'1.3'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'keywords'=>\&_keep,'no_index'=>\&_no_index_directory,'optional_features'=>\&_optional_features_as_map,'provides'=>\&_provides,'recommends'=>\&_version_map,'requires'=>\&_version_map,'resources'=>\&_resources_1_3,':custom'=>\&_keep },'1.2'=>{'version'=>\&_keep,'license'=>\&_license_1,'name'=>\&_keep,'generated_by'=>\&_generated_by,'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'meta-spec'=>\&_change_meta_spec,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'recommends'=>\&_version_map,'requires'=>\&_version_map,'keywords'=>\&_keep,'no_index'=>\&_no_index_1_2,'optional_features'=>\&_optional_features_as_map,'provides'=>\&_provides,'resources'=>\&_resources_1_2,':custom'=>\&_keep },'1.1'=>{'version'=>\&_keep,'name'=>\&_keep,'meta-spec'=>\&_change_meta_spec,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'recommends'=>\&_version_map,'requires'=>\&_version_map,'license_url'=>\&_url_or_drop,'private'=>\&_keep,':custom'=>\&_keep },'1.0'=>{'name'=>\&_keep,'meta-spec'=>\&_change_meta_spec,'version'=>\&_keep,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'recommends'=>\&_version_map,'requires'=>\&_version_map,':custom'=>\&_keep,},);my%fragments_generate=('2'=>{'abstract'=>'abstract','author'=>'author','generated_by'=>'generated_by','license'=>'license','name'=>'name','version'=>'version','dynamic_config'=>'dynamic_config','release_status'=>'release_status','keywords'=>'keywords','no_index'=>'no_index','optional_features'=>'optional_features','provides'=>'provides','resources'=>'resources','description'=>'description','prereqs'=>'prereqs',},'1.4'=>{'abstract'=>'abstract','author'=>'author','generated_by'=>'generated_by','license'=>'license','name'=>'name','version'=>'version','build_requires'=>'prereqs','conflicts'=>'prereqs','distribution_type'=>'distribution_type','dynamic_config'=>'dynamic_config','keywords'=>'keywords','no_index'=>'no_index','optional_features'=>'optional_features','provides'=>'provides','recommends'=>'prereqs','requires'=>'prereqs','resources'=>'resources','configure_requires'=>'prereqs',},);$fragments_generate{$_}=$fragments_generate{'1.4'}for qw/1.3 1.2 1.1 1.0/;sub new {my ($class,$data,%args)=@_;my$self={'data'=>$data,'spec'=>_extract_spec_version($data,$args{default_version}),};return bless$self,$class}sub _extract_spec_version {my ($data,$default)=@_;my$spec=$data->{'meta-spec'};return($default || "1.0")unless defined$spec && ref$spec eq 'HASH';my$v=$spec->{version};if (defined$v && $v =~ /^\d+(?:\.\d+)?$/){return$v if defined$v && grep {$v eq $_}keys%known_specs;return$v+0 if defined$v && grep {$v==$_}keys%known_specs}return "2" if exists$data->{prereqs};return "1.4" if exists$data->{configure_requires};return($default || "1.2")}sub convert {my ($self,%args)=@_;my$args={%args };my$new_version=$args->{version}|| $HIGHEST;my$is_fragment=$args->{is_fragment};my ($old_version)=$self->{spec};my$converted=_dclone($self->{data});if ($old_version==$new_version){$converted=_convert($converted,$cleanup{$old_version},$old_version,$is_fragment);unless ($args->{is_fragment}){my$cmv=CPAN::Meta::Validator->new($converted);unless ($cmv->is_valid){my$errs=join("\n",$cmv->errors);die "Failed to clean-up $old_version metadata. Errors:\n$errs\n"}}return$converted}elsif ($old_version > $new_version){my@vers=sort {$b <=> $a}keys%known_specs;for my$i (0 .. $#vers-1){next if$vers[$i]> $old_version;last if$vers[$i+1]< $new_version;my$spec_string="$vers[$i+1]-from-$vers[$i]";$converted=_convert($converted,$down_convert{$spec_string},$vers[$i+1],$is_fragment);unless ($args->{is_fragment}){my$cmv=CPAN::Meta::Validator->new($converted);unless ($cmv->is_valid){my$errs=join("\n",$cmv->errors);die "Failed to downconvert metadata to $vers[$i+1]. Errors:\n$errs\n"}}}return$converted}else {my@vers=sort {$a <=> $b}keys%known_specs;for my$i (0 .. $#vers-1){next if$vers[$i]< $old_version;last if$vers[$i+1]> $new_version;my$spec_string="$vers[$i+1]-from-$vers[$i]";$converted=_convert($converted,$up_convert{$spec_string},$vers[$i+1],$is_fragment);unless ($args->{is_fragment}){my$cmv=CPAN::Meta::Validator->new($converted);unless ($cmv->is_valid){my$errs=join("\n",$cmv->errors);die "Failed to upconvert metadata to $vers[$i+1]. Errors:\n$errs\n"}}}return$converted}}sub upgrade_fragment {my ($self)=@_;my ($old_version)=$self->{spec};my%expected=map {;$_=>1}grep {defined}map {$fragments_generate{$old_version}{$_}}keys %{$self->{data}};my$converted=$self->convert(version=>$HIGHEST,is_fragment=>1);for my$key (keys %$converted){next if$key =~ /^x_/i || $key eq 'meta-spec';delete$converted->{$key}unless$expected{$key}}return$converted}1;
|
|
159
|
+CPAN_META_CONVERTER
|
|
160
|
+
|
|
161
|
+$fatpacked{"CPAN/Meta/Feature.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_FEATURE';
|
|
162
|
+ use 5.006;use strict;use warnings;package CPAN::Meta::Feature;our$VERSION='2.150005';use CPAN::Meta::Prereqs;sub new {my ($class,$identifier,$spec)=@_;my%guts=(identifier=>$identifier,description=>$spec->{description},prereqs=>CPAN::Meta::Prereqs->new($spec->{prereqs}),);bless \%guts=>$class}sub identifier {$_[0]{identifier}}sub description {$_[0]{description}}sub prereqs {$_[0]{prereqs}}1;
|
|
163
|
+CPAN_META_FEATURE
|
|
164
|
+
|
|
165
|
+$fatpacked{"CPAN/Meta/History.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_HISTORY';
|
|
166
|
+ use 5.006;use strict;use warnings;package CPAN::Meta::History;our$VERSION='2.150005';1;
|
|
167
|
+CPAN_META_HISTORY
|
|
168
|
+
|
|
169
|
+$fatpacked{"CPAN/Meta/Merge.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_MERGE';
|
|
170
|
+ use strict;use warnings;package CPAN::Meta::Merge;our$VERSION='2.150005';use Carp qw/croak/;use Scalar::Util qw/blessed/;use CPAN::Meta::Converter 2.141170;sub _is_identical {my ($left,$right)=@_;return (not defined$left and not defined$right)|| (defined$left and defined$right and $left eq $right)}sub _identical {my ($left,$right,$path)=@_;croak sprintf "Can't merge attribute %s: '%s' does not equal '%s'",join('.',@{$path}),$left,$right unless _is_identical($left,$right);return$left}sub _merge {my ($current,$next,$mergers,$path)=@_;for my$key (keys %{$next}){if (not exists$current->{$key}){$current->{$key}=$next->{$key}}elsif (my$merger=$mergers->{$key}){$current->{$key}=$merger->($current->{$key},$next->{$key},[@{$path},$key ])}elsif ($merger=$mergers->{':default'}){$current->{$key}=$merger->($current->{$key},$next->{$key},[@{$path},$key ])}else {croak sprintf "Can't merge unknown attribute '%s'",join '.',@{$path},$key}}return$current}sub _uniq {my%seen=();return grep {not $seen{$_}++}@_}sub _set_addition {my ($left,$right)=@_;return [+_uniq(@{$left},@{$right})]}sub _uniq_map {my ($left,$right,$path)=@_;for my$key (keys %{$right}){if (not exists$left->{$key}){$left->{$key}=$right->{$key}}elsif (_is_identical($left->{$key},$right->{$key})){1}elsif (ref$left->{$key}eq 'HASH' and ref$right->{$key}eq 'HASH'){$left->{$key}=_uniq_map($left->{$key},$right->{$key},[@{$path},$key ])}else {croak 'Duplication of element ' .join '.',@{$path},$key}}return$left}sub _improvize {my ($left,$right,$path)=@_;my ($name)=reverse @{$path};if ($name =~ /^x_/){if (ref($left)eq 'ARRAY'){return _set_addition($left,$right,$path)}elsif (ref($left)eq 'HASH'){return _uniq_map($left,$right,$path)}else {return _identical($left,$right,$path)}}croak sprintf "Can't merge '%s'",join '.',@{$path}}sub _optional_features {my ($left,$right,$path)=@_;for my$key (keys %{$right}){if (not exists$left->{$key}){$left->{$key}=$right->{$key}}else {for my$subkey (keys %{$right->{$key}}){next if$subkey eq 'prereqs';if (not exists$left->{$key}{$subkey}){$left->{$key}{$subkey}=$right->{$key}{$subkey}}else {Carp::croak "Cannot merge two optional_features named '$key' with different '$subkey' values" if do {no warnings 'uninitialized';$left->{$key}{$subkey}ne $right->{$key}{$subkey}}}}require CPAN::Meta::Prereqs;$left->{$key}{prereqs}=CPAN::Meta::Prereqs->new($left->{$key}{prereqs})->with_merged_prereqs(CPAN::Meta::Prereqs->new($right->{$key}{prereqs}))->as_string_hash}}return$left}my%default=(abstract=>\&_identical,author=>\&_set_addition,dynamic_config=>sub {my ($left,$right)=@_;return$left || $right},generated_by=>sub {my ($left,$right)=@_;return join ', ',_uniq(split(/, /,$left),split(/, /,$right))},license=>\&_set_addition,'meta-spec'=>{version=>\&_identical,url=>\&_identical },name=>\&_identical,release_status=>\&_identical,version=>\&_identical,description=>\&_identical,keywords=>\&_set_addition,no_index=>{map {($_=>\&_set_addition)}qw/file directory package namespace/ },optional_features=>\&_optional_features,prereqs=>sub {require CPAN::Meta::Prereqs;my ($left,$right)=map {CPAN::Meta::Prereqs->new($_)}@_[0,1];return$left->with_merged_prereqs($right)->as_string_hash},provides=>\&_uniq_map,resources=>{license=>\&_set_addition,homepage=>\&_identical,bugtracker=>\&_uniq_map,repository=>\&_uniq_map,':default'=>\&_improvize,},':default'=>\&_improvize,);sub new {my ($class,%arguments)=@_;croak 'default version required' if not exists$arguments{default_version};my%mapping=%default;my%extra=%{$arguments{extra_mappings}|| {}};for my$key (keys%extra){if (ref($mapping{$key})eq 'HASH'){$mapping{$key}={%{$mapping{$key}},%{$extra{$key}}}}else {$mapping{$key}=$extra{$key}}}return bless {default_version=>$arguments{default_version},mapping=>_coerce_mapping(\%mapping,[]),},$class}my%coderef_for=(set_addition=>\&_set_addition,uniq_map=>\&_uniq_map,identical=>\&_identical,improvize=>\&_improvize,);sub _coerce_mapping {my ($orig,$map_path)=@_;my%ret;for my$key (keys %{$orig}){my$value=$orig->{$key};if (ref($orig->{$key})eq 'CODE'){$ret{$key}=$value}elsif (ref($value)eq 'HASH'){my$mapping=_coerce_mapping($value,[@{$map_path},$key ]);$ret{$key}=sub {my ($left,$right,$path)=@_;return _merge($left,$right,$mapping,[@{$path}])}}elsif ($coderef_for{$value}){$ret{$key}=$coderef_for{$value}}else {croak "Don't know what to do with " .join '.',@{$map_path},$key}}return \%ret}sub merge {my ($self,@items)=@_;my$current={};for my$next (@items){if (blessed($next)&& $next->isa('CPAN::Meta')){$next=$next->as_struct}elsif (ref($next)eq 'HASH'){my$cmc=CPAN::Meta::Converter->new($next,default_version=>$self->{default_version});$next=$cmc->upgrade_fragment}else {croak "Don't know how to merge '$next'"}$current=_merge($current,$next,$self->{mapping},[])}return$current}1;
|
|
171
|
+CPAN_META_MERGE
|
|
172
|
+
|
|
173
|
+$fatpacked{"CPAN/Meta/Prereqs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_PREREQS';
|
|
174
|
+ use 5.006;use strict;use warnings;package CPAN::Meta::Prereqs;our$VERSION='2.150005';use Carp qw(confess);use Scalar::Util qw(blessed);use CPAN::Meta::Requirements 2.121;sub __legal_phases {qw(configure build test runtime develop)}sub __legal_types {qw(requires recommends suggests conflicts)}sub new {my ($class,$prereq_spec)=@_;$prereq_spec ||= {};my%is_legal_phase=map {;$_=>1}$class->__legal_phases;my%is_legal_type=map {;$_=>1}$class->__legal_types;my%guts;PHASE: for my$phase (keys %$prereq_spec){next PHASE unless$phase =~ /\Ax_/i or $is_legal_phase{$phase};my$phase_spec=$prereq_spec->{$phase };next PHASE unless keys %$phase_spec;TYPE: for my$type (keys %$phase_spec){next TYPE unless$type =~ /\Ax_/i or $is_legal_type{$type};my$spec=$phase_spec->{$type };next TYPE unless keys %$spec;$guts{prereqs}{$phase}{$type}=CPAN::Meta::Requirements->from_string_hash($spec)}}return bless \%guts=>$class}sub requirements_for {my ($self,$phase,$type)=@_;confess "requirements_for called without phase" unless defined$phase;confess "requirements_for called without type" unless defined$type;unless ($phase =~ /\Ax_/i or grep {$phase eq $_}$self->__legal_phases){confess "requested requirements for unknown phase: $phase"}unless ($type =~ /\Ax_/i or grep {$type eq $_}$self->__legal_types){confess "requested requirements for unknown type: $type"}my$req=($self->{prereqs}{$phase}{$type}||= CPAN::Meta::Requirements->new);$req->finalize if$self->is_finalized;return$req}sub with_merged_prereqs {my ($self,$other)=@_;my@other=blessed($other)? $other : @$other;my@prereq_objs=($self,@other);my%new_arg;for my$phase ($self->__legal_phases){for my$type ($self->__legal_types){my$req=CPAN::Meta::Requirements->new;for my$prereq (@prereq_objs){my$this_req=$prereq->requirements_for($phase,$type);next unless$this_req->required_modules;$req->add_requirements($this_req)}next unless$req->required_modules;$new_arg{$phase }{$type }=$req->as_string_hash}}return (ref$self)->new(\%new_arg)}sub merged_requirements {my ($self,$phases,$types)=@_;$phases=[qw/runtime build test/]unless defined$phases;$types=[qw/requires recommends/]unless defined$types;confess "merged_requirements phases argument must be an arrayref" unless ref$phases eq 'ARRAY';confess "merged_requirements types argument must be an arrayref" unless ref$types eq 'ARRAY';my$req=CPAN::Meta::Requirements->new;for my$phase (@$phases){unless ($phase =~ /\Ax_/i or grep {$phase eq $_}$self->__legal_phases){confess "requested requirements for unknown phase: $phase"}for my$type (@$types){unless ($type =~ /\Ax_/i or grep {$type eq $_}$self->__legal_types){confess "requested requirements for unknown type: $type"}$req->add_requirements($self->requirements_for($phase,$type))}}$req->finalize if$self->is_finalized;return$req}sub as_string_hash {my ($self)=@_;my%hash;for my$phase ($self->__legal_phases){for my$type ($self->__legal_types){my$req=$self->requirements_for($phase,$type);next unless$req->required_modules;$hash{$phase }{$type }=$req->as_string_hash}}return \%hash}sub is_finalized {$_[0]{finalized}}sub finalize {my ($self)=@_;$self->{finalized}=1;for my$phase (keys %{$self->{prereqs}}){$_->finalize for values %{$self->{prereqs}{$phase}}}}sub clone {my ($self)=@_;my$clone=(ref$self)->new($self->as_string_hash)}1;
|
|
175
|
+CPAN_META_PREREQS
|
|
176
|
+
|
|
177
|
+$fatpacked{"CPAN/Meta/Requirements.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_REQUIREMENTS';
|
|
178
|
+ use strict;use warnings;package CPAN::Meta::Requirements;our$VERSION='2.133';use Carp ();BEGIN {eval "use version ()";if (my$err=$@){eval "use ExtUtils::MakeMaker::version" or die$err}}*_is_qv=version->can('is_qv')? sub {$_[0]->is_qv}: sub {exists $_[0]->{qv}};my$V0=version->new(0);my@valid_options=qw(bad_version_hook);sub new {my ($class,$options)=@_;$options ||= {};Carp::croak "Argument to $class\->new() must be a hash reference" unless ref$options eq 'HASH';my%self=map {;$_=>$options->{$_}}@valid_options;return bless \%self=>$class}sub _find_magic_vstring {my$value=shift;my$tvalue='';require B;my$sv=B::svref_2object(\$value);my$magic=ref($sv)eq 'B::PVMG' ? $sv->MAGIC : undef;while ($magic){if ($magic->TYPE eq 'V'){$tvalue=$magic->PTR;$tvalue =~ s/^v?(.+)$/v$1/;last}else {$magic=$magic->MOREMAGIC}}return$tvalue}sub _isa_version {UNIVERSAL::isa($_[0],'UNIVERSAL')&& $_[0]->isa('version')}sub _version_object {my ($self,$module,$version)=@_;my ($vobj,$err);if (not defined$version or (!ref($version)&& $version eq '0')){return$V0}elsif (ref($version)eq 'version' || _isa_version($version)){$vobj=$version}else {if ($INC{'version/vpp.pm'}|| $INC{'ExtUtils/MakeMaker/version/vpp.pm'}){my$magic=_find_magic_vstring($version);$version=$magic if length$magic}eval {local$SIG{__WARN__}=sub {die "Invalid version: $_[0]"};$vobj=version->new($version)};if (my$err=$@){my$hook=$self->{bad_version_hook};$vobj=eval {$hook->($version,$module)}if ref$hook eq 'CODE';unless (eval {$vobj->isa("version")}){$err =~ s{ at .* line \d+.*$}{};die "Can't convert '$version': $err"}}}if ($vobj =~ m{\A\.}){$vobj=version->new("0$vobj")}if (_is_qv($vobj)){$vobj=version->new($vobj->normal)}return$vobj}BEGIN {for my$type (qw(maximum exclusion exact_version)){my$method="with_$type";my$to_add=$type eq 'exact_version' ? $type : "add_$type";my$code=sub {my ($self,$name,$version)=@_;$version=$self->_version_object($name,$version);$self->__modify_entry_for($name,$method,$version);return$self};no strict 'refs';*$to_add=$code}}sub add_minimum {my ($self,$name,$version)=@_;if (not defined$version or "$version" eq '0'){return$self if$self->__entry_for($name);Carp::confess("can't add new requirements to finalized requirements")if$self->is_finalized;$self->{requirements}{$name }=CPAN::Meta::Requirements::_Range::Range->with_minimum($V0)}else {$version=$self->_version_object($name,$version);$self->__modify_entry_for($name,'with_minimum',$version)}return$self}sub add_requirements {my ($self,$req)=@_;for my$module ($req->required_modules){my$modifiers=$req->__entry_for($module)->as_modifiers;for my$modifier (@$modifiers){my ($method,@args)=@$modifier;$self->$method($module=>@args)}}return$self}sub accepts_module {my ($self,$module,$version)=@_;$version=$self->_version_object($module,$version);return 1 unless my$range=$self->__entry_for($module);return$range->_accepts($version)}sub clear_requirement {my ($self,$module)=@_;return$self unless$self->__entry_for($module);Carp::confess("can't clear requirements on finalized requirements")if$self->is_finalized;delete$self->{requirements}{$module };return$self}sub requirements_for_module {my ($self,$module)=@_;my$entry=$self->__entry_for($module);return unless$entry;return$entry->as_string}sub required_modules {keys %{$_[0]{requirements}}}sub clone {my ($self)=@_;my$new=(ref$self)->new;return$new->add_requirements($self)}sub __entry_for {$_[0]{requirements}{$_[1]}}sub __modify_entry_for {my ($self,$name,$method,$version)=@_;my$fin=$self->is_finalized;my$old=$self->__entry_for($name);Carp::confess("can't add new requirements to finalized requirements")if$fin and not $old;my$new=($old || 'CPAN::Meta::Requirements::_Range::Range')->$method($version);Carp::confess("can't modify finalized requirements")if$fin and $old->as_string ne $new->as_string;$self->{requirements}{$name }=$new}sub is_simple {my ($self)=@_;for my$module ($self->required_modules){return if$self->__entry_for($module)->as_string =~ /\s/}return 1}sub is_finalized {$_[0]{finalized}}sub finalize {$_[0]{finalized}=1}sub as_string_hash {my ($self)=@_;my%hash=map {;$_=>$self->{requirements}{$_}->as_string}$self->required_modules;return \%hash}my%methods_for_op=('=='=>[qw(exact_version) ],'!='=>[qw(add_exclusion) ],'>='=>[qw(add_minimum) ],'<='=>[qw(add_maximum) ],'>'=>[qw(add_minimum add_exclusion) ],'<'=>[qw(add_maximum add_exclusion) ],);sub add_string_requirement {my ($self,$module,$req)=@_;unless (defined$req && length$req){$req=0;$self->_blank_carp($module)}my$magic=_find_magic_vstring($req);if (length$magic){$self->add_minimum($module=>$magic);return}my@parts=split qr{\s*,\s*},$req;for my$part (@parts){my ($op,$ver)=$part =~ m{\A\s*(==|>=|>|<=|<|!=)\s*(.*)\z};if (!defined$op){$self->add_minimum($module=>$part)}else {Carp::confess("illegal requirement string: $req")unless my$methods=$methods_for_op{$op };$self->$_($module=>$ver)for @$methods}}}sub _blank_carp {my ($self,$module)=@_;Carp::carp("Undefined requirement for $module treated as '0'")}sub from_string_hash {my ($class,$hash,$options)=@_;my$self=$class->new($options);for my$module (keys %$hash){my$req=$hash->{$module};unless (defined$req && length$req){$req=0;$class->_blank_carp($module)}$self->add_string_requirement($module,$req)}return$self}{package CPAN::Meta::Requirements::_Range::Exact;sub _new {bless {version=>$_[1]}=>$_[0]}sub _accepts {return $_[0]{version}==$_[1]}sub as_string {return "== $_[0]{version}"}sub as_modifiers {return [[exact_version=>$_[0]{version}]]}sub _clone {(ref $_[0])->_new(version->new($_[0]{version}))}sub with_exact_version {my ($self,$version)=@_;return$self->_clone if$self->_accepts($version);Carp::confess("illegal requirements: unequal exact version specified")}sub with_minimum {my ($self,$minimum)=@_;return$self->_clone if$self->{version}>= $minimum;Carp::confess("illegal requirements: minimum above exact specification")}sub with_maximum {my ($self,$maximum)=@_;return$self->_clone if$self->{version}<= $maximum;Carp::confess("illegal requirements: maximum below exact specification")}sub with_exclusion {my ($self,$exclusion)=@_;return$self->_clone unless$exclusion==$self->{version};Carp::confess("illegal requirements: excluded exact specification")}}{package CPAN::Meta::Requirements::_Range::Range;sub _self {ref($_[0])? $_[0]: (bless {}=>$_[0])}sub _clone {return (bless {}=>$_[0])unless ref $_[0];my ($s)=@_;my%guts=((exists$s->{minimum}? (minimum=>version->new($s->{minimum})): ()),(exists$s->{maximum}? (maximum=>version->new($s->{maximum})): ()),(exists$s->{exclusions}? (exclusions=>[map {version->new($_)}@{$s->{exclusions}}]): ()),);bless \%guts=>ref($s)}sub as_modifiers {my ($self)=@_;my@mods;push@mods,[add_minimum=>$self->{minimum}]if exists$self->{minimum};push@mods,[add_maximum=>$self->{maximum}]if exists$self->{maximum};push@mods,map {;[add_exclusion=>$_ ]}@{$self->{exclusions}|| []};return \@mods}sub as_string {my ($self)=@_;return 0 if!keys %$self;return "$self->{minimum}" if (keys %$self)==1 and exists$self->{minimum};my@exclusions=@{$self->{exclusions}|| []};my@parts;for my$pair ([qw(>= > minimum) ],[qw(<= < maximum) ],){my ($op,$e_op,$k)=@$pair;if (exists$self->{$k}){my@new_exclusions=grep {$_!=$self->{$k }}@exclusions;if (@new_exclusions==@exclusions){push@parts,"$op $self->{ $k }"}else {push@parts,"$e_op $self->{ $k }";@exclusions=@new_exclusions}}}push@parts,map {;"!= $_"}@exclusions;return join q{, },@parts}sub with_exact_version {my ($self,$version)=@_;$self=$self->_clone;Carp::confess("illegal requirements: exact specification outside of range")unless$self->_accepts($version);return CPAN::Meta::Requirements::_Range::Exact->_new($version)}sub _simplify {my ($self)=@_;if (defined$self->{minimum}and defined$self->{maximum}){if ($self->{minimum}==$self->{maximum}){Carp::confess("illegal requirements: excluded all values")if grep {$_==$self->{minimum}}@{$self->{exclusions}|| []};return CPAN::Meta::Requirements::_Range::Exact->_new($self->{minimum})}Carp::confess("illegal requirements: minimum exceeds maximum")if$self->{minimum}> $self->{maximum}}if ($self->{exclusions}){my%seen;@{$self->{exclusions}}=grep {(!defined$self->{minimum}or $_ >= $self->{minimum})and (!defined$self->{maximum}or $_ <= $self->{maximum})and !$seen{$_}++}@{$self->{exclusions}}}return$self}sub with_minimum {my ($self,$minimum)=@_;$self=$self->_clone;if (defined (my$old_min=$self->{minimum})){$self->{minimum}=(sort {$b cmp $a}($minimum,$old_min))[0]}else {$self->{minimum}=$minimum}return$self->_simplify}sub with_maximum {my ($self,$maximum)=@_;$self=$self->_clone;if (defined (my$old_max=$self->{maximum})){$self->{maximum}=(sort {$a cmp $b}($maximum,$old_max))[0]}else {$self->{maximum}=$maximum}return$self->_simplify}sub with_exclusion {my ($self,$exclusion)=@_;$self=$self->_clone;push @{$self->{exclusions}||= []},$exclusion;return$self->_simplify}sub _accepts {my ($self,$version)=@_;return if defined$self->{minimum}and $version < $self->{minimum};return if defined$self->{maximum}and $version > $self->{maximum};return if defined$self->{exclusions}and grep {$version==$_}@{$self->{exclusions}};return 1}}1;
|
|
179
|
+CPAN_META_REQUIREMENTS
|
|
180
|
+
|
|
181
|
+$fatpacked{"CPAN/Meta/Spec.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_SPEC';
|
|
182
|
+ use 5.006;use strict;use warnings;package CPAN::Meta::Spec;our$VERSION='2.150005';1;
|
|
183
|
+CPAN_META_SPEC
|
|
184
|
+
|
|
185
|
+$fatpacked{"CPAN/Meta/Validator.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_VALIDATOR';
|
|
186
|
+ use 5.006;use strict;use warnings;package CPAN::Meta::Validator;our$VERSION='2.150005';my%known_specs=('1.4'=>'http://module-build.sourceforge.net/META-spec-v1.4.html','1.3'=>'http://module-build.sourceforge.net/META-spec-v1.3.html','1.2'=>'http://module-build.sourceforge.net/META-spec-v1.2.html','1.1'=>'http://module-build.sourceforge.net/META-spec-v1.1.html','1.0'=>'http://module-build.sourceforge.net/META-spec-v1.0.html');my%known_urls=map {$known_specs{$_}=>$_}keys%known_specs;my$module_map1={'map'=>{':key'=>{name=>\&module,value=>\&exversion }}};my$module_map2={'map'=>{':key'=>{name=>\&module,value=>\&version }}};my$no_index_2={'map'=>{file=>{list=>{value=>\&string }},directory=>{list=>{value=>\&string }},'package'=>{list=>{value=>\&string }},namespace=>{list=>{value=>\&string }},':key'=>{name=>\&custom_2,value=>\&anything },}};my$no_index_1_3={'map'=>{file=>{list=>{value=>\&string }},directory=>{list=>{value=>\&string }},'package'=>{list=>{value=>\&string }},namespace=>{list=>{value=>\&string }},':key'=>{name=>\&string,value=>\&anything },}};my$no_index_1_2={'map'=>{file=>{list=>{value=>\&string }},dir=>{list=>{value=>\&string }},'package'=>{list=>{value=>\&string }},namespace=>{list=>{value=>\&string }},':key'=>{name=>\&string,value=>\&anything },}};my$no_index_1_1={'map'=>{':key'=>{name=>\&string,list=>{value=>\&string }},}};my$prereq_map={map=>{':key'=>{name=>\&phase,'map'=>{':key'=>{name=>\&relation,%$module_map1,},},}},};my%definitions=('2'=>{'abstract'=>{mandatory=>1,value=>\&string },'author'=>{mandatory=>1,list=>{value=>\&string }},'dynamic_config'=>{mandatory=>1,value=>\&boolean },'generated_by'=>{mandatory=>1,value=>\&string },'license'=>{mandatory=>1,list=>{value=>\&license }},'meta-spec'=>{mandatory=>1,'map'=>{version=>{mandatory=>1,value=>\&version},url=>{value=>\&url },':key'=>{name=>\&custom_2,value=>\&anything },}},'name'=>{mandatory=>1,value=>\&string },'release_status'=>{mandatory=>1,value=>\&release_status },'version'=>{mandatory=>1,value=>\&version },'description'=>{value=>\&string },'keywords'=>{list=>{value=>\&string }},'no_index'=>$no_index_2,'optional_features'=>{'map'=>{':key'=>{name=>\&string,'map'=>{description=>{value=>\&string },prereqs=>$prereq_map,':key'=>{name=>\&custom_2,value=>\&anything },}}}},'prereqs'=>$prereq_map,'provides'=>{'map'=>{':key'=>{name=>\&module,'map'=>{file=>{mandatory=>1,value=>\&file },version=>{value=>\&version },':key'=>{name=>\&custom_2,value=>\&anything },}}}},'resources'=>{'map'=>{license=>{list=>{value=>\&url }},homepage=>{value=>\&url },bugtracker=>{'map'=>{web=>{value=>\&url },mailto=>{value=>\&string},':key'=>{name=>\&custom_2,value=>\&anything },}},repository=>{'map'=>{web=>{value=>\&url },url=>{value=>\&url },type=>{value=>\&string },':key'=>{name=>\&custom_2,value=>\&anything },}},':key'=>{value=>\&string,name=>\&custom_2 },}},':key'=>{name=>\&custom_2,value=>\&anything },},'1.4'=>{'meta-spec'=>{mandatory=>1,'map'=>{version=>{mandatory=>1,value=>\&version},url=>{mandatory=>1,value=>\&urlspec },':key'=>{name=>\&string,value=>\&anything },},},'name'=>{mandatory=>1,value=>\&string },'version'=>{mandatory=>1,value=>\&version },'abstract'=>{mandatory=>1,value=>\&string },'author'=>{mandatory=>1,list=>{value=>\&string }},'license'=>{mandatory=>1,value=>\&license },'generated_by'=>{mandatory=>1,value=>\&string },'distribution_type'=>{value=>\&string },'dynamic_config'=>{value=>\&boolean },'requires'=>$module_map1,'recommends'=>$module_map1,'build_requires'=>$module_map1,'configure_requires'=>$module_map1,'conflicts'=>$module_map2,'optional_features'=>{'map'=>{':key'=>{name=>\&string,'map'=>{description=>{value=>\&string },requires=>$module_map1,recommends=>$module_map1,build_requires=>$module_map1,conflicts=>$module_map2,':key'=>{name=>\&string,value=>\&anything },}}}},'provides'=>{'map'=>{':key'=>{name=>\&module,'map'=>{file=>{mandatory=>1,value=>\&file },version=>{value=>\&version },':key'=>{name=>\&string,value=>\&anything },}}}},'no_index'=>$no_index_1_3,'private'=>$no_index_1_3,'keywords'=>{list=>{value=>\&string }},'resources'=>{'map'=>{license=>{value=>\&url },homepage=>{value=>\&url },bugtracker=>{value=>\&url },repository=>{value=>\&url },':key'=>{value=>\&string,name=>\&custom_1 },}},':key'=>{name=>\&string,value=>\&anything },},'1.3'=>{'meta-spec'=>{mandatory=>1,'map'=>{version=>{mandatory=>1,value=>\&version},url=>{mandatory=>1,value=>\&urlspec },':key'=>{name=>\&string,value=>\&anything },},},'name'=>{mandatory=>1,value=>\&string },'version'=>{mandatory=>1,value=>\&version },'abstract'=>{mandatory=>1,value=>\&string },'author'=>{mandatory=>1,list=>{value=>\&string }},'license'=>{mandatory=>1,value=>\&license },'generated_by'=>{mandatory=>1,value=>\&string },'distribution_type'=>{value=>\&string },'dynamic_config'=>{value=>\&boolean },'requires'=>$module_map1,'recommends'=>$module_map1,'build_requires'=>$module_map1,'conflicts'=>$module_map2,'optional_features'=>{'map'=>{':key'=>{name=>\&string,'map'=>{description=>{value=>\&string },requires=>$module_map1,recommends=>$module_map1,build_requires=>$module_map1,conflicts=>$module_map2,':key'=>{name=>\&string,value=>\&anything },}}}},'provides'=>{'map'=>{':key'=>{name=>\&module,'map'=>{file=>{mandatory=>1,value=>\&file },version=>{value=>\&version },':key'=>{name=>\&string,value=>\&anything },}}}},'no_index'=>$no_index_1_3,'private'=>$no_index_1_3,'keywords'=>{list=>{value=>\&string }},'resources'=>{'map'=>{license=>{value=>\&url },homepage=>{value=>\&url },bugtracker=>{value=>\&url },repository=>{value=>\&url },':key'=>{value=>\&string,name=>\&custom_1 },}},':key'=>{name=>\&string,value=>\&anything },},'1.2'=>{'meta-spec'=>{mandatory=>1,'map'=>{version=>{mandatory=>1,value=>\&version},url=>{mandatory=>1,value=>\&urlspec },':key'=>{name=>\&string,value=>\&anything },},},'name'=>{mandatory=>1,value=>\&string },'version'=>{mandatory=>1,value=>\&version },'license'=>{mandatory=>1,value=>\&license },'generated_by'=>{mandatory=>1,value=>\&string },'author'=>{mandatory=>1,list=>{value=>\&string }},'abstract'=>{mandatory=>1,value=>\&string },'distribution_type'=>{value=>\&string },'dynamic_config'=>{value=>\&boolean },'keywords'=>{list=>{value=>\&string }},'private'=>$no_index_1_2,'$no_index'=>$no_index_1_2,'requires'=>$module_map1,'recommends'=>$module_map1,'build_requires'=>$module_map1,'conflicts'=>$module_map2,'optional_features'=>{'map'=>{':key'=>{name=>\&string,'map'=>{description=>{value=>\&string },requires=>$module_map1,recommends=>$module_map1,build_requires=>$module_map1,conflicts=>$module_map2,':key'=>{name=>\&string,value=>\&anything },}}}},'provides'=>{'map'=>{':key'=>{name=>\&module,'map'=>{file=>{mandatory=>1,value=>\&file },version=>{value=>\&version },':key'=>{name=>\&string,value=>\&anything },}}}},'resources'=>{'map'=>{license=>{value=>\&url },homepage=>{value=>\&url },bugtracker=>{value=>\&url },repository=>{value=>\&url },':key'=>{value=>\&string,name=>\&custom_1 },}},':key'=>{name=>\&string,value=>\&anything },},'1.1'=>{'name'=>{value=>\&string },'version'=>{mandatory=>1,value=>\&version },'license'=>{value=>\&license },'generated_by'=>{value=>\&string },'license_uri'=>{value=>\&url },'distribution_type'=>{value=>\&string },'dynamic_config'=>{value=>\&boolean },'private'=>$no_index_1_1,'requires'=>$module_map1,'recommends'=>$module_map1,'build_requires'=>$module_map1,'conflicts'=>$module_map2,':key'=>{name=>\&string,value=>\&anything },},'1.0'=>{'name'=>{value=>\&string },'version'=>{mandatory=>1,value=>\&version },'license'=>{value=>\&license },'generated_by'=>{value=>\&string },'license_uri'=>{value=>\&url },'distribution_type'=>{value=>\&string },'dynamic_config'=>{value=>\&boolean },'requires'=>$module_map1,'recommends'=>$module_map1,'build_requires'=>$module_map1,'conflicts'=>$module_map2,':key'=>{name=>\&string,value=>\&anything },},);sub new {my ($class,$data)=@_;my$self={'data'=>$data,'spec'=>eval {$data->{'meta-spec'}{'version'}}|| "1.0",'errors'=>undef,};return bless$self,$class}sub is_valid {my$self=shift;my$data=$self->{data};my$spec_version=$self->{spec};$self->check_map($definitions{$spec_version},$data);return!$self->errors}sub errors {my$self=shift;return ()unless(defined$self->{errors});return @{$self->{errors}}}my$spec_error="Missing validation action in specification. " ."Must be one of 'map', 'list', or 'value'";sub check_map {my ($self,$spec,$data)=@_;if(ref($spec)ne 'HASH'){$self->_error("Unknown META specification, cannot validate.");return}if(ref($data)ne 'HASH'){$self->_error("Expected a map structure from string or file.");return}for my$key (keys %$spec){next unless($spec->{$key}->{mandatory});next if(defined$data->{$key});push @{$self->{stack}},$key;$self->_error("Missing mandatory field, '$key'");pop @{$self->{stack}}}for my$key (keys %$data){push @{$self->{stack}},$key;if($spec->{$key}){if($spec->{$key}{value}){$spec->{$key}{value}->($self,$key,$data->{$key})}elsif($spec->{$key}{'map'}){$self->check_map($spec->{$key}{'map'},$data->{$key})}elsif($spec->{$key}{'list'}){$self->check_list($spec->{$key}{'list'},$data->{$key})}else {$self->_error("$spec_error for '$key'")}}elsif ($spec->{':key'}){$spec->{':key'}{name}->($self,$key,$key);if($spec->{':key'}{value}){$spec->{':key'}{value}->($self,$key,$data->{$key})}elsif($spec->{':key'}{'map'}){$self->check_map($spec->{':key'}{'map'},$data->{$key})}elsif($spec->{':key'}{'list'}){$self->check_list($spec->{':key'}{'list'},$data->{$key})}else {$self->_error("$spec_error for ':key'")}}else {$self->_error("Unknown key, '$key', found in map structure")}pop @{$self->{stack}}}}sub check_list {my ($self,$spec,$data)=@_;if(ref($data)ne 'ARRAY'){$self->_error("Expected a list structure");return}if(defined$spec->{mandatory}){if(!defined$data->[0]){$self->_error("Missing entries from mandatory list")}}for my$value (@$data){push @{$self->{stack}},$value || "<undef>";if(defined$spec->{value}){$spec->{value}->($self,'list',$value)}elsif(defined$spec->{'map'}){$self->check_map($spec->{'map'},$value)}elsif(defined$spec->{'list'}){$self->check_list($spec->{'list'},$value)}elsif ($spec->{':key'}){$self->check_map($spec,$value)}else {$self->_error("$spec_error associated with '$self->{stack}[-2]'")}pop @{$self->{stack}}}}sub header {my ($self,$key,$value)=@_;if(defined$value){return 1 if($value && $value =~ /^--- #YAML:1.0/)}$self->_error("file does not have a valid YAML header.");return 0}sub release_status {my ($self,$key,$value)=@_;if(defined$value){my$version=$self->{data}{version}|| '';if ($version =~ /_/){return 1 if ($value =~ /\A(?:testing|unstable)\z/);$self->_error("'$value' for '$key' is invalid for version '$version'")}else {return 1 if ($value =~ /\A(?:stable|testing|unstable)\z/);$self->_error("'$value' for '$key' is invalid")}}else {$self->_error("'$key' is not defined")}return 0}sub _uri_split {return $_[0]=~ m,(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?,}sub url {my ($self,$key,$value)=@_;if(defined$value){my ($scheme,$auth,$path,$query,$frag)=_uri_split($value);unless (defined$scheme && length$scheme){$self->_error("'$value' for '$key' does not have a URL scheme");return 0}unless (defined$auth && length$auth){$self->_error("'$value' for '$key' does not have a URL authority");return 0}return 1}$value ||= '';$self->_error("'$value' for '$key' is not a valid URL.");return 0}sub urlspec {my ($self,$key,$value)=@_;if(defined$value){return 1 if($value && $known_specs{$self->{spec}}eq $value);if($value && $known_urls{$value}){$self->_error('META specification URL does not match version');return 0}}$self->_error('Unknown META specification');return 0}sub anything {return 1}sub string {my ($self,$key,$value)=@_;if(defined$value){return 1 if($value || $value =~ /^0$/)}$self->_error("value is an undefined string");return 0}sub string_or_undef {my ($self,$key,$value)=@_;return 1 unless(defined$value);return 1 if($value || $value =~ /^0$/);$self->_error("No string defined for '$key'");return 0}sub file {my ($self,$key,$value)=@_;return 1 if(defined$value);$self->_error("No file defined for '$key'");return 0}sub exversion {my ($self,$key,$value)=@_;if(defined$value && ($value || $value =~ /0/)){my$pass=1;for(split(",",$value)){$self->version($key,$_)or ($pass=0)}return$pass}$value='<undef>' unless(defined$value);$self->_error("'$value' for '$key' is not a valid version.");return 0}sub version {my ($self,$key,$value)=@_;if(defined$value){return 0 unless($value || $value =~ /0/);return 1 if($value =~ /^\s*((<|<=|>=|>|!=|==)\s*)?v?\d+((\.\d+((_|\.)\d+)?)?)/)}else {$value='<undef>'}$self->_error("'$value' for '$key' is not a valid version.");return 0}sub boolean {my ($self,$key,$value)=@_;if(defined$value){return 1 if($value =~ /^(0|1|true|false)$/)}else {$value='<undef>'}$self->_error("'$value' for '$key' is not a boolean value.");return 0}my%v1_licenses=('perl'=>'http://dev.perl.org/licenses/','gpl'=>'http://www.opensource.org/licenses/gpl-license.php','apache'=>'http://apache.org/licenses/LICENSE-2.0','artistic'=>'http://opensource.org/licenses/artistic-license.php','artistic_2'=>'http://opensource.org/licenses/artistic-license-2.0.php','lgpl'=>'http://www.opensource.org/licenses/lgpl-license.php','bsd'=>'http://www.opensource.org/licenses/bsd-license.php','gpl'=>'http://www.opensource.org/licenses/gpl-license.php','mit'=>'http://opensource.org/licenses/mit-license.php','mozilla'=>'http://opensource.org/licenses/mozilla1.1.php','open_source'=>undef,'unrestricted'=>undef,'restrictive'=>undef,'unknown'=>undef,);my%v2_licenses=map {$_=>1}qw(agpl_3 apache_1_1 apache_2_0 artistic_1 artistic_2 bsd freebsd gfdl_1_2 gfdl_1_3 gpl_1 gpl_2 gpl_3 lgpl_2_1 lgpl_3_0 mit mozilla_1_0 mozilla_1_1 openssl perl_5 qpl_1_0 ssleay sun zlib open_source restricted unrestricted unknown);sub license {my ($self,$key,$value)=@_;my$licenses=$self->{spec}< 2 ? \%v1_licenses : \%v2_licenses;if(defined$value){return 1 if($value && exists$licenses->{$value})}else {$value='<undef>'}$self->_error("License '$value' is invalid");return 0}sub custom_1 {my ($self,$key)=@_;if(defined$key){return 1 if($key && $key =~ /^[_a-z]+$/i && $key =~ /[A-Z]/)}else {$key='<undef>'}$self->_error("Custom resource '$key' must be in CamelCase.");return 0}sub custom_2 {my ($self,$key)=@_;if(defined$key){return 1 if($key && $key =~ /^x_/i)}else {$key='<undef>'}$self->_error("Custom key '$key' must begin with 'x_' or 'X_'.");return 0}sub identifier {my ($self,$key)=@_;if(defined$key){return 1 if($key && $key =~ /^([a-z][_a-z]+)$/i)}else {$key='<undef>'}$self->_error("Key '$key' is not a legal identifier.");return 0}sub module {my ($self,$key)=@_;if(defined$key){return 1 if($key && $key =~ /^[A-Za-z0-9_]+(::[A-Za-z0-9_]+)*$/)}else {$key='<undef>'}$self->_error("Key '$key' is not a legal module name.");return 0}my@valid_phases=qw/configure build test runtime develop/;sub phase {my ($self,$key)=@_;if(defined$key){return 1 if(length$key && grep {$key eq $_}@valid_phases);return 1 if$key =~ /x_/i}else {$key='<undef>'}$self->_error("Key '$key' is not a legal phase.");return 0}my@valid_relations=qw/requires recommends suggests conflicts/;sub relation {my ($self,$key)=@_;if(defined$key){return 1 if(length$key && grep {$key eq $_}@valid_relations);return 1 if$key =~ /x_/i}else {$key='<undef>'}$self->_error("Key '$key' is not a legal prereq relationship.");return 0}sub _error {my$self=shift;my$mess=shift;$mess .= ' ('.join(' -> ',@{$self->{stack}}).')' if($self->{stack});$mess .= " [Validation: $self->{spec}]";push @{$self->{errors}},$mess}1;
|
|
187
|
+CPAN_META_VALIDATOR
|
|
188
|
+
|
|
189
|
+$fatpacked{"CPAN/Meta/YAML.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_YAML';
|
|
190
|
+ use 5.008001;use strict;use warnings;package CPAN::Meta::YAML;$CPAN::Meta::YAML::VERSION='0.016';;use Exporter;our@ISA=qw{Exporter};our@EXPORT=qw{Load Dump};our@EXPORT_OK=qw{LoadFile DumpFile freeze thaw};sub Dump {return CPAN::Meta::YAML->new(@_)->_dump_string}sub Load {my$self=CPAN::Meta::YAML->_load_string(@_);if (wantarray){return @$self}else {return$self->[-1]}}BEGIN {*freeze=\&Dump;*thaw=\&Load}sub DumpFile {my$file=shift;return CPAN::Meta::YAML->new(@_)->_dump_file($file)}sub LoadFile {my$file=shift;my$self=CPAN::Meta::YAML->_load_file($file);if (wantarray){return @$self}else {return$self->[-1]}}sub new {my$class=shift;bless [@_ ],$class}sub read_string {my$self=shift;$self->_load_string(@_)}sub write_string {my$self=shift;$self->_dump_string(@_)}sub read {my$self=shift;$self->_load_file(@_)}sub write {my$self=shift;$self->_dump_file(@_)}my@UNPRINTABLE=qw(0 x01 x02 x03 x04 x05 x06 a b t n v f r x0E x0F x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x1A e x1C x1D x1E x1F);my%UNESCAPES=(0=>"\x00",z=>"\x00",N=>"\x85",a=>"\x07",b=>"\x08",t=>"\x09",n=>"\x0a",v=>"\x0b",f=>"\x0c",r=>"\x0d",e=>"\x1b",'\\'=>'\\',);my%QUOTE=map {$_=>1}qw{null true false};my$re_capture_double_quoted=qr/\"([^\\"]*(?:\\.[^\\"]*)*)\"/;my$re_capture_single_quoted=qr/\'([^\']*(?:\'\'[^\']*)*)\'/;my$re_capture_unquoted_key=qr/([^:]+(?::+\S(?:[^:]*|.*?(?=:)))*)(?=\s*\:(?:\s+|$))/;my$re_trailing_comment=qr/(?:\s+\#.*)?/;my$re_key_value_separator=qr/\s*:(?:\s+(?:\#.*)?|$)/;sub _load_file {my$class=ref $_[0]? ref shift : shift;my$file=shift or $class->_error('You did not specify a file name');$class->_error("File '$file' does not exist")unless -e $file;$class->_error("'$file' is a directory, not a file")unless -f _;$class->_error("Insufficient permissions to read '$file'")unless -r _;open(my$fh,"<:unix:encoding(UTF-8)",$file);unless ($fh){$class->_error("Failed to open file '$file': $!")}if (_can_flock()){flock($fh,Fcntl::LOCK_SH())or warn "Couldn't lock '$file' for reading: $!"}my$contents=eval {use warnings FATAL=>'utf8';local $/;<$fh>};if (my$err=$@){$class->_error("Error reading from file '$file': $err")}unless (close$fh){$class->_error("Failed to close file '$file': $!")}$class->_load_string($contents)}sub _load_string {my$class=ref $_[0]? ref shift : shift;my$self=bless [],$class;my$string=$_[0];eval {unless (defined$string){die \"Did not provide a string to load"}if (utf8::is_utf8($string)&&!utf8::valid($string)){die \<<'...'}utf8::upgrade($string);$string =~ s/^\x{FEFF}//;return$self unless length$string;my@lines=grep {!/^\s*(?:\#.*)?\z/}split /(?:\015{1,2}\012|\015|\012)/,$string;@lines and $lines[0]=~ /^\%YAML[: ][\d\.]+.*\z/ and shift@lines;my$in_document=0;while (@lines){if ($lines[0]=~ /^---\s*(?:(.+)\s*)?\z/){shift@lines;if (defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/){push @$self,$self->_load_scalar("$1",[undef ],\@lines);next}$in_document=1}if (!@lines or $lines[0]=~ /^(?:---|\.\.\.)/){push @$self,undef;while (@lines and $lines[0]!~ /^---/){shift@lines}$in_document=0}elsif (!$in_document && @$self){die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'"}elsif ($lines[0]=~ /^\s*\-(?:\s|$|-+$)/){my$document=[];push @$self,$document;$self->_load_array($document,[0 ],\@lines)}elsif ($lines[0]=~ /^(\s*)\S/){my$document={};push @$self,$document;$self->_load_hash($document,[length($1)],\@lines)}else {die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'"}}};my$err=$@;if (ref$err eq 'SCALAR'){$self->_error(${$err})}elsif ($err){$self->_error($err)}return$self}sub _unquote_single {my ($self,$string)=@_;return '' unless length$string;$string =~ s/\'\'/\'/g;return$string}sub _unquote_double {my ($self,$string)=@_;return '' unless length$string;$string =~ s/\\"/"/g;$string =~ s{\\([Nnever\\fartz0b]|x([0-9a-fA-F]{2}))}
|
|
191
|
+ Read an invalid UTF-8 string (maybe mixed UTF-8 and 8-bit character set).
|
|
192
|
+ Did you decode with lax ":utf8" instead of strict ":encoding(UTF-8)"?
|
|
193
|
+ ...
|
|
194
|
+ {(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}}gex;return$string}sub _load_scalar {my ($self,$string,$indent,$lines)=@_;$string =~ s/\s*\z//;return undef if$string eq '~';if ($string =~ /^$re_capture_single_quoted$re_trailing_comment\z/){return$self->_unquote_single($1)}if ($string =~ /^$re_capture_double_quoted$re_trailing_comment\z/){return$self->_unquote_double($1)}if ($string =~ /^[\'\"!&]/){die \"CPAN::Meta::YAML does not support a feature in line '$string'"}return {}if$string =~ /^{}(?:\s+\#.*)?\z/;return []if$string =~ /^\[\](?:\s+\#.*)?\z/;if ($string !~ /^[>|]/){die \"CPAN::Meta::YAML found illegal characters in plain scalar: '$string'" if$string =~ /^(?:-(?:\s|$)|[\@\%\`])/ or $string =~ /:(?:\s|$)/;$string =~ s/\s+#.*\z//;return$string}die \"CPAN::Meta::YAML failed to find multi-line scalar content" unless @$lines;$lines->[0]=~ /^(\s*)/;$indent->[-1]=length("$1");if (defined$indent->[-2]and $indent->[-1]<= $indent->[-2]){die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'"}my@multiline=();while (@$lines){$lines->[0]=~ /^(\s*)/;last unless length($1)>= $indent->[-1];push@multiline,substr(shift(@$lines),length($1))}my$j=(substr($string,0,1)eq '>')? ' ' : "\n";my$t=(substr($string,1,1)eq '-')? '' : "\n";return join($j,@multiline).$t}sub _load_array {my ($self,$array,$indent,$lines)=@_;while (@$lines){if ($lines->[0]=~ /^(?:---|\.\.\.)/){while (@$lines and $lines->[0]!~ /^---/){shift @$lines}return 1}$lines->[0]=~ /^(\s*)/;if (length($1)< $indent->[-1]){return 1}elsif (length($1)> $indent->[-1]){die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'"}if ($lines->[0]=~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/){my$indent2=length("$1");$lines->[0]=~ s/-/ /;push @$array,{};$self->_load_hash($array->[-1],[@$indent,$indent2 ],$lines)}elsif ($lines->[0]=~ /^\s*\-\s*\z/){shift @$lines;unless (@$lines){push @$array,undef;return 1}if ($lines->[0]=~ /^(\s*)\-/){my$indent2=length("$1");if ($indent->[-1]==$indent2){push @$array,undef}else {push @$array,[];$self->_load_array($array->[-1],[@$indent,$indent2 ],$lines)}}elsif ($lines->[0]=~ /^(\s*)\S/){push @$array,{};$self->_load_hash($array->[-1],[@$indent,length("$1")],$lines)}else {die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'"}}elsif ($lines->[0]=~ /^\s*\-(\s*)(.+?)\s*\z/){shift @$lines;push @$array,$self->_load_scalar("$2",[@$indent,undef ],$lines)}elsif (defined$indent->[-2]and $indent->[-1]==$indent->[-2]){return 1}else {die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'"}}return 1}sub _load_hash {my ($self,$hash,$indent,$lines)=@_;while (@$lines){if ($lines->[0]=~ /^(?:---|\.\.\.)/){while (@$lines and $lines->[0]!~ /^---/){shift @$lines}return 1}$lines->[0]=~ /^(\s*)/;if (length($1)< $indent->[-1]){return 1}elsif (length($1)> $indent->[-1]){die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'"}my$key;if ($lines->[0]=~ s/^\s*$re_capture_single_quoted$re_key_value_separator//){$key=$self->_unquote_single($1)}elsif ($lines->[0]=~ s/^\s*$re_capture_double_quoted$re_key_value_separator//){$key=$self->_unquote_double($1)}elsif ($lines->[0]=~ s/^\s*$re_capture_unquoted_key$re_key_value_separator//){$key=$1;$key =~ s/\s+$//}elsif ($lines->[0]=~ /^\s*\?/){die \"CPAN::Meta::YAML does not support a feature in line '$lines->[0]'"}else {die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'"}if (exists$hash->{$key}){warn "CPAN::Meta::YAML found a duplicate key '$key' in line '$lines->[0]'"}if (length$lines->[0]){$hash->{$key}=$self->_load_scalar(shift(@$lines),[@$indent,undef ],$lines)}else {shift @$lines;unless (@$lines){$hash->{$key}=undef;return 1}if ($lines->[0]=~ /^(\s*)-/){$hash->{$key}=[];$self->_load_array($hash->{$key},[@$indent,length($1)],$lines)}elsif ($lines->[0]=~ /^(\s*)./){my$indent2=length("$1");if ($indent->[-1]>= $indent2){$hash->{$key}=undef}else {$hash->{$key}={};$self->_load_hash($hash->{$key},[@$indent,length($1)],$lines)}}}}return 1}sub _dump_file {my$self=shift;require Fcntl;my$file=shift or $self->_error('You did not specify a file name');my$fh;if (_can_flock()){my$flags=Fcntl::O_WRONLY()|Fcntl::O_CREAT();sysopen($fh,$file,$flags);unless ($fh){$self->_error("Failed to open file '$file' for writing: $!")}binmode($fh,":raw:encoding(UTF-8)");flock($fh,Fcntl::LOCK_EX())or warn "Couldn't lock '$file' for reading: $!";truncate$fh,0;seek$fh,0,0}else {open$fh,">:unix:encoding(UTF-8)",$file}print {$fh}$self->_dump_string;unless (close$fh){$self->_error("Failed to close file '$file': $!")}return 1}sub _dump_string {my$self=shift;return '' unless ref$self && @$self;my$indent=0;my@lines=();eval {for my$cursor (@$self){push@lines,'---';if (!defined$cursor){}elsif (!ref$cursor){$lines[-1].= ' ' .$self->_dump_scalar($cursor)}elsif (ref$cursor eq 'ARRAY'){unless (@$cursor){$lines[-1].= ' []';next}push@lines,$self->_dump_array($cursor,$indent,{})}elsif (ref$cursor eq 'HASH'){unless (%$cursor){$lines[-1].= ' {}';next}push@lines,$self->_dump_hash($cursor,$indent,{})}else {die \("Cannot serialize " .ref($cursor))}}};if (ref $@ eq 'SCALAR'){$self->_error(${$@})}elsif ($@){$self->_error($@)}join '',map {"$_\n"}@lines}sub _has_internal_string_value {my$value=shift;my$b_obj=B::svref_2object(\$value);return$b_obj->FLAGS & B::SVf_POK()}sub _dump_scalar {my$string=$_[1];my$is_key=$_[2];my$has_string_flag=_has_internal_string_value($string);return '~' unless defined$string;return "''" unless length$string;if (Scalar::Util::looks_like_number($string)){if ($is_key || $has_string_flag){return qq['$string']}else {return$string}}if ($string =~ /[\x00-\x09\x0b-\x0d\x0e-\x1f\x7f-\x9f\'\n]/){$string =~ s/\\/\\\\/g;$string =~ s/"/\\"/g;$string =~ s/\n/\\n/g;$string =~ s/[\x85]/\\N/g;$string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g;$string =~ s/([\x7f-\x9f])/'\x' . sprintf("%X",ord($1))/ge;return qq|"$string"|}if ($string =~ /(?:^[~!@#%&*|>?:,'"`{}\[\]]|^-+$|\s|:\z)/ or $QUOTE{$string}){return "'$string'"}return$string}sub _dump_array {my ($self,$array,$indent,$seen)=@_;if ($seen->{refaddr($array)}++){die \"CPAN::Meta::YAML does not support circular references"}my@lines=();for my$el (@$array){my$line=(' ' x $indent).'-';my$type=ref$el;if (!$type){$line .= ' ' .$self->_dump_scalar($el);push@lines,$line}elsif ($type eq 'ARRAY'){if (@$el){push@lines,$line;push@lines,$self->_dump_array($el,$indent + 1,$seen)}else {$line .= ' []';push@lines,$line}}elsif ($type eq 'HASH'){if (keys %$el){push@lines,$line;push@lines,$self->_dump_hash($el,$indent + 1,$seen)}else {$line .= ' {}';push@lines,$line}}else {die \"CPAN::Meta::YAML does not support $type references"}}@lines}sub _dump_hash {my ($self,$hash,$indent,$seen)=@_;if ($seen->{refaddr($hash)}++){die \"CPAN::Meta::YAML does not support circular references"}my@lines=();for my$name (sort keys %$hash){my$el=$hash->{$name};my$line=(' ' x $indent).$self->_dump_scalar($name,1).":";my$type=ref$el;if (!$type){$line .= ' ' .$self->_dump_scalar($el);push@lines,$line}elsif ($type eq 'ARRAY'){if (@$el){push@lines,$line;push@lines,$self->_dump_array($el,$indent + 1,$seen)}else {$line .= ' []';push@lines,$line}}elsif ($type eq 'HASH'){if (keys %$el){push@lines,$line;push@lines,$self->_dump_hash($el,$indent + 1,$seen)}else {$line .= ' {}';push@lines,$line}}else {die \"CPAN::Meta::YAML does not support $type references"}}@lines}our$errstr='';sub _error {require Carp;$errstr=$_[1];$errstr =~ s/ at \S+ line \d+.*//;Carp::croak($errstr)}my$errstr_warned;sub errstr {require Carp;Carp::carp("CPAN::Meta::YAML->errstr and \$CPAN::Meta::YAML::errstr is deprecated")unless$errstr_warned++;$errstr}use B;my$HAS_FLOCK;sub _can_flock {if (defined$HAS_FLOCK){return$HAS_FLOCK}else {require Config;my$c=\%Config::Config;$HAS_FLOCK=grep {$c->{$_}}qw/d_flock d_fcntl_can_lock d_lockf/;require Fcntl if$HAS_FLOCK;return$HAS_FLOCK}}use Scalar::Util ();BEGIN {local $@;if (eval {Scalar::Util->VERSION(1.18)}){*refaddr=*Scalar::Util::refaddr}else {eval <<'END_PERL'}}delete$CPAN::Meta::YAML::{refaddr};1;
|
|
195
|
+ # Scalar::Util failed to load or too old
|
|
196
|
+ sub refaddr {
|
|
197
|
+ my $pkg = ref($_[0]) or return undef;
|
|
198
|
+ if ( !! UNIVERSAL::can($_[0], 'can') ) {
|
|
199
|
+ bless $_[0], 'Scalar::Util::Fake';
|
|
200
|
+ } else {
|
|
201
|
+ $pkg = undef;
|
12096
|
202
|
}
|
12097
|
|
- return $tvalue;
|
|
203
|
+ "$_[0]" =~ /0x(\w+)/;
|
|
204
|
+ my $i = do { no warnings 'portable'; hex $1 };
|
|
205
|
+ bless $_[0], $pkg if defined $pkg;
|
|
206
|
+ $i;
|
12098
|
207
|
}
|
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);
|
|
208
|
+ END_PERL
|
|
209
|
+CPAN_META_YAML
|
|
210
|
+
|
|
211
|
+$fatpacked{"Exporter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXPORTER';
|
|
212
|
+ package Exporter;require 5.006;our$Debug=0;our$ExportLevel=0;our$Verbose ||= 0;our$VERSION='5.70';our (%Cache);sub as_heavy {require Exporter::Heavy;my$c=(caller(1))[3];$c =~ s/.*:://;\&{"Exporter::Heavy::heavy_$c"}}sub export {goto &{as_heavy()}}sub import {my$pkg=shift;my$callpkg=caller($ExportLevel);if ($pkg eq "Exporter" and @_ and $_[0]eq "import"){*{$callpkg."::import"}=\&import;return}my$exports=\@{"$pkg\::EXPORT"};my$fail=${$pkg .'::'}{EXPORT_FAIL}&& \@{"$pkg\::EXPORT_FAIL"};return export$pkg,$callpkg,@_ if$Verbose or $Debug or $fail && @$fail > 1;my$export_cache=($Cache{$pkg}||= {});my$args=@_ or @_=@$exports;if ($args and not %$export_cache){s/^&//,$export_cache->{$_}=1 foreach (@$exports,@{"$pkg\::EXPORT_OK"})}my$heavy;if ($args or $fail){($heavy=(/\W/ or $args and not exists$export_cache->{$_}or $fail and @$fail and $_ eq $fail->[0]))and last foreach (@_)}else {($heavy=/\W/)and last foreach (@_)}return export$pkg,$callpkg,($args ? @_ : ())if$heavy;local$SIG{__WARN__}=sub {require Carp;&Carp::carp}if not $SIG{__WARN__};*{"$callpkg\::$_"}=\&{"$pkg\::$_"}foreach @_}sub export_fail {my$self=shift;@_}sub export_to_level {goto &{as_heavy()}}sub export_tags {goto &{as_heavy()}}sub export_ok_tags {goto &{as_heavy()}}sub require_version {goto &{as_heavy()}}1;
|
|
213
|
+EXPORTER
|
|
214
|
+
|
|
215
|
+$fatpacked{"Exporter/Heavy.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXPORTER_HEAVY';
|
|
216
|
+ package Exporter::Heavy;use strict;no strict 'refs';require Exporter;our$VERSION=$Exporter::VERSION;sub _rebuild_cache {my ($pkg,$exports,$cache)=@_;s/^&// foreach @$exports;@{$cache}{@$exports}=(1)x @$exports;my$ok=\@{"${pkg}::EXPORT_OK"};if (@$ok){s/^&// foreach @$ok;@{$cache}{@$ok}=(1)x @$ok}}sub heavy_export {my$oldwarn=$SIG{__WARN__};local$SIG{__WARN__}=sub {local$SIG{__WARN__}=$oldwarn;my$text=shift;if ($text =~ s/ at \S*Exporter\S*.pm line \d+.*\n//){require Carp;local$Carp::CarpLevel=1;Carp::carp($text)}else {warn$text}};local$SIG{__DIE__}=sub {require Carp;local$Carp::CarpLevel=1;Carp::croak("$_[0]Illegal null symbol in \@${1}::EXPORT")if $_[0]=~ /^Unable to create sub named "(.*?)::"/};my($pkg,$callpkg,@imports)=@_;my($type,$sym,$cache_is_current,$oops);my($exports,$export_cache)=(\@{"${pkg}::EXPORT"},$Exporter::Cache{$pkg}||= {});if (@imports){if (!%$export_cache){_rebuild_cache ($pkg,$exports,$export_cache);$cache_is_current=1}if (grep m{^[/!:]},@imports){my$tagsref=\%{"${pkg}::EXPORT_TAGS"};my$tagdata;my%imports;my($remove,$spec,@names,@allexports);unshift@imports,':DEFAULT' if$imports[0]=~ m/^!/;for$spec (@imports){$remove=$spec =~ s/^!//;if ($spec =~ s/^://){if ($spec eq 'DEFAULT'){@names=@$exports}elsif ($tagdata=$tagsref->{$spec}){@names=@$tagdata}else {warn qq["$spec" is not defined in %${pkg}::EXPORT_TAGS];++$oops;next}}elsif ($spec =~ m:^/(.*)/$:){my$patn=$1;@allexports=keys %$export_cache unless@allexports;@names=grep(/$patn/,@allexports)}else {@names=($spec)}warn "Import ".($remove ? "del":"add").": @names " if$Exporter::Verbose;if ($remove){for$sym (@names){delete$imports{$sym}}}else {@imports{@names}=(1)x @names}}@imports=keys%imports}my@carp;for$sym (@imports){if (!$export_cache->{$sym}){if ($sym =~ m/^\d/){$pkg->VERSION($sym);if (@imports==1){@imports=@$exports;last}if (@imports==2 and!$imports[1]){@imports=();last}}elsif ($sym !~ s/^&// ||!$export_cache->{$sym}){unless ($cache_is_current){%$export_cache=();_rebuild_cache ($pkg,$exports,$export_cache);$cache_is_current=1}if (!$export_cache->{$sym}){push@carp,qq["$sym" is not exported by the $pkg module\n];$oops++}}}}if ($oops){require Carp;Carp::croak("@{carp}Can't continue after import errors")}}else {@imports=@$exports}my($fail,$fail_cache)=(\@{"${pkg}::EXPORT_FAIL"},$Exporter::FailCache{$pkg}||= {});if (@$fail){if (!%$fail_cache){my@expanded=map {/^\w/ ? ($_,'&'.$_): $_}@$fail;warn "${pkg}::EXPORT_FAIL cached: @expanded" if$Exporter::Verbose;@{$fail_cache}{@expanded}=(1)x @expanded}my@failed;for$sym (@imports){push(@failed,$sym)if$fail_cache->{$sym}}if (@failed){@failed=$pkg->export_fail(@failed);for$sym (@failed){require Carp;Carp::carp(qq["$sym" is not implemented by the $pkg module ],"on this architecture")}if (@failed){require Carp;Carp::croak("Can't continue after import errors")}}}warn "Importing into $callpkg from $pkg: ",join(", ",sort@imports)if$Exporter::Verbose;for$sym (@imports){(*{"${callpkg}::$sym"}=\&{"${pkg}::$sym"},next)unless$sym =~ s/^(\W)//;$type=$1;no warnings 'once';*{"${callpkg}::$sym"}=$type eq '&' ? \&{"${pkg}::$sym"}: $type eq '$' ? \${"${pkg}::$sym"}: $type eq '@' ? \@{"${pkg}::$sym"}: $type eq '%' ? \%{"${pkg}::$sym"}: $type eq '*' ? *{"${pkg}::$sym"}: do {require Carp;Carp::croak("Can't export symbol: $type$sym")}}}sub heavy_export_to_level {my$pkg=shift;my$level=shift;(undef)=shift;my$callpkg=caller($level);$pkg->export($callpkg,@_)}sub _push_tags {my($pkg,$var,$syms)=@_;my@nontag=();my$export_tags=\%{"${pkg}::EXPORT_TAGS"};push(@{"${pkg}::$var"},map {$export_tags->{$_}? @{$export_tags->{$_}}: scalar(push(@nontag,$_),$_)}(@$syms)? @$syms : keys %$export_tags);if (@nontag and $^W){require Carp;Carp::carp(join(", ",@nontag)." are not tags of $pkg")}}sub heavy_require_version {my($self,$wanted)=@_;my$pkg=ref$self || $self;return ${pkg}->VERSION($wanted)}sub heavy_export_tags {_push_tags((caller)[0],"EXPORT",\@_)}sub heavy_export_ok_tags {_push_tags((caller)[0],"EXPORT_OK",\@_)}1;
|
|
217
|
+EXPORTER_HEAVY
|
|
218
|
+
|
|
219
|
+$fatpacked{"File/pushd.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'FILE_PUSHD';
|
|
220
|
+ use strict;use warnings;package File::pushd;our$VERSION='1.009';our@EXPORT=qw(pushd tempd);our@ISA=qw(Exporter);use Exporter;use Carp;use Cwd qw(getcwd abs_path);use File::Path qw(rmtree);use File::Temp qw();use File::Spec;use overload q{""}=>sub {File::Spec->canonpath($_[0]->{_pushd})},fallback=>1;sub pushd {my ($target_dir,$options)=@_;$options->{untaint_pattern}||= qr{^([-+@\w./]+)$};$target_dir="." unless defined$target_dir;croak "Can't locate directory $target_dir" unless -d $target_dir;my$tainted_orig=getcwd;my$orig;if ($tainted_orig =~ $options->{untaint_pattern}){$orig=$1}else {$orig=$tainted_orig}my$tainted_dest;eval {$tainted_dest=$target_dir ? abs_path($target_dir): $orig};croak "Can't locate absolute path for $target_dir: $@" if $@;my$dest;if ($tainted_dest =~ $options->{untaint_pattern}){$dest=$1}else {$dest=$tainted_dest}if ($dest ne $orig){chdir$dest or croak "Can't chdir to $dest\: $!"}my$self=bless {_pushd=>$dest,_original=>$orig },__PACKAGE__;return$self}sub tempd {my ($options)=@_;my$dir;eval {$dir=pushd(File::Temp::tempdir(CLEANUP=>0),$options)};croak $@ if $@;$dir->{_tempd}=1;return$dir}sub preserve {my$self=shift;return 1 if!$self->{"_tempd"};if (@_==0){return$self->{_preserve}=1}else {return$self->{_preserve}=$_[0]? 1 : 0}}sub DESTROY {my ($self)=@_;my$orig=$self->{_original};chdir$orig if$orig;if ($self->{_tempd}&&!$self->{_preserve}){my$err=do {local $@;eval {rmtree($self->{_pushd})};$@};carp$err if$err}}1;
|
|
221
|
+FILE_PUSHD
|
|
222
|
+
|
|
223
|
+$fatpacked{"HTTP/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_TINY';
|
|
224
|
+ package HTTP::Tiny;use strict;use warnings;our$VERSION='0.056';use Carp ();my@attributes;BEGIN {@attributes=qw(cookie_jar default_headers http_proxy https_proxy keep_alive local_address max_redirect max_size proxy no_proxy timeout SSL_options verify_SSL);my%persist_ok=map {;$_=>1}qw(cookie_jar default_headers max_redirect max_size);no strict 'refs';no warnings 'uninitialized';for my$accessor (@attributes){*{$accessor}=sub {@_ > 1 ? do {delete $_[0]->{handle}if!$persist_ok{$accessor}&& $_[1]ne $_[0]->{$accessor};$_[0]->{$accessor}=$_[1]}: $_[0]->{$accessor}}}}sub agent {my($self,$agent)=@_;if(@_ > 1){$self->{agent}=(defined$agent && $agent =~ / $/)? $agent .$self->_agent : $agent}return$self->{agent}}sub new {my($class,%args)=@_;my$self={max_redirect=>5,timeout=>60,keep_alive=>1,verify_SSL=>$args{verify_SSL}|| $args{verify_ssl}|| 0,no_proxy=>$ENV{no_proxy},};bless$self,$class;$class->_validate_cookie_jar($args{cookie_jar})if$args{cookie_jar};for my$key (@attributes){$self->{$key}=$args{$key}if exists$args{$key}}$self->agent(exists$args{agent}? $args{agent}: $class->_agent);$self->_set_proxies;return$self}sub _set_proxies {my ($self)=@_;if (!exists$self->{proxy}){$self->{proxy}=$ENV{all_proxy}|| $ENV{ALL_PROXY}}if (defined$self->{proxy}){$self->_split_proxy('generic proxy'=>$self->{proxy})}else {delete$self->{proxy}}if (!exists$self->{http_proxy}){local$ENV{HTTP_PROXY}if$ENV{REQUEST_METHOD};$self->{http_proxy}=$ENV{http_proxy}|| $ENV{HTTP_PROXY}|| $self->{proxy}}if (defined$self->{http_proxy}){$self->_split_proxy(http_proxy=>$self->{http_proxy});$self->{_has_proxy}{http}=1}else {delete$self->{http_proxy}}if (!exists$self->{https_proxy}){$self->{https_proxy}=$ENV{https_proxy}|| $ENV{HTTPS_PROXY}|| $self->{proxy}}if ($self->{https_proxy}){$self->_split_proxy(https_proxy=>$self->{https_proxy});$self->{_has_proxy}{https}=1}else {delete$self->{https_proxy}}unless (ref$self->{no_proxy}eq 'ARRAY'){$self->{no_proxy}=(defined$self->{no_proxy})? [split /\s*,\s*/,$self->{no_proxy}]: []}return}for my$sub_name (qw/get head put post delete/){my$req_method=uc$sub_name;no strict 'refs';eval <<"HERE"}sub post_form {my ($self,$url,$data,$args)=@_;(@_==3 || @_==4 && ref$args eq 'HASH')or Carp::croak(q/Usage: $http->post_form(URL, DATAREF, [HASHREF])/ ."\n");my$headers={};while (my ($key,$value)=each %{$args->{headers}|| {}}){$headers->{lc$key}=$value}delete$args->{headers};return$self->request('POST',$url,{%$args,content=>$self->www_form_urlencode($data),headers=>{%$headers,'content-type'=>'application/x-www-form-urlencoded' },})}sub mirror {my ($self,$url,$file,$args)=@_;@_==3 || (@_==4 && ref$args eq 'HASH')or Carp::croak(q/Usage: $http->mirror(URL, FILE, [HASHREF])/ ."\n");if (-e $file and my$mtime=(stat($file))[9]){$args->{headers}{'if-modified-since'}||= $self->_http_date($mtime)}my$tempfile=$file .int(rand(2**31));require Fcntl;sysopen my$fh,$tempfile,Fcntl::O_CREAT()|Fcntl::O_EXCL()|Fcntl::O_WRONLY()or Carp::croak(qq/Error: Could not create temporary file $tempfile for downloading: $!\n/);binmode$fh;$args->{data_callback}=sub {print {$fh}$_[0]};my$response=$self->request('GET',$url,$args);close$fh or Carp::croak(qq/Error: Caught error closing temporary file $tempfile: $!\n/);if ($response->{success}){rename$tempfile,$file or Carp::croak(qq/Error replacing $file with $tempfile: $!\n/);my$lm=$response->{headers}{'last-modified'};if ($lm and my$mtime=$self->_parse_http_date($lm)){utime$mtime,$mtime,$file}}$response->{success}||= $response->{status}eq '304';unlink$tempfile;return$response}my%idempotent=map {$_=>1}qw/GET HEAD PUT DELETE OPTIONS TRACE/;sub request {my ($self,$method,$url,$args)=@_;@_==3 || (@_==4 && ref$args eq 'HASH')or Carp::croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/ ."\n");$args ||= {};my$response;for (0 .. 1){$response=eval {$self->_request($method,$url,$args)};last unless $@ && $idempotent{$method}&& $@ =~ m{^(?:Socket closed|Unexpected end)}}if (my$e=$@){if (ref$e eq 'HASH' && exists$e->{status}){return$e}$e="$e";$response={url=>$url,success=>q{},status=>599,reason=>'Internal Exception',content=>$e,headers=>{'content-type'=>'text/plain','content-length'=>length$e,}}}return$response}sub www_form_urlencode {my ($self,$data)=@_;(@_==2 && ref$data)or Carp::croak(q/Usage: $http->www_form_urlencode(DATAREF)/ ."\n");(ref$data eq 'HASH' || ref$data eq 'ARRAY')or Carp::croak("form data must be a hash or array reference\n");my@params=ref$data eq 'HASH' ? %$data : @$data;@params % 2==0 or Carp::croak("form data reference must have an even number of terms\n");my@terms;while(@params){my ($key,$value)=splice(@params,0,2);if (ref$value eq 'ARRAY'){unshift@params,map {$key=>$_}@$value}else {push@terms,join("=",map {$self->_uri_escape($_)}$key,$value)}}return join("&",(ref$data eq 'ARRAY')? (@terms): (sort@terms))}sub can_ssl {my ($self)=@_;my($ok,$reason)=(1,'');unless (eval {require IO::Socket::SSL;IO::Socket::SSL->VERSION(1.42)}){$ok=0;$reason .= qq/IO::Socket::SSL 1.42 must be installed for https support\n/}unless (eval {require Net::SSLeay;Net::SSLeay->VERSION(1.49)}){$ok=0;$reason .= qq/Net::SSLeay 1.49 must be installed for https support\n/}if (ref($self)&& ($self->{verify_SSL}|| $self->{SSL_options}{SSL_verify_mode})){my$handle=HTTP::Tiny::Handle->new(SSL_options=>$self->{SSL_options},verify_SSL=>$self->{verify_SSL},);unless (eval {$handle->_find_CA_file;1}){$ok=0;$reason .= "$@"}}wantarray ? ($ok,$reason): $ok}my%DefaultPort=(http=>80,https=>443,);sub _agent {my$class=ref($_[0])|| $_[0];(my$default_agent=$class)=~ s{::}{-}g;return$default_agent ."/" .$class->VERSION}sub _request {my ($self,$method,$url,$args)=@_;my ($scheme,$host,$port,$path_query,$auth)=$self->_split_url($url);my$request={method=>$method,scheme=>$scheme,host=>$host,port=>$port,host_port=>($port==$DefaultPort{$scheme}? $host : "$host:$port"),uri=>$path_query,headers=>{},};my$handle=delete$self->{handle};if ($handle){unless ($handle->can_reuse($scheme,$host,$port)){$handle->close;undef$handle}}$handle ||= $self->_open_handle($request,$scheme,$host,$port);$self->_prepare_headers_and_cb($request,$args,$url,$auth);$handle->write_request($request);my$response;do {$response=$handle->read_response_header}until (substr($response->{status},0,1)ne '1');$self->_update_cookie_jar($url,$response)if$self->{cookie_jar};if (my@redir_args=$self->_maybe_redirect($request,$response,$args)){$handle->close;return$self->_request(@redir_args,$args)}my$known_message_length;if ($method eq 'HEAD' || $response->{status}=~ /^[23]04/){$known_message_length=1}else {my$data_cb=$self->_prepare_data_cb($response,$args);$known_message_length=$handle->read_body($data_cb,$response)}if ($self->{keep_alive}&& $known_message_length && $response->{protocol}eq 'HTTP/1.1' && ($response->{headers}{connection}|| '')ne 'close'){$self->{handle}=$handle}else {$handle->close}$response->{success}=substr($response->{status},0,1)eq '2';$response->{url}=$url;return$response}sub _open_handle {my ($self,$request,$scheme,$host,$port)=@_;my$handle=HTTP::Tiny::Handle->new(timeout=>$self->{timeout},SSL_options=>$self->{SSL_options},verify_SSL=>$self->{verify_SSL},local_address=>$self->{local_address},keep_alive=>$self->{keep_alive});if ($self->{_has_proxy}{$scheme}&&!grep {$host =~ /\Q$_\E$/}@{$self->{no_proxy}}){return$self->_proxy_connect($request,$handle)}else {return$handle->connect($scheme,$host,$port)}}sub _proxy_connect {my ($self,$request,$handle)=@_;my@proxy_vars;if ($request->{scheme}eq 'https'){Carp::croak(qq{No https_proxy defined})unless$self->{https_proxy};@proxy_vars=$self->_split_proxy(https_proxy=>$self->{https_proxy});if ($proxy_vars[0]eq 'https'){Carp::croak(qq{Can't proxy https over https: $request->{uri} via $self->{https_proxy}})}}else {Carp::croak(qq{No http_proxy defined})unless$self->{http_proxy};@proxy_vars=$self->_split_proxy(http_proxy=>$self->{http_proxy})}my ($p_scheme,$p_host,$p_port,$p_auth)=@proxy_vars;if (length$p_auth &&!defined$request->{headers}{'proxy-authorization'}){$self->_add_basic_auth_header($request,'proxy-authorization'=>$p_auth)}$handle->connect($p_scheme,$p_host,$p_port);if ($request->{scheme}eq 'https'){$self->_create_proxy_tunnel($request,$handle)}else {$request->{uri}="$request->{scheme}://$request->{host_port}$request->{uri}"}return$handle}sub _split_proxy {my ($self,$type,$proxy)=@_;my ($scheme,$host,$port,$path_query,$auth)=eval {$self->_split_url($proxy)};unless(defined($scheme)&& length($scheme)&& length($host)&& length($port)&& $path_query eq '/'){Carp::croak(qq{$type URL must be in format http[s]://[auth@]<host>:<port>/\n})}return ($scheme,$host,$port,$auth)}sub _create_proxy_tunnel {my ($self,$request,$handle)=@_;$handle->_assert_ssl;my$agent=exists($request->{headers}{'user-agent'})? $request->{headers}{'user-agent'}: $self->{agent};my$connect_request={method=>'CONNECT',uri=>"$request->{host}:$request->{port}",headers=>{host=>"$request->{host}:$request->{port}",'user-agent'=>$agent,}};if ($request->{headers}{'proxy-authorization'}){$connect_request->{headers}{'proxy-authorization'}=delete$request->{headers}{'proxy-authorization'}}$handle->write_request($connect_request);my$response;do {$response=$handle->read_response_header}until (substr($response->{status},0,1)ne '1');unless (substr($response->{status},0,1)eq '2'){die$response}$handle->start_ssl($request->{host});return}sub _prepare_headers_and_cb {my ($self,$request,$args,$url,$auth)=@_;for ($self->{default_headers},$args->{headers}){next unless defined;while (my ($k,$v)=each %$_){$request->{headers}{lc$k}=$v}}if (exists$request->{headers}{'host'}){die(qq/The 'Host' header must not be provided as header option\n/)}$request->{headers}{'host'}=$request->{host_port};$request->{headers}{'user-agent'}||= $self->{agent};$request->{headers}{'connection'}="close" unless$self->{keep_alive};if (defined$args->{content}){if (ref$args->{content}eq 'CODE'){$request->{headers}{'content-type'}||= "application/octet-stream";$request->{headers}{'transfer-encoding'}='chunked' unless$request->{headers}{'content-length'}|| $request->{headers}{'transfer-encoding'};$request->{cb}=$args->{content}}elsif (length$args->{content}){my$content=$args->{content};if ($] ge '5.008'){utf8::downgrade($content,1)or die(qq/Wide character in request message body\n/)}$request->{headers}{'content-type'}||= "application/octet-stream";$request->{headers}{'content-length'}=length$content unless$request->{headers}{'content-length'}|| $request->{headers}{'transfer-encoding'};$request->{cb}=sub {substr$content,0,length$content,''}}$request->{trailer_cb}=$args->{trailer_callback}if ref$args->{trailer_callback}eq 'CODE'}if ($self->{cookie_jar}){my$cookies=$self->cookie_jar->cookie_header($url);$request->{headers}{cookie}=$cookies if length$cookies}if (length$auth &&!defined$request->{headers}{authorization}){$self->_add_basic_auth_header($request,'authorization'=>$auth)}return}sub _add_basic_auth_header {my ($self,$request,$header,$auth)=@_;require MIME::Base64;$request->{headers}{$header}="Basic " .MIME::Base64::encode_base64($auth,"");return}sub _prepare_data_cb {my ($self,$response,$args)=@_;my$data_cb=$args->{data_callback};$response->{content}='';if (!$data_cb || $response->{status}!~ /^2/){if (defined$self->{max_size}){$data_cb=sub {$_[1]->{content}.= $_[0];die(qq/Size of response body exceeds the maximum allowed of $self->{max_size}\n/)if length $_[1]->{content}> $self->{max_size}}}else {$data_cb=sub {$_[1]->{content}.= $_[0]}}}return$data_cb}sub _update_cookie_jar {my ($self,$url,$response)=@_;my$cookies=$response->{headers}->{'set-cookie'};return unless defined$cookies;my@cookies=ref$cookies ? @$cookies : $cookies;$self->cookie_jar->add($url,$_)for@cookies;return}sub _validate_cookie_jar {my ($class,$jar)=@_;for my$method (qw/add cookie_header/){Carp::croak(qq/Cookie jar must provide the '$method' method\n/)unless ref($jar)&& ref($jar)->can($method)}return}sub _maybe_redirect {my ($self,$request,$response,$args)=@_;my$headers=$response->{headers};my ($status,$method)=($response->{status},$request->{method});if (($status eq '303' or ($status =~ /^30[1278]/ && $method =~ /^GET|HEAD$/))and $headers->{location}and ++$args->{redirects}<= $self->{max_redirect}){my$location=($headers->{location}=~ /^\//)? "$request->{scheme}://$request->{host_port}$headers->{location}" : $headers->{location};return (($status eq '303' ? 'GET' : $method),$location)}return}sub _split_url {my$url=pop;my ($scheme,$host,$path_query)=$url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)> or die(qq/Cannot parse URL: '$url'\n/);$scheme=lc$scheme;$path_query="/$path_query" unless$path_query =~ m<\A/>;my$auth='';if ((my$i=index$host,'@')!=-1){$auth=substr$host,0,$i,'';substr$host,0,1,'';$auth =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg}my$port=$host =~ s/:(\d*)\z// && length $1 ? $1 : $scheme eq 'http' ? 80 : $scheme eq 'https' ? 443 : undef;return ($scheme,(length$host ? lc$host : "localhost"),$port,$path_query,$auth)}my$DoW="Sun|Mon|Tue|Wed|Thu|Fri|Sat";my$MoY="Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec";sub _http_date {my ($sec,$min,$hour,$mday,$mon,$year,$wday)=gmtime($_[1]);return sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT",substr($DoW,$wday*4,3),$mday,substr($MoY,$mon*4,3),$year+1900,$hour,$min,$sec)}sub _parse_http_date {my ($self,$str)=@_;require Time::Local;my@tl_parts;if ($str =~ /^[SMTWF][a-z]+, +(\d{1,2}) ($MoY) +(\d\d\d\d) +(\d\d):(\d\d):(\d\d) +GMT$/){@tl_parts=($6,$5,$4,$1,(index($MoY,$2)/4),$3)}elsif ($str =~ /^[SMTWF][a-z]+, +(\d\d)-($MoY)-(\d{2,4}) +(\d\d):(\d\d):(\d\d) +GMT$/){@tl_parts=($6,$5,$4,$1,(index($MoY,$2)/4),$3)}elsif ($str =~ /^[SMTWF][a-z]+ +($MoY) +(\d{1,2}) +(\d\d):(\d\d):(\d\d) +(?:[^0-9]+ +)?(\d\d\d\d)$/){@tl_parts=($5,$4,$3,$2,(index($MoY,$1)/4),$6)}return eval {my$t=@tl_parts ? Time::Local::timegm(@tl_parts): -1;$t < 0 ? undef : $t}}my%escapes=map {chr($_)=>sprintf("%%%02X",$_)}0..255;$escapes{' '}="+";my$unsafe_char=qr/[^A-Za-z0-9\-\._~]/;sub _uri_escape {my ($self,$str)=@_;if ($] ge '5.008'){utf8::encode($str)}else {$str=pack("U*",unpack("C*",$str))if (length$str==do {use bytes;length$str});$str=pack("C*",unpack("C*",$str))}$str =~ s/($unsafe_char)/$escapes{$1}/ge;return$str}package HTTP::Tiny::Handle;use strict;use warnings;use Errno qw[EINTR EPIPE];use IO::Socket qw[SOCK_STREAM];my$SOCKET_CLASS=$ENV{PERL_HTTP_TINY_IPV4_ONLY}? 'IO::Socket::INET' : eval {require IO::Socket::IP;IO::Socket::IP->VERSION(0.25)}? 'IO::Socket::IP' : 'IO::Socket::INET';sub BUFSIZE () {32768}my$Printable=sub {local $_=shift;s/\r/\\r/g;s/\n/\\n/g;s/\t/\\t/g;s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;$_};my$Token=qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;sub new {my ($class,%args)=@_;return bless {rbuf=>'',timeout=>60,max_line_size=>16384,max_header_lines=>64,verify_SSL=>0,SSL_options=>{},%args },$class}sub connect {@_==4 || die(q/Usage: $handle->connect(scheme, host, port)/ ."\n");my ($self,$scheme,$host,$port)=@_;if ($scheme eq 'https'){$self->_assert_ssl}elsif ($scheme ne 'http'){die(qq/Unsupported URL scheme '$scheme'\n/)}$self->{fh}=$SOCKET_CLASS->new(PeerHost=>$host,PeerPort=>$port,$self->{local_address}? (LocalAddr=>$self->{local_address}): (),Proto=>'tcp',Type=>SOCK_STREAM,Timeout=>$self->{timeout},KeepAlive=>!!$self->{keep_alive})or die(qq/Could not connect to '$host:$port': $@\n/);binmode($self->{fh})or die(qq/Could not binmode() socket: '$!'\n/);$self->start_ssl($host)if$scheme eq 'https';$self->{scheme}=$scheme;$self->{host}=$host;$self->{port}=$port;$self->{pid}=$$;$self->{tid}=_get_tid();return$self}sub start_ssl {my ($self,$host)=@_;if (ref($self->{fh})eq 'IO::Socket::SSL'){unless ($self->{fh}->stop_SSL){my$ssl_err=IO::Socket::SSL->errstr;die(qq/Error halting prior SSL connection: $ssl_err/)}}my$ssl_args=$self->_ssl_args($host);IO::Socket::SSL->start_SSL($self->{fh},%$ssl_args,SSL_create_ctx_callback=>sub {my$ctx=shift;Net::SSLeay::CTX_set_mode($ctx,Net::SSLeay::MODE_AUTO_RETRY())},);unless (ref($self->{fh})eq 'IO::Socket::SSL'){my$ssl_err=IO::Socket::SSL->errstr;die(qq/SSL connection failed for $host: $ssl_err\n/)}}sub close {@_==1 || die(q/Usage: $handle->close()/ ."\n");my ($self)=@_;CORE::close($self->{fh})or die(qq/Could not close socket: '$!'\n/)}sub write {@_==2 || die(q/Usage: $handle->write(buf)/ ."\n");my ($self,$buf)=@_;if ($] ge '5.008'){utf8::downgrade($buf,1)or die(qq/Wide character in write()\n/)}my$len=length$buf;my$off=0;local$SIG{PIPE}='IGNORE';while (){$self->can_write or die(qq/Timed out while waiting for socket to become ready for writing\n/);my$r=syswrite($self->{fh},$buf,$len,$off);if (defined$r){$len -= $r;$off += $r;last unless$len > 0}elsif ($!==EPIPE){die(qq/Socket closed by remote server: $!\n/)}elsif ($!!=EINTR){if ($self->{fh}->can('errstr')){my$err=$self->{fh}->errstr();die (qq/Could not write to SSL socket: '$err'\n /)}else {die(qq/Could not write to socket: '$!'\n/)}}}return$off}sub read {@_==2 || @_==3 || die(q/Usage: $handle->read(len [, allow_partial])/ ."\n");my ($self,$len,$allow_partial)=@_;my$buf='';my$got=length$self->{rbuf};if ($got){my$take=($got < $len)? $got : $len;$buf=substr($self->{rbuf},0,$take,'');$len -= $take}while ($len > 0){$self->can_read or die(q/Timed out while waiting for socket to become ready for reading/ ."\n");my$r=sysread($self->{fh},$buf,$len,length$buf);if (defined$r){last unless$r;$len -= $r}elsif ($!!=EINTR){if ($self->{fh}->can('errstr')){my$err=$self->{fh}->errstr();die (qq/Could not read from SSL socket: '$err'\n /)}else {die(qq/Could not read from socket: '$!'\n/)}}}if ($len &&!$allow_partial){die(qq/Unexpected end of stream\n/)}return$buf}sub readline {@_==1 || die(q/Usage: $handle->readline()/ ."\n");my ($self)=@_;while (){if ($self->{rbuf}=~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x){return $1}if (length$self->{rbuf}>= $self->{max_line_size}){die(qq/Line size exceeds the maximum allowed size of $self->{max_line_size}\n/)}$self->can_read or die(qq/Timed out while waiting for socket to become ready for reading\n/);my$r=sysread($self->{fh},$self->{rbuf},BUFSIZE,length$self->{rbuf});if (defined$r){last unless$r}elsif ($!!=EINTR){if ($self->{fh}->can('errstr')){my$err=$self->{fh}->errstr();die (qq/Could not read from SSL socket: '$err'\n /)}else {die(qq/Could not read from socket: '$!'\n/)}}}die(qq/Unexpected end of stream while looking for line\n/)}sub read_header_lines {@_==1 || @_==2 || die(q/Usage: $handle->read_header_lines([headers])/ ."\n");my ($self,$headers)=@_;$headers ||= {};my$lines=0;my$val;while (){my$line=$self->readline;if (++$lines >= $self->{max_header_lines}){die(qq/Header lines exceeds maximum number allowed of $self->{max_header_lines}\n/)}elsif ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x){my ($field_name)=lc $1;if (exists$headers->{$field_name}){for ($headers->{$field_name}){$_=[$_]unless ref $_ eq "ARRAY";push @$_,$2;$val=\$_->[-1]}}else {$val=\($headers->{$field_name}=$2)}}elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x){$val or die(qq/Unexpected header continuation line\n/);next unless length $1;$$val .= ' ' if length $$val;$$val .= $1}elsif ($line =~ /\A \x0D?\x0A \z/x){last}else {die(q/Malformed header line: / .$Printable->($line)."\n")}}return$headers}sub write_request {@_==2 || die(q/Usage: $handle->write_request(request)/ ."\n");my($self,$request)=@_;$self->write_request_header(@{$request}{qw/method uri headers/});$self->write_body($request)if$request->{cb};return}my%HeaderCase=('content-md5'=>'Content-MD5','etag'=>'ETag','te'=>'TE','www-authenticate'=>'WWW-Authenticate','x-xss-protection'=>'X-XSS-Protection',);sub write_header_lines {(@_==2 || @_==3 && ref $_[1]eq 'HASH')|| die(q/Usage: $handle->write_header_lines(headers[,prefix])/ ."\n");my($self,$headers,$prefix_data)=@_;my$buf=(defined$prefix_data ? $prefix_data : '');while (my ($k,$v)=each %$headers){my$field_name=lc$k;if (exists$HeaderCase{$field_name}){$field_name=$HeaderCase{$field_name}}else {$field_name =~ /\A $Token+ \z/xo or die(q/Invalid HTTP header field name: / .$Printable->($field_name)."\n");$field_name =~ s/\b(\w)/\u$1/g;$HeaderCase{lc$field_name}=$field_name}for (ref$v eq 'ARRAY' ? @$v : $v){$_='' unless defined $_;$buf .= "$field_name: $_\x0D\x0A"}}$buf .= "\x0D\x0A";return$self->write($buf)}sub read_body {@_==3 || die(q/Usage: $handle->read_body(callback, response)/ ."\n");my ($self,$cb,$response)=@_;my$te=$response->{headers}{'transfer-encoding'}|| '';my$chunked=grep {/chunked/i}(ref$te eq 'ARRAY' ? @$te : $te);return$chunked ? $self->read_chunked_body($cb,$response): $self->read_content_body($cb,$response)}sub write_body {@_==2 || die(q/Usage: $handle->write_body(request)/ ."\n");my ($self,$request)=@_;if ($request->{headers}{'content-length'}){return$self->write_content_body($request)}else {return$self->write_chunked_body($request)}}sub read_content_body {@_==3 || @_==4 || die(q/Usage: $handle->read_content_body(callback, response, [read_length])/ ."\n");my ($self,$cb,$response,$content_length)=@_;$content_length ||= $response->{headers}{'content-length'};if (defined$content_length){my$len=$content_length;while ($len > 0){my$read=($len > BUFSIZE)? BUFSIZE : $len;$cb->($self->read($read,0),$response);$len -= $read}return length($self->{rbuf})==0}my$chunk;$cb->($chunk,$response)while length($chunk=$self->read(BUFSIZE,1));return}sub write_content_body {@_==2 || die(q/Usage: $handle->write_content_body(request)/ ."\n");my ($self,$request)=@_;my ($len,$content_length)=(0,$request->{headers}{'content-length'});while (){my$data=$request->{cb}->();defined$data && length$data or last;if ($] ge '5.008'){utf8::downgrade($data,1)or die(qq/Wide character in write_content()\n/)}$len += $self->write($data)}$len==$content_length or die(qq/Content-Length mismatch (got: $len expected: $content_length)\n/);return$len}sub read_chunked_body {@_==3 || die(q/Usage: $handle->read_chunked_body(callback, $response)/ ."\n");my ($self,$cb,$response)=@_;while (){my$head=$self->readline;$head =~ /\A ([A-Fa-f0-9]+)/x or die(q/Malformed chunk head: / .$Printable->($head)."\n");my$len=hex($1)or last;$self->read_content_body($cb,$response,$len);$self->read(2)eq "\x0D\x0A" or die(qq/Malformed chunk: missing CRLF after chunk data\n/)}$self->read_header_lines($response->{headers});return 1}sub write_chunked_body {@_==2 || die(q/Usage: $handle->write_chunked_body(request)/ ."\n");my ($self,$request)=@_;my$len=0;while (){my$data=$request->{cb}->();defined$data && length$data or last;if ($] ge '5.008'){utf8::downgrade($data,1)or die(qq/Wide character in write_chunked_body()\n/)}$len += length$data;my$chunk=sprintf '%X',length$data;$chunk .= "\x0D\x0A";$chunk .= $data;$chunk .= "\x0D\x0A";$self->write($chunk)}$self->write("0\x0D\x0A");$self->write_header_lines($request->{trailer_cb}->())if ref$request->{trailer_cb}eq 'CODE';return$len}sub read_response_header {@_==1 || die(q/Usage: $handle->read_response_header()/ ."\n");my ($self)=@_;my$line=$self->readline;$line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x or die(q/Malformed Status-Line: / .$Printable->($line)."\n");my ($protocol,$version,$status,$reason)=($1,$2,$3,$4);die (qq/Unsupported HTTP protocol: $protocol\n/)unless$version =~ /0*1\.0*[01]/;return {status=>$status,reason=>$reason,headers=>$self->read_header_lines,protocol=>$protocol,}}sub write_request_header {@_==4 || die(q/Usage: $handle->write_request_header(method, request_uri, headers)/ ."\n");my ($self,$method,$request_uri,$headers)=@_;return$self->write_header_lines($headers,"$method $request_uri HTTP/1.1\x0D\x0A")}sub _do_timeout {my ($self,$type,$timeout)=@_;$timeout=$self->{timeout}unless defined$timeout && $timeout >= 0;my$fd=fileno$self->{fh};defined$fd && $fd >= 0 or die(qq/select(2): 'Bad file descriptor'\n/);my$initial=time;my$pending=$timeout;my$nfound;vec(my$fdset='',$fd,1)=1;while (){$nfound=($type eq 'read')? select($fdset,undef,undef,$pending): select(undef,$fdset,undef,$pending);if ($nfound==-1){$!==EINTR or die(qq/select(2): '$!'\n/);redo if!$timeout || ($pending=$timeout - (time - $initial))> 0;$nfound=0}last}$!=0;return$nfound}sub can_read {@_==1 || @_==2 || die(q/Usage: $handle->can_read([timeout])/ ."\n");my$self=shift;if (ref($self->{fh})eq 'IO::Socket::SSL'){return 1 if$self->{fh}->pending}return$self->_do_timeout('read',@_)}sub can_write {@_==1 || @_==2 || die(q/Usage: $handle->can_write([timeout])/ ."\n");my$self=shift;return$self->_do_timeout('write',@_)}sub _assert_ssl {my($ok,$reason)=HTTP::Tiny->can_ssl();die$reason unless$ok}sub can_reuse {my ($self,$scheme,$host,$port)=@_;return 0 if $self->{pid}!=$$ || $self->{tid}!=_get_tid()|| length($self->{rbuf})|| $scheme ne $self->{scheme}|| $host ne $self->{host}|| $port ne $self->{port}|| eval {$self->can_read(0)}|| $@ ;return 1}sub _find_CA_file {my$self=shift();if ($self->{SSL_options}->{SSL_ca_file}){unless (-r $self->{SSL_options}->{SSL_ca_file}){die qq/SSL_ca_file '$self->{SSL_options}->{SSL_ca_file}' not found or not readable\n/}return$self->{SSL_options}->{SSL_ca_file}}return Mozilla::CA::SSL_ca_file()if eval {require Mozilla::CA;1};for my$ca_bundle ("/etc/ssl/certs/ca-certificates.crt","/etc/pki/tls/certs/ca-bundle.crt","/etc/ssl/ca-bundle.pem","/etc/openssl/certs/ca-certificates.crt","/etc/ssl/cert.pem","/usr/local/share/certs/ca-root-nss.crt","/etc/pki/tls/cacert.pem","/etc/certs/ca-certificates.crt",){return$ca_bundle if -e $ca_bundle}die qq/Couldn't find a CA bundle with which to verify the SSL certificate.\n/ .qq/Try installing Mozilla::CA from CPAN\n/}sub _get_tid {no warnings 'reserved';return threads->can("tid")? threads->tid : 0}sub _ssl_args {my ($self,$host)=@_;my%ssl_args;if (Net::SSLeay::OPENSSL_VERSION_NUMBER()>= 0x01000000){$ssl_args{SSL_hostname}=$host,}if ($self->{verify_SSL}){$ssl_args{SSL_verifycn_scheme}='http';$ssl_args{SSL_verifycn_name}=$host;$ssl_args{SSL_verify_mode}=0x01;$ssl_args{SSL_ca_file}=$self->_find_CA_file}else {$ssl_args{SSL_verifycn_scheme}='none';$ssl_args{SSL_verify_mode}=0x00}for my$k (keys %{$self->{SSL_options}}){$ssl_args{$k}=$self->{SSL_options}{$k}if$k =~ m/^SSL_/}return \%ssl_args}1;
|
|
225
|
+ sub $sub_name {
|
|
226
|
+ my (\$self, \$url, \$args) = \@_;
|
|
227
|
+ \@_ == 2 || (\@_ == 3 && ref \$args eq 'HASH')
|
|
228
|
+ or Carp::croak(q/Usage: \$http->$sub_name(URL, [HASHREF])/ . "\n");
|
|
229
|
+ return \$self->request('$req_method', \$url, \$args || {});
|
12116
|
230
|
}
|
|
231
|
+ HERE
|
|
232
|
+HTTP_TINY
|
|
233
|
+
|
|
234
|
+$fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP';
|
|
235
|
+ package JSON::PP;use 5.005;use strict;use base qw(Exporter);use overload ();use Carp ();use B ();$JSON::PP::VERSION='2.27300';@JSON::PP::EXPORT=qw(encode_json decode_json from_json to_json);use constant P_ASCII=>0;use constant P_LATIN1=>1;use constant P_UTF8=>2;use constant P_INDENT=>3;use constant P_CANONICAL=>4;use constant P_SPACE_BEFORE=>5;use constant P_SPACE_AFTER=>6;use constant P_ALLOW_NONREF=>7;use constant P_SHRINK=>8;use constant P_ALLOW_BLESSED=>9;use constant P_CONVERT_BLESSED=>10;use constant P_RELAXED=>11;use constant P_LOOSE=>12;use constant P_ALLOW_BIGNUM=>13;use constant P_ALLOW_BAREKEY=>14;use constant P_ALLOW_SINGLEQUOTE=>15;use constant P_ESCAPE_SLASH=>16;use constant P_AS_NONBLESSED=>17;use constant P_ALLOW_UNKNOWN=>18;use constant OLD_PERL=>$] < 5.008 ? 1 : 0;BEGIN {my@xs_compati_bit_properties=qw(latin1 ascii utf8 indent canonical space_before space_after allow_nonref shrink allow_blessed convert_blessed relaxed allow_unknown);my@pp_bit_properties=qw(allow_singlequote allow_bignum loose allow_barekey escape_slash as_nonblessed);if ($] < 5.008){my$helper=$] >= 5.006 ? 'JSON::PP::Compat5006' : 'JSON::PP::Compat5005';eval qq| require $helper |;if ($@){Carp::croak $@}}for my$name (@xs_compati_bit_properties,@pp_bit_properties){my$flag_name='P_' .uc($name);eval qq/
|
|
236
|
+ sub $name {
|
|
237
|
+ my \$enable = defined \$_[1] ? \$_[1] : 1;
|
12117
|
238
|
|
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
|
|
- }
|
|
239
|
+ if (\$enable) {
|
|
240
|
+ \$_[0]->{PROPS}->[$flag_name] = 1;
|
|
241
|
+ }
|
|
242
|
+ else {
|
|
243
|
+ \$_[0]->{PROPS}->[$flag_name] = 0;
|
|
244
|
+ }
|
12133
|
245
|
|
12134
|
|
- $req = version::vpp->new($req);
|
|
246
|
+ \$_[0];
|
|
247
|
+ }
|
12135
|
248
|
|
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
|
|
- }
|
|
249
|
+ sub get_$name {
|
|
250
|
+ \$_[0]->{PROPS}->[$flag_name] ? 1 : '';
|
|
251
|
+ }
|
|
252
|
+ /}}my%encode_allow_method =map {($_=>1)}qw/utf8 pretty allow_nonref latin1 self_encode escape_slash allow_blessed convert_blessed indent indent_length allow_bignum as_nonblessed/;my%decode_allow_method =map {($_=>1)}qw/utf8 allow_nonref loose allow_singlequote allow_bignum allow_barekey max_size relaxed/;my$JSON;sub encode_json ($) {($JSON ||= __PACKAGE__->new->utf8)->encode(@_)}sub decode_json {($JSON ||= __PACKAGE__->new->utf8)->decode(@_)}sub to_json($) {Carp::croak ("JSON::PP::to_json has been renamed to encode_json.")}sub from_json($) {Carp::croak ("JSON::PP::from_json has been renamed to decode_json.")}sub new {my$class=shift;my$self={max_depth=>512,max_size=>0,indent=>0,FLAGS=>0,fallback=>sub {encode_error('Invalid value. JSON can only reference.')},indent_length=>3,};bless$self,$class}sub encode {return $_[0]->PP_encode_json($_[1])}sub decode {return $_[0]->PP_decode_json($_[1],0x00000000)}sub decode_prefix {return $_[0]->PP_decode_json($_[1],0x00000001)}sub pretty {my ($self,$v)=@_;my$enable=defined$v ? $v : 1;if ($enable){$self->indent(1)->indent_length(3)->space_before(1)->space_after(1)}else {$self->indent(0)->space_before(0)->space_after(0)}$self}sub max_depth {my$max=defined $_[1]? $_[1]: 0x80000000;$_[0]->{max_depth}=$max;$_[0]}sub get_max_depth {$_[0]->{max_depth}}sub max_size {my$max=defined $_[1]? $_[1]: 0;$_[0]->{max_size}=$max;$_[0]}sub get_max_size {$_[0]->{max_size}}sub filter_json_object {$_[0]->{cb_object}=defined $_[1]? $_[1]: 0;$_[0]->{F_HOOK}=($_[0]->{cb_object}or $_[0]->{cb_sk_object})? 1 : 0;$_[0]}sub filter_json_single_key_object {if (@_ > 1){$_[0]->{cb_sk_object}->{$_[1]}=$_[2]}$_[0]->{F_HOOK}=($_[0]->{cb_object}or $_[0]->{cb_sk_object})? 1 : 0;$_[0]}sub indent_length {if (!defined $_[1]or $_[1]> 15 or $_[1]< 0){Carp::carp "The acceptable range of indent_length() is 0 to 15."}else {$_[0]->{indent_length}=$_[1]}$_[0]}sub get_indent_length {$_[0]->{indent_length}}sub sort_by {$_[0]->{sort_by}=defined $_[1]? $_[1]: 1;$_[0]}sub allow_bigint {Carp::carp("allow_bigint() is obsoleted. use allow_bignum() insted.")}{my$max_depth;my$indent;my$ascii;my$latin1;my$utf8;my$space_before;my$space_after;my$canonical;my$allow_blessed;my$convert_blessed;my$indent_length;my$escape_slash;my$bignum;my$as_nonblessed;my$depth;my$indent_count;my$keysort;sub PP_encode_json {my$self=shift;my$obj=shift;$indent_count=0;$depth=0;my$idx=$self->{PROPS};($ascii,$latin1,$utf8,$indent,$canonical,$space_before,$space_after,$allow_blessed,$convert_blessed,$escape_slash,$bignum,$as_nonblessed)=@{$idx}[P_ASCII .. P_SPACE_AFTER,P_ALLOW_BLESSED,P_CONVERT_BLESSED,P_ESCAPE_SLASH,P_ALLOW_BIGNUM,P_AS_NONBLESSED];($max_depth,$indent_length)=@{$self}{qw/max_depth indent_length/};$keysort=$canonical ? sub {$a cmp $b}: undef;if ($self->{sort_by}){$keysort=ref($self->{sort_by})eq 'CODE' ? $self->{sort_by}: $self->{sort_by}=~ /\D+/ ? $self->{sort_by}: sub {$a cmp $b}}encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)")if(!ref$obj and!$idx->[P_ALLOW_NONREF ]);my$str=$self->object_to_json($obj);$str .= "\n" if ($indent);unless ($ascii or $latin1 or $utf8){utf8::upgrade($str)}if ($idx->[P_SHRINK ]){utf8::downgrade($str,1)}return$str}sub object_to_json {my ($self,$obj)=@_;my$type=ref($obj);if($type eq 'HASH'){return$self->hash_to_json($obj)}elsif($type eq 'ARRAY'){return$self->array_to_json($obj)}elsif ($type){if (blessed($obj)){return$self->value_to_json($obj)if ($obj->isa('JSON::PP::Boolean'));if ($convert_blessed and $obj->can('TO_JSON')){my$result=$obj->TO_JSON();if (defined$result and ref($result)){if (refaddr($obj)eq refaddr($result)){encode_error(sprintf("%s::TO_JSON method returned same object as was passed instead of a new one",ref$obj))}}return$self->object_to_json($result)}return "$obj" if ($bignum and _is_bignum($obj));return$self->blessed_to_json($obj)if ($allow_blessed and $as_nonblessed);encode_error(sprintf("encountered object '%s', but neither allow_blessed " ."nor convert_blessed settings are enabled",$obj))unless ($allow_blessed);return 'null'}else {return$self->value_to_json($obj)}}else{return$self->value_to_json($obj)}}sub hash_to_json {my ($self,$obj)=@_;my@res;encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")if (++$depth > $max_depth);my ($pre,$post)=$indent ? $self->_up_indent(): ('','');my$del=($space_before ? ' ' : '').':' .($space_after ? ' ' : '');for my$k (_sort($obj)){if (OLD_PERL){utf8::decode($k)}push@res,string_to_json($self,$k).$del .($self->object_to_json($obj->{$k})|| $self->value_to_json($obj->{$k}))}--$depth;$self->_down_indent()if ($indent);return '{' .(@res ? $pre : '').(@res ? join(",$pre",@res).$post : '').'}'}sub array_to_json {my ($self,$obj)=@_;my@res;encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")if (++$depth > $max_depth);my ($pre,$post)=$indent ? $self->_up_indent(): ('','');for my$v (@$obj){push@res,$self->object_to_json($v)|| $self->value_to_json($v)}--$depth;$self->_down_indent()if ($indent);return '[' .(@res ? $pre : '').(@res ? join(",$pre",@res).$post : '').']'}sub value_to_json {my ($self,$value)=@_;return 'null' if(!defined$value);my$b_obj=B::svref_2object(\$value);my$flags=$b_obj->FLAGS;return$value if$flags & (B::SVp_IOK | B::SVp_NOK)and!($flags & B::SVp_POK);my$type=ref($value);if(!$type){return string_to_json($self,$value)}elsif(blessed($value)and $value->isa('JSON::PP::Boolean')){return $$value==1 ? 'true' : 'false'}elsif ($type){if ((overload::StrVal($value)=~ /=(\w+)/)[0]){return$self->value_to_json("$value")}if ($type eq 'SCALAR' and defined $$value){return $$value eq '1' ? 'true' : $$value eq '0' ? 'false' : $self->{PROPS}->[P_ALLOW_UNKNOWN ]? 'null' : encode_error("cannot encode reference to scalar")}if ($self->{PROPS}->[P_ALLOW_UNKNOWN ]){return 'null'}else {if ($type eq 'SCALAR' or $type eq 'REF'){encode_error("cannot encode reference to scalar")}else {encode_error("encountered $value, but JSON can only represent references to arrays or hashes")}}}else {return$self->{fallback}->($value)if ($self->{fallback}and ref($self->{fallback})eq 'CODE');return 'null'}}my%esc=("\n"=>'\n',"\r"=>'\r',"\t"=>'\t',"\f"=>'\f',"\b"=>'\b',"\""=>'\"',"\\"=>'\\\\',"\'"=>'\\\'',);sub string_to_json {my ($self,$arg)=@_;$arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g;$arg =~ s/\//\\\//g if ($escape_slash);$arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg;if ($ascii){$arg=JSON_PP_encode_ascii($arg)}if ($latin1){$arg=JSON_PP_encode_latin1($arg)}if ($utf8){utf8::encode($arg)}return '"' .$arg .'"'}sub blessed_to_json {my$reftype=reftype($_[1])|| '';if ($reftype eq 'HASH'){return $_[0]->hash_to_json($_[1])}elsif ($reftype eq 'ARRAY'){return $_[0]->array_to_json($_[1])}else {return 'null'}}sub encode_error {my$error=shift;Carp::croak "$error"}sub _sort {defined$keysort ? (sort$keysort (keys %{$_[0]})): keys %{$_[0]}}sub _up_indent {my$self=shift;my$space=' ' x $indent_length;my ($pre,$post)=('','');$post="\n" .$space x $indent_count;$indent_count++;$pre="\n" .$space x $indent_count;return ($pre,$post)}sub _down_indent {$indent_count--}sub PP_encode_box {{depth=>$depth,indent_count=>$indent_count,}}}sub _encode_ascii {join('',map {$_ <= 127 ? chr($_): $_ <= 65535 ? sprintf('\u%04x',$_): sprintf('\u%x\u%x',_encode_surrogates($_))}unpack('U*',$_[0]))}sub _encode_latin1 {join('',map {$_ <= 255 ? chr($_): $_ <= 65535 ? sprintf('\u%04x',$_): sprintf('\u%x\u%x',_encode_surrogates($_))}unpack('U*',$_[0]))}sub _encode_surrogates {my$uni=$_[0]- 0x10000;return ($uni / 0x400 + 0xD800,$uni % 0x400 + 0xDC00)}sub _is_bignum {$_[0]->isa('Math::BigInt')or $_[0]->isa('Math::BigFloat')}my$max_intsize;BEGIN {my$checkint=1111;for my$d (5..64){$checkint .= 1;my$int=eval qq| $checkint |;if ($int =~ /[eE]/){$max_intsize=$d - 1;last}}}{my%escapes=(b=>"\x8",t=>"\x9",n=>"\xA",f=>"\xC",r=>"\xD",'\\'=>'\\','"'=>'"','/'=>'/',);my$text;my$at;my$ch;my$len;my$depth;my$encoding;my$is_valid_utf8;my$utf8_len;my$utf8;my$max_depth;my$max_size;my$relaxed;my$cb_object;my$cb_sk_object;my$F_HOOK;my$allow_bigint;my$singlequote;my$loose;my$allow_barekey;sub PP_decode_json {my ($self,$opt);($self,$text,$opt)=@_;($at,$ch,$depth)=(0,'',0);if (!defined$text or ref$text){decode_error("malformed JSON string, neither array, object, number, string or atom")}my$idx=$self->{PROPS};($utf8,$relaxed,$loose,$allow_bigint,$allow_barekey,$singlequote)=@{$idx}[P_UTF8,P_RELAXED,P_LOOSE .. P_ALLOW_SINGLEQUOTE];if ($utf8){utf8::downgrade($text,1)or Carp::croak("Wide character in subroutine entry")}else {utf8::upgrade($text);utf8::encode($text)}$len=length$text;($max_depth,$max_size,$cb_object,$cb_sk_object,$F_HOOK)=@{$self}{qw/max_depth max_size cb_object cb_sk_object F_HOOK/};if ($max_size > 1){use bytes;my$bytes=length$text;decode_error(sprintf("attempted decode of JSON text of %s bytes size, but max_size is set to %s" ,$bytes,$max_size),1)if ($bytes > $max_size)}my@octets=unpack('C4',$text);$encoding=($octets[0]and $octets[1])? 'UTF-8' : (!$octets[0]and $octets[1])? 'UTF-16BE' : (!$octets[0]and!$octets[1])? 'UTF-32BE' : ($octets[2])? 'UTF-16LE' : (!$octets[2])? 'UTF-32LE' : 'unknown';white();my$valid_start=defined$ch;my$result=value();return undef if (!$result && ($opt & 0x10000000));decode_error("malformed JSON string, neither array, object, number, string or atom")unless$valid_start;if (!$idx->[P_ALLOW_NONREF ]and!ref$result){decode_error('JSON text must be an object or array (but found number, string, true, false or null,' .' use allow_nonref to allow this)',1)}Carp::croak('something wrong.')if$len < $at;my$consumed=defined$ch ? $at - 1 : $at;white();if ($ch){return ($result,$consumed)if ($opt & 0x00000001);decode_error("garbage after JSON object")}($opt & 0x00000001)? ($result,$consumed): $result}sub next_chr {return$ch=undef if($at >= $len);$ch=substr($text,$at++,1)}sub value {white();return if(!defined$ch);return object()if($ch eq '{');return array()if($ch eq '[');return string()if($ch eq '"' or ($singlequote and $ch eq "'"));return number()if($ch =~ /[0-9]/ or $ch eq '-');return word()}sub string {my ($i,$s,$t,$u);my$utf16;my$is_utf8;($is_valid_utf8,$utf8_len)=('',0);$s='';if($ch eq '"' or ($singlequote and $ch eq "'")){my$boundChar=$ch;OUTER: while(defined(next_chr())){if($ch eq $boundChar){next_chr();if ($utf16){decode_error("missing low surrogate character in surrogate pair")}utf8::decode($s)if($is_utf8);return$s}elsif($ch eq '\\'){next_chr();if(exists$escapes{$ch}){$s .= $escapes{$ch}}elsif($ch eq 'u'){my$u='';for(1..4){$ch=next_chr();last OUTER if($ch !~ /[0-9a-fA-F]/);$u .= $ch}if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/){$utf16=$u}elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/){unless (defined$utf16){decode_error("missing high surrogate character in surrogate pair")}$is_utf8=1;$s .= JSON_PP_decode_surrogates($utf16,$u)|| next;$utf16=undef}else {if (defined$utf16){decode_error("surrogate pair expected")}if ((my$hex=hex($u))> 127){$is_utf8=1;$s .= JSON_PP_decode_unicode($u)|| next}else {$s .= chr$hex}}}else{unless ($loose){$at -= 2;decode_error('illegal backslash escape sequence in string')}$s .= $ch}}else{if (ord$ch > 127){unless($ch=is_valid_utf8($ch)){$at -= 1;decode_error("malformed UTF-8 character in JSON string")}else {$at += $utf8_len - 1}$is_utf8=1}if (!$loose){if ($ch =~ /[\x00-\x1f\x22\x5c]/){$at--;decode_error('invalid character encountered while parsing JSON string')}}$s .= $ch}}}decode_error("unexpected end of string while parsing JSON string")}sub white {while(defined$ch){if($ch le ' '){next_chr()}elsif($ch eq '/'){next_chr();if(defined$ch and $ch eq '/'){1 while(defined(next_chr())and $ch ne "\n" and $ch ne "\r")}elsif(defined$ch and $ch eq '*'){next_chr();while(1){if(defined$ch){if($ch eq '*'){if(defined(next_chr())and $ch eq '/'){next_chr();last}}else{next_chr()}}else{decode_error("Unterminated comment")}}next}else{$at--;decode_error("malformed JSON string, neither array, object, number, string or atom")}}else{if ($relaxed and $ch eq '#'){pos($text)=$at;$text =~ /\G([^\n]*(?:\r\n|\r|\n|$))/g;$at=pos($text);next_chr;next}last}}}sub array {my$a=$_[0]|| [];decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')if (++$depth > $max_depth);next_chr();white();if(defined$ch and $ch eq ']'){--$depth;next_chr();return$a}else {while(defined($ch)){push @$a,value();white();if (!defined$ch){last}if($ch eq ']'){--$depth;next_chr();return$a}if($ch ne ','){last}next_chr();white();if ($relaxed and $ch eq ']'){--$depth;next_chr();return$a}}}decode_error(", or ] expected while parsing array")}sub object {my$o=$_[0]|| {};my$k;decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')if (++$depth > $max_depth);next_chr();white();if(defined$ch and $ch eq '}'){--$depth;next_chr();if ($F_HOOK){return _json_object_hook($o)}return$o}else {while (defined$ch){$k=($allow_barekey and $ch ne '"' and $ch ne "'")? bareKey(): string();white();if(!defined$ch or $ch ne ':'){$at--;decode_error("':' expected")}next_chr();$o->{$k}=value();white();last if (!defined$ch);if($ch eq '}'){--$depth;next_chr();if ($F_HOOK){return _json_object_hook($o)}return$o}if($ch ne ','){last}next_chr();white();if ($relaxed and $ch eq '}'){--$depth;next_chr();if ($F_HOOK){return _json_object_hook($o)}return$o}}}$at--;decode_error(", or } expected while parsing object/hash")}sub bareKey {my$key;while($ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){$key .= $ch;next_chr()}return$key}sub word {my$word=substr($text,$at-1,4);if($word eq 'true'){$at += 3;next_chr;return$JSON::PP::true}elsif($word eq 'null'){$at += 3;next_chr;return undef}elsif($word eq 'fals'){$at += 3;if(substr($text,$at,1)eq 'e'){$at++;next_chr;return$JSON::PP::false}}$at--;decode_error("'null' expected")if ($word =~ /^n/);decode_error("'true' expected")if ($word =~ /^t/);decode_error("'false' expected")if ($word =~ /^f/);decode_error("malformed JSON string, neither array, object, number, string or atom")}sub number {my$n='';my$v;if($ch eq '0'){my$peek=substr($text,$at,1);my$hex=$peek =~ /[xX]/;if($hex){decode_error("malformed number (leading zero must not be followed by another digit)");($n)=(substr($text,$at+1)=~ /^([0-9a-fA-F]+)/)}else{($n)=(substr($text,$at)=~ /^([0-7]+)/);if (defined$n and length$n > 1){decode_error("malformed number (leading zero must not be followed by another digit)")}}if(defined$n and length($n)){if (!$hex and length($n)==1){decode_error("malformed number (leading zero must not be followed by another digit)")}$at += length($n)+ $hex;next_chr;return$hex ? hex($n): oct($n)}}if($ch eq '-'){$n='-';next_chr;if (!defined$ch or $ch !~ /\d/){decode_error("malformed number (no digits after initial minus)")}}while(defined$ch and $ch =~ /\d/){$n .= $ch;next_chr}if(defined$ch and $ch eq '.'){$n .= '.';next_chr;if (!defined$ch or $ch !~ /\d/){decode_error("malformed number (no digits after decimal point)")}else {$n .= $ch}while(defined(next_chr)and $ch =~ /\d/){$n .= $ch}}if(defined$ch and ($ch eq 'e' or $ch eq 'E')){$n .= $ch;next_chr;if(defined($ch)and ($ch eq '+' or $ch eq '-')){$n .= $ch;next_chr;if (!defined$ch or $ch =~ /\D/){decode_error("malformed number (no digits after exp sign)")}$n .= $ch}elsif(defined($ch)and $ch =~ /\d/){$n .= $ch}else {decode_error("malformed number (no digits after exp sign)")}while(defined(next_chr)and $ch =~ /\d/){$n .= $ch}}$v .= $n;if ($v !~ /[.eE]/ and length$v > $max_intsize){if ($allow_bigint){require Math::BigInt;return Math::BigInt->new($v)}else {return "$v"}}elsif ($allow_bigint){require Math::BigFloat;return Math::BigFloat->new($v)}return 0+$v}sub is_valid_utf8 {$utf8_len=$_[0]=~ /[\x00-\x7F]/ ? 1 : $_[0]=~ /[\xC2-\xDF]/ ? 2 : $_[0]=~ /[\xE0-\xEF]/ ? 3 : $_[0]=~ /[\xF0-\xF4]/ ? 4 : 0 ;return unless$utf8_len;my$is_valid_utf8=substr($text,$at - 1,$utf8_len);return ($is_valid_utf8 =~ /^(?:
|
|
253
|
+ [\x00-\x7F]
|
|
254
|
+ |[\xC2-\xDF][\x80-\xBF]
|
|
255
|
+ |[\xE0][\xA0-\xBF][\x80-\xBF]
|
|
256
|
+ |[\xE1-\xEC][\x80-\xBF][\x80-\xBF]
|
|
257
|
+ |[\xED][\x80-\x9F][\x80-\xBF]
|
|
258
|
+ |[\xEE-\xEF][\x80-\xBF][\x80-\xBF]
|
|
259
|
+ |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF]
|
|
260
|
+ |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF]
|
|
261
|
+ |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF]
|
|
262
|
+ )$/x)? $is_valid_utf8 : ''}sub decode_error {my$error=shift;my$no_rep=shift;my$str=defined$text ? substr($text,$at): '';my$mess='';my$type=$] >= 5.008 ? 'U*' : $] < 5.006 ? 'C*' : utf8::is_utf8($str)? 'U*' : 'C*' ;for my$c (unpack($type,$str)){$mess .= $c==0x07 ? '\a' : $c==0x09 ? '\t' : $c==0x0a ? '\n' : $c==0x0d ? '\r' : $c==0x0c ? '\f' : $c < 0x20 ? sprintf('\x{%x}',$c): $c==0x5c ? '\\\\' : $c < 0x80 ? chr($c): sprintf('\x{%x}',$c);if (length$mess >= 20){$mess .= '...';last}}unless (length$mess){$mess='(end of string)'}Carp::croak ($no_rep ? "$error" : "$error, at character offset $at (before \"$mess\")")}sub _json_object_hook {my$o=$_[0];my@ks=keys %{$o};if ($cb_sk_object and @ks==1 and exists$cb_sk_object->{$ks[0]}and ref$cb_sk_object->{$ks[0]}){my@val=$cb_sk_object->{$ks[0]}->($o->{$ks[0]});if (@val==1){return$val[0]}}my@val=$cb_object->($o)if ($cb_object);if (@val==0 or @val > 1){return$o}else {return$val[0]}}sub PP_decode_box {{text=>$text,at=>$at,ch=>$ch,len=>$len,depth=>$depth,encoding=>$encoding,is_valid_utf8=>$is_valid_utf8,}}}sub _decode_surrogates {my$uni=0x10000 + (hex($_[0])- 0xD800)* 0x400 + (hex($_[1])- 0xDC00);my$un=pack('U*',$uni);utf8::encode($un);return$un}sub _decode_unicode {my$un=pack('U',hex shift);utf8::encode($un);return$un}BEGIN {unless (defined&utf8::is_utf8){require Encode;*utf8::is_utf8=*Encode::is_utf8}if ($] >= 5.008){*JSON::PP::JSON_PP_encode_ascii=\&_encode_ascii;*JSON::PP::JSON_PP_encode_latin1=\&_encode_latin1;*JSON::PP::JSON_PP_decode_surrogates=\&_decode_surrogates;*JSON::PP::JSON_PP_decode_unicode=\&_decode_unicode}if ($] >= 5.008 and $] < 5.008003){package JSON::PP;require subs;subs->import('join');eval q|
|
|
263
|
+ sub join {
|
|
264
|
+ return '' if (@_ < 2);
|
|
265
|
+ my $j = shift;
|
|
266
|
+ my $str = shift;
|
|
267
|
+ for (@_) { $str .= $j . $_; }
|
|
268
|
+ return $str;
|
|
269
|
+ }
|
|
270
|
+ |}sub JSON::PP::incr_parse {local$Carp::CarpLevel=1;($_[0]->{_incr_parser}||= JSON::PP::IncrParser->new)->incr_parse(@_)}sub JSON::PP::incr_skip {($_[0]->{_incr_parser}||= JSON::PP::IncrParser->new)->incr_skip}sub JSON::PP::incr_reset {($_[0]->{_incr_parser}||= JSON::PP::IncrParser->new)->incr_reset}eval q{
|
|
271
|
+ sub JSON::PP::incr_text : lvalue {
|
|
272
|
+ $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new;
|
12154
|
273
|
|
12155
|
|
- return defined $version ? $version->stringify : undef;
|
12156
|
|
- }
|
|
274
|
+ if ( $_[0]->{_incr_parser}->{incr_parsing} ) {
|
|
275
|
+ Carp::croak("incr_text can not be called when the incremental parser already started parsing");
|
|
276
|
+ }
|
|
277
|
+ $_[0]->{_incr_parser}->{incr_text};
|
|
278
|
+ }
|
|
279
|
+ } if ($] >= 5.006)}BEGIN {eval 'require Scalar::Util';unless($@){*JSON::PP::blessed=\&Scalar::Util::blessed;*JSON::PP::reftype=\&Scalar::Util::reftype;*JSON::PP::refaddr=\&Scalar::Util::refaddr}else{eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }';*JSON::PP::blessed=sub {local($@,$SIG{__DIE__},$SIG{__WARN__});ref($_[0])? eval {$_[0]->a_sub_not_likely_to_be_here}: undef};my%tmap=qw(B::NULL SCALAR B::HV HASH B::AV ARRAY B::CV CODE B::IO IO B::GV GLOB B::REGEXP REGEXP);*JSON::PP::reftype=sub {my$r=shift;return undef unless length(ref($r));my$t=ref(B::svref_2object($r));return exists$tmap{$t}? $tmap{$t}: length(ref($$r))? 'REF' : 'SCALAR'};*JSON::PP::refaddr=sub {return undef unless length(ref($_[0]));my$addr;if(defined(my$pkg=blessed($_[0]))){$addr .= bless $_[0],'Scalar::Util::Fake';bless $_[0],$pkg}else {$addr .= $_[0]}$addr =~ /0x(\w+)/;local $^W;hex($1)}}}$JSON::PP::true=do {bless \(my$dummy=1),"JSON::PP::Boolean"};$JSON::PP::false=do {bless \(my$dummy=0),"JSON::PP::Boolean"};sub is_bool {defined $_[0]and UNIVERSAL::isa($_[0],"JSON::PP::Boolean")}sub true {$JSON::PP::true}sub false {$JSON::PP::false}sub null {undef}package JSON::PP::Boolean;use overload ("0+"=>sub {${$_[0]}},"++"=>sub {$_[0]=${$_[0]}+ 1},"--"=>sub {$_[0]=${$_[0]}- 1},fallback=>1,);package JSON::PP::IncrParser;use strict;use constant INCR_M_WS=>0;use constant INCR_M_STR=>1;use constant INCR_M_BS=>2;use constant INCR_M_JSON=>3;use constant INCR_M_C0=>4;use constant INCR_M_C1=>5;$JSON::PP::IncrParser::VERSION='1.01';my$unpack_format=$] < 5.006 ? 'C*' : 'U*';sub new {my ($class)=@_;bless {incr_nest=>0,incr_text=>undef,incr_parsing=>0,incr_p=>0,},$class}sub incr_parse {my ($self,$coder,$text)=@_;$self->{incr_text}='' unless (defined$self->{incr_text});if (defined$text){if (utf8::is_utf8($text)and!utf8::is_utf8($self->{incr_text})){utf8::upgrade($self->{incr_text});utf8::decode($self->{incr_text})}$self->{incr_text}.= $text}my$max_size=$coder->get_max_size;if (defined wantarray){$self->{incr_mode}=INCR_M_WS unless defined$self->{incr_mode};if (wantarray){my@ret;$self->{incr_parsing}=1;do {push@ret,$self->_incr_parse($coder,$self->{incr_text});unless (!$self->{incr_nest}and $self->{incr_mode}==INCR_M_JSON){$self->{incr_mode}=INCR_M_WS if$self->{incr_mode}!=INCR_M_STR}}until (length$self->{incr_text}>= $self->{incr_p});$self->{incr_parsing}=0;return@ret}else {$self->{incr_parsing}=1;my$obj=$self->_incr_parse($coder,$self->{incr_text});$self->{incr_parsing}=0 if defined$obj;return$obj ? $obj : undef}}}sub _incr_parse {my ($self,$coder,$text,$skip)=@_;my$p=$self->{incr_p};my$restore=$p;my@obj;my$len=length$text;if ($self->{incr_mode}==INCR_M_WS){while ($len > $p){my$s=substr($text,$p,1);$p++ and next if (0x20 >= unpack($unpack_format,$s));$self->{incr_mode}=INCR_M_JSON;last}}while ($len > $p){my$s=substr($text,$p++,1);if ($s eq '"'){if (substr($text,$p - 2,1)eq '\\'){next}if ($self->{incr_mode}!=INCR_M_STR){$self->{incr_mode}=INCR_M_STR}else {$self->{incr_mode}=INCR_M_JSON;unless ($self->{incr_nest}){last}}}if ($self->{incr_mode}==INCR_M_JSON){if ($s eq '[' or $s eq '{'){if (++$self->{incr_nest}> $coder->get_max_depth){Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')}}elsif ($s eq ']' or $s eq '}'){last if (--$self->{incr_nest}<= 0)}elsif ($s eq '#'){while ($len > $p){last if substr($text,$p++,1)eq "\n"}}}}$self->{incr_p}=$p;return if ($self->{incr_mode}==INCR_M_STR and not $self->{incr_nest});return if ($self->{incr_mode}==INCR_M_JSON and $self->{incr_nest}> 0);return '' unless (length substr($self->{incr_text},0,$p));local$Carp::CarpLevel=2;$self->{incr_p}=$restore;$self->{incr_c}=$p;my ($obj,$tail)=$coder->PP_decode_json(substr($self->{incr_text},0,$p),0x10000001);$self->{incr_text}=substr($self->{incr_text},$p);$self->{incr_p}=0;return$obj || ''}sub incr_text {if ($_[0]->{incr_parsing}){Carp::croak("incr_text can not be called when the incremental parser already started parsing")}$_[0]->{incr_text}}sub incr_skip {my$self=shift;$self->{incr_text}=substr($self->{incr_text},$self->{incr_c});$self->{incr_p}=0}sub incr_reset {my$self=shift;$self->{incr_text}=undef;$self->{incr_p}=0;$self->{incr_mode}=0;$self->{incr_nest}=0;$self->{incr_parsing}=0}1;
|
|
280
|
+JSON_PP
|
|
281
|
+
|
|
282
|
+$fatpacked{"JSON/PP/Boolean.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP_BOOLEAN';
|
|
283
|
+ use JSON::PP ();use strict;1;
|
|
284
|
+JSON_PP_BOOLEAN
|
|
285
|
+
|
|
286
|
+$fatpacked{"Module/CPANfile.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE';
|
|
287
|
+ package Module::CPANfile;use strict;use warnings;use Cwd;use Carp ();use Module::CPANfile::Environment;use Module::CPANfile::Requirement;our$VERSION='1.1000';sub new {my($class,$file)=@_;bless {},$class}sub load {my($proto,$file)=@_;my$self=ref$proto ? $proto : $proto->new;$self->parse($file || Cwd::abs_path('cpanfile'));$self}sub save {my($self,$path)=@_;open my$out,">",$path or die "$path: $!";print {$out}$self->to_string}sub parse {my($self,$file)=@_;my$code=do {open my$fh,"<",$file or die "$file: $!";join '',<$fh>};my$env=Module::CPANfile::Environment->new($file);$env->parse($code)or die $@;$self->{_mirrors}=$env->mirrors;$self->{_prereqs}=$env->prereqs}sub from_prereqs {my($proto,$prereqs)=@_;my$self=$proto->new;$self->{_prereqs}=Module::CPANfile::Prereqs->from_cpan_meta($prereqs);$self}sub mirrors {my$self=shift;$self->{_mirrors}|| []}sub features {my$self=shift;map$self->feature($_),$self->{_prereqs}->identifiers}sub feature {my($self,$identifier)=@_;$self->{_prereqs}->feature($identifier)}sub prereq {shift->prereqs}sub prereqs {my$self=shift;$self->{_prereqs}->as_cpan_meta}sub merged_requirements {my$self=shift;$self->{_prereqs}->merged_requirements}sub effective_prereqs {my($self,$features)=@_;$self->prereqs_with(@{$features || []})}sub prereqs_with {my($self,@feature_identifiers)=@_;my$prereqs=$self->prereqs;my@others=map {$self->feature($_)->prereqs}@feature_identifiers;$prereqs->with_merged_prereqs(\@others)}sub prereq_specs {my$self=shift;$self->prereqs->as_string_hash}sub prereq_for_module {my($self,$module)=@_;$self->{_prereqs}->find($module)}sub options_for_module {my($self,$module)=@_;my$prereq=$self->prereq_for_module($module)or return;$prereq->requirement->options}sub merge_meta {my($self,$file,$version)=@_;require CPAN::Meta;$version ||= $file =~ /\.yml$/ ? '1.4' : '2';my$prereq=$self->prereqs;my$meta=CPAN::Meta->load_file($file);my$prereqs_hash=$prereq->with_merged_prereqs($meta->effective_prereqs)->as_string_hash;my$struct={%{$meta->as_struct},prereqs=>$prereqs_hash };CPAN::Meta->new($struct)->save($file,{version=>$version })}sub _dump {my$str=shift;require Data::Dumper;chomp(my$value=Data::Dumper->new([$str])->Terse(1)->Dump);$value}sub to_string {my($self,$include_empty)=@_;my$mirrors=$self->mirrors;my$prereqs=$self->prereq_specs;my$code='';$code .= $self->_dump_mirrors($mirrors);$code .= $self->_dump_prereqs($prereqs,$include_empty);for my$feature ($self->features){$code .= sprintf "feature %s, %s => sub {\n",_dump($feature->{identifier}),_dump($feature->{description});$code .= $self->_dump_prereqs($feature->{spec},$include_empty,4);$code .= "}\n\n"}$code =~ s/\n+$/\n/s;$code}sub _dump_mirrors {my($self,$mirrors)=@_;my$code="";for my$url (@$mirrors){$code .= "mirror '$url';\n"}$code =~ s/\n+$/\n/s;$code}sub _dump_prereqs {my($self,$prereqs,$include_empty,$base_indent)=@_;my$code='';for my$phase (qw(runtime configure build test develop)){my$indent=$phase eq 'runtime' ? '' : ' ';$indent=(' ' x ($base_indent || 0)).$indent;my($phase_code,$requirements);$phase_code .= "on $phase => sub {\n" unless$phase eq 'runtime';for my$type (qw(requires recommends suggests conflicts)){for my$mod (sort keys %{$prereqs->{$phase}{$type}}){my$ver=$prereqs->{$phase}{$type}{$mod};$phase_code .= $ver eq '0' ? "${indent}$type '$mod';\n" : "${indent}$type '$mod', '$ver';\n";$requirements++}}$phase_code .= "\n" unless$requirements;$phase_code .= "};\n" unless$phase eq 'runtime';$code .= $phase_code ."\n" if$requirements or $include_empty}$code =~ s/\n+$/\n/s;$code}1;
|
|
288
|
+MODULE_CPANFILE
|
|
289
|
+
|
|
290
|
+$fatpacked{"Module/CPANfile/Environment.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_ENVIRONMENT';
|
|
291
|
+ package Module::CPANfile::Environment;use strict;use warnings;use Module::CPANfile::Prereqs;use Carp ();my@bindings=qw(on requires recommends suggests conflicts feature osname mirror configure_requires build_requires test_requires author_requires);my$file_id=1;sub new {my($class,$file)=@_;bless {file=>$file,phase=>'runtime',feature=>undef,features=>{},prereqs=>Module::CPANfile::Prereqs->new,mirrors=>[],},$class}sub bind {my$self=shift;my$pkg=caller;for my$binding (@bindings){no strict 'refs';*{"$pkg\::$binding"}=sub {$self->$binding(@_)}}}sub parse {my($self,$code)=@_;my$err;{local $@;$file_id++;$self->_evaluate(<<EVAL);$err=$@}if ($err){die "Parsing $self->{file} failed: $err"};return 1}sub _evaluate {my$_environment=$_[0];eval $_[1]}sub prereqs {$_[0]->{prereqs}}sub mirrors {$_[0]->{mirrors}}sub on {my($self,$phase,$code)=@_;local$self->{phase}=$phase;$code->()}sub feature {my($self,$identifier,$description,$code)=@_;if (@_==3 && ref($description)eq 'CODE'){$code=$description;$description=$identifier}unless (ref$description eq '' && ref$code eq 'CODE'){Carp::croak("Usage: feature 'identifier', 'Description' => sub { ... }")}local$self->{feature}=$identifier;$self->prereqs->add_feature($identifier,$description);$code->()}sub osname {die "TODO"}sub mirror {my($self,$url)=@_;push @{$self->{mirrors}},$url}sub requirement_for {my($self,$module,@args)=@_;my$requirement=0;$requirement=shift@args if@args % 2;return Module::CPANfile::Requirement->new(name=>$module,version=>$requirement,@args,)}sub requires {my$self=shift;$self->add_prereq(requires=>@_)}sub recommends {my$self=shift;$self->add_prereq(recommends=>@_)}sub suggests {my$self=shift;$self->add_prereq(suggests=>@_)}sub conflicts {my$self=shift;$self->add_prereq(conflicts=>@_)}sub add_prereq {my($self,$type,$module,@args)=@_;$self->prereqs->add_prereq(feature=>$self->{feature},phase=>$self->{phase},type=>$type,module=>$module,requirement=>$self->requirement_for($module,@args),)}sub configure_requires {my($self,@args)=@_;$self->on(configure=>sub {$self->requires(@args)})}sub build_requires {my($self,@args)=@_;$self->on(build=>sub {$self->requires(@args)})}sub test_requires {my($self,@args)=@_;$self->on(test=>sub {$self->requires(@args)})}sub author_requires {my($self,@args)=@_;$self->on(develop=>sub {$self->requires(@args)})}1;
|
|
292
|
+ package Module::CPANfile::Sandbox$file_id;
|
|
293
|
+ no warnings;
|
|
294
|
+ BEGIN { \$_environment->bind }
|
12157
|
295
|
|
12158
|
|
- 1; #this line is important and will help the module return a true value
|
|
296
|
+ # line 1 "$self->{file}"
|
|
297
|
+ $code;
|
|
298
|
+ EVAL
|
|
299
|
+MODULE_CPANFILE_ENVIRONMENT
|
|
300
|
+
|
|
301
|
+$fatpacked{"Module/CPANfile/Prereq.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_PREREQ';
|
|
302
|
+ package Module::CPANfile::Prereq;use strict;sub new {my($class,%options)=@_;bless \%options,$class}sub feature {$_[0]->{feature}}sub phase {$_[0]->{phase}}sub type {$_[0]->{type}}sub module {$_[0]->{module}}sub requirement {$_[0]->{requirement}}sub match_feature {my($self,$identifier)=@_;no warnings 'uninitialized';$self->feature eq $identifier}1;
|
|
303
|
+MODULE_CPANFILE_PREREQ
|
|
304
|
+
|
|
305
|
+$fatpacked{"Module/CPANfile/Prereqs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_PREREQS';
|
|
306
|
+ package Module::CPANfile::Prereqs;use strict;use Carp ();use CPAN::Meta::Feature;use Module::CPANfile::Prereq;sub from_cpan_meta {my($class,$prereqs)=@_;my$self=$class->new;for my$phase (keys %$prereqs){for my$type (keys %{$prereqs->{$phase}}){while (my($module,$requirement)=each %{$prereqs->{$phase}{$type}}){$self->add_prereq(phase=>$phase,type=>$type,module=>$module,requirement=>Module::CPANfile::Requirement->new(name=>$module,version=>$requirement),)}}}$self}sub new {my$class=shift;bless {prereqs=>[],features=>{},},$class}sub add_feature {my($self,$identifier,$description)=@_;$self->{features}{$identifier}={description=>$description }}sub add_prereq {my($self,%args)=@_;$self->add(Module::CPANfile::Prereq->new(%args))}sub add {my($self,$prereq)=@_;push @{$self->{prereqs}},$prereq}sub as_cpan_meta {my$self=shift;$self->{cpanmeta}||= $self->build_cpan_meta}sub build_cpan_meta {my($self,$identifier)=@_;my$prereq_spec={};$self->prereq_each($identifier,sub {my$prereq=shift;$prereq_spec->{$prereq->phase}{$prereq->type}{$prereq->module}=$prereq->requirement->version});CPAN::Meta::Prereqs->new($prereq_spec)}sub prereq_each {my($self,$identifier,$code)=@_;for my$prereq (@{$self->{prereqs}}){next unless$prereq->match_feature($identifier);$code->($prereq)}}sub merged_requirements {my$self=shift;my$reqs=CPAN::Meta::Requirements->new;for my$prereq (@{$self->{prereqs}}){$reqs->add_string_requirement($prereq->module,$prereq->requirement->version)}$reqs}sub find {my($self,$module)=@_;for my$prereq (@{$self->{prereqs}}){return$prereq if$prereq->module eq $module}return}sub identifiers {my$self=shift;keys %{$self->{features}}}sub feature {my($self,$identifier)=@_;my$data=$self->{features}{$identifier}or Carp::croak("Unknown feature '$identifier'");my$prereqs=$self->build_cpan_meta($identifier);CPAN::Meta::Feature->new($identifier,{description=>$data->{description},prereqs=>$prereqs->as_string_hash,})}1;
|
|
307
|
+MODULE_CPANFILE_PREREQS
|
|
308
|
+
|
|
309
|
+$fatpacked{"Module/CPANfile/Requirement.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_REQUIREMENT';
|
|
310
|
+ package Module::CPANfile::Requirement;use strict;sub new {my ($class,%args)=@_;$args{version}||= 0;bless +{name=>delete$args{name},version=>delete$args{version},options=>\%args,},$class}sub name {$_[0]->{name}}sub version {$_[0]->{version}}sub options {$_[0]->{options}}sub has_options {keys %{$_[0]->{options}}> 0}1;
|
|
311
|
+MODULE_CPANFILE_REQUIREMENT
|
|
312
|
+
|
|
313
|
+$fatpacked{"Module/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_METADATA';
|
|
314
|
+ package Module::Metadata;sub __clean_eval {eval $_[0]}use strict;use warnings;our$VERSION='1.000027';use Carp qw/croak/;use File::Spec;BEGIN {eval {require Fcntl;Fcntl->import('SEEK_SET');1}or *SEEK_SET=sub {0}}use version 0.87;BEGIN {if ($INC{'Log/Contextual.pm'}){require "Log/Contextual/WarnLogger.pm";Log::Contextual->import('log_info','-default_logger'=>Log::Contextual::WarnLogger->new({env_prefix=>'MODULE_METADATA',}),)}else {*log_info=sub (&) {warn $_[0]->()}}}use File::Find qw(find);my$V_NUM_REGEXP=qr{v?[0-9._]+};my$PKG_FIRST_WORD_REGEXP=qr{ # the FIRST word in a package name
|
|
315
|
+ [a-zA-Z_] # the first word CANNOT start with a digit
|
|
316
|
+ (?:
|
|
317
|
+ [\w']? # can contain letters, digits, _, or ticks
|
|
318
|
+ \w # But, NO multi-ticks or trailing ticks
|
|
319
|
+ )*
|
|
320
|
+ }x;my$PKG_ADDL_WORD_REGEXP=qr{ # the 2nd+ word in a package name
|
|
321
|
+ \w # the 2nd+ word CAN start with digits
|
|
322
|
+ (?:
|
|
323
|
+ [\w']? # and can contain letters or ticks
|
|
324
|
+ \w # But, NO multi-ticks or trailing ticks
|
|
325
|
+ )*
|
|
326
|
+ }x;my$PKG_NAME_REGEXP=qr{ # match a package name
|
|
327
|
+ (?: :: )? # a pkg name can start with arisdottle
|
|
328
|
+ $PKG_FIRST_WORD_REGEXP # a package word
|
|
329
|
+ (?:
|
|
330
|
+ (?: :: )+ ### arisdottle (allow one or many times)
|
|
331
|
+ $PKG_ADDL_WORD_REGEXP ### a package word
|
|
332
|
+ )* # ^ zero, one or many times
|
|
333
|
+ (?:
|
|
334
|
+ :: # allow trailing arisdottle
|
|
335
|
+ )?
|
|
336
|
+ }x;my$PKG_REGEXP=qr{ # match a package declaration
|
|
337
|
+ ^[\s\{;]* # intro chars on a line
|
|
338
|
+ package # the word 'package'
|
|
339
|
+ \s+ # whitespace
|
|
340
|
+ ($PKG_NAME_REGEXP) # a package name
|
|
341
|
+ \s* # optional whitespace
|
|
342
|
+ ($V_NUM_REGEXP)? # optional version number
|
|
343
|
+ \s* # optional whitesapce
|
|
344
|
+ [;\{] # semicolon line terminator or block start (since 5.16)
|
|
345
|
+ }x;my$VARNAME_REGEXP=qr{ # match fully-qualified VERSION name
|
|
346
|
+ ([\$*]) # sigil - $ or *
|
|
347
|
+ (
|
|
348
|
+ ( # optional leading package name
|
|
349
|
+ (?:::|\')? # possibly starting like just :: (a la $::VERSION)
|
|
350
|
+ (?:\w+(?:::|\'))* # Foo::Bar:: ...
|
|
351
|
+ )?
|
|
352
|
+ VERSION
|
|
353
|
+ )\b
|
|
354
|
+ }x;my$VERS_REGEXP=qr{ # match a VERSION definition
|
|
355
|
+ (?:
|
|
356
|
+ \(\s*$VARNAME_REGEXP\s*\) # with parens
|
|
357
|
+ |
|
|
358
|
+ $VARNAME_REGEXP # without parens
|
|
359
|
+ )
|
|
360
|
+ \s*
|
|
361
|
+ =[^=~>] # = but not ==, nor =~, nor =>
|
|
362
|
+ }x;sub new_from_file {my$class=shift;my$filename=File::Spec->rel2abs(shift);return undef unless defined($filename)&& -f $filename;return$class->_init(undef,$filename,@_)}sub new_from_handle {my$class=shift;my$handle=shift;my$filename=shift;return undef unless defined($handle)&& defined($filename);$filename=File::Spec->rel2abs($filename);return$class->_init(undef,$filename,@_,handle=>$handle)}sub new_from_module {my$class=shift;my$module=shift;my%props=@_;$props{inc}||= \@INC;my$filename=$class->find_module_by_name($module,$props{inc});return undef unless defined($filename)&& -f $filename;return$class->_init($module,$filename,%props)}{my$compare_versions=sub {my ($v1,$op,$v2)=@_;$v1=version->new($v1)unless UNIVERSAL::isa($v1,'version');my$eval_str="\$v1 $op \$v2";my$result=eval$eval_str;log_info {"error comparing versions: '$eval_str' $@"}if $@;return$result};my$normalize_version=sub {my ($version)=@_;if ($version =~ /[=<>!,]/){}elsif (ref$version eq 'version'){$version=$version->is_qv ? $version->normal : $version->stringify}elsif ($version =~ /^[^v][^.]*\.[^.]+\./){$version="v$version"}else {}return$version};my$resolve_module_versions=sub {my$packages=shift;my($file,$version);my$err='';for my$p (@$packages){if (defined($p->{version})){if (defined($version)){if ($compare_versions->($version,'!=',$p->{version})){$err .= " $p->{file} ($p->{version})\n"}else {}}else {$file=$p->{file};$version=$p->{version}}}$file ||= $p->{file}if defined($p->{file})}if ($err){$err=" $file ($version)\n" .$err}my%result=(file=>$file,version=>$version,err=>$err);return \%result};sub provides {my$class=shift;croak "provides() requires key/value pairs \n" if @_ % 2;my%args=@_;croak "provides() takes only one of 'dir' or 'files'\n" if$args{dir}&& $args{files};croak "provides() requires a 'version' argument" unless defined$args{version};croak "provides() does not support version '$args{version}' metadata" unless grep {$args{version}eq $_}qw/1.4 2/;$args{prefix}='lib' unless defined$args{prefix};my$p;if ($args{dir}){$p=$class->package_versions_from_directory($args{dir})}else {croak "provides() requires 'files' to be an array reference\n" unless ref$args{files}eq 'ARRAY';$p=$class->package_versions_from_directory($args{files})}if (length$args{prefix}){$args{prefix}=~ s{/$}{};for my$v (values %$p){$v->{file}="$args{prefix}/$v->{file}"}}return$p}sub package_versions_from_directory {my ($class,$dir,$files)=@_;my@files;if ($files){@files=@$files}else {find({wanted=>sub {push@files,$_ if -f $_ && /\.pm$/},no_chdir=>1,},$dir)}my(%prime,%alt);for my$file (@files){my$mapped_filename=File::Spec::Unix->abs2rel($file,$dir);my@path=split(/\//,$mapped_filename);(my$prime_package=join('::',@path))=~ s/\.pm$//;my$pm_info=$class->new_from_file($file);for my$package ($pm_info->packages_inside){next if$package eq 'main';next if$package eq 'DB';next if grep /^_/,split(/::/,$package);my$version=$pm_info->version($package);$prime_package=$package if lc($prime_package)eq lc($package);if ($package eq $prime_package){if (exists($prime{$package})){croak "Unexpected conflict in '$package'; multiple versions found.\n"}else {$mapped_filename="$package.pm" if lc("$package.pm")eq lc($mapped_filename);$prime{$package}{file}=$mapped_filename;$prime{$package}{version}=$version if defined($version)}}else {push(@{$alt{$package}},{file=>$mapped_filename,version=>$version,})}}}for my$package (keys(%alt)){my$result=$resolve_module_versions->($alt{$package});if (exists($prime{$package})){if ($result->{err}){log_info {"Found conflicting versions for package '$package'\n" ." $prime{$package}{file} ($prime{$package}{version})\n" .$result->{err}}}elsif (defined($result->{version})){if (exists($prime{$package}{version})&& defined($prime{$package}{version})){if ($compare_versions->($prime{$package}{version},'!=',$result->{version})){log_info {"Found conflicting versions for package '$package'\n" ." $prime{$package}{file} ($prime{$package}{version})\n" ." $result->{file} ($result->{version})\n"}}}else {$prime{$package}{file}=$result->{file};$prime{$package}{version}=$result->{version}}}else {}}else {if ($result->{err}){log_info {"Found conflicting versions for package '$package'\n" .$result->{err}}}$prime{$package}{file}=$result->{file};$prime{$package}{version}=$result->{version}if defined($result->{version})}}for (grep defined $_->{version},values%prime){$_->{version}=$normalize_version->($_->{version})}return \%prime}}sub _init {my$class=shift;my$module=shift;my$filename=shift;my%props=@_;my$handle=delete$props{handle};my(%valid_props,@valid_props);@valid_props=qw(collect_pod inc);@valid_props{@valid_props}=delete(@props{@valid_props});warn "Unknown properties: @{[keys %props]}\n" if scalar(%props);my%data=(module=>$module,filename=>$filename,version=>undef,packages=>[],versions=>{},pod=>{},pod_headings=>[],collect_pod=>0,%valid_props,);my$self=bless(\%data,$class);if (not $handle){my$filename=$self->{filename};open$handle,'<',$filename or croak("Can't open '$filename': $!");$self->_handle_bom($handle,$filename)}$self->_parse_fh($handle);unless($self->{module}and length($self->{module})){my ($v,$d,$f)=File::Spec->splitpath($self->{filename});if($f =~ /\.pm$/){$f =~ s/\..+$//;my@candidates=grep /$f$/,@{$self->{packages}};$self->{module}=shift(@candidates)}else {if(grep /main/,@{$self->{packages}}){$self->{module}='main'}else {$self->{module}=$self->{packages}[0]|| ''}}}$self->{version}=$self->{versions}{$self->{module}}if defined($self->{module});return$self}sub _do_find_module {my$class=shift;my$module=shift || croak 'find_module_by_name() requires a package name';my$dirs=shift || \@INC;my$file=File::Spec->catfile(split(/::/,$module));for my$dir (@$dirs){my$testfile=File::Spec->catfile($dir,$file);return [File::Spec->rel2abs($testfile),$dir ]if -e $testfile and!-d _;$testfile .= '.pm';return [File::Spec->rel2abs($testfile),$dir ]if -e $testfile}return}sub find_module_by_name {my$found=shift()->_do_find_module(@_)or return;return$found->[0]}sub find_module_dir_by_name {my$found=shift()->_do_find_module(@_)or return;return$found->[1]}sub _parse_version_expression {my$self=shift;my$line=shift;my($sigil,$variable_name,$package);if ($line =~ /$VERS_REGEXP/o){($sigil,$variable_name,$package)=$2 ? ($1,$2,$3): ($4,$5,$6);if ($package){$package=($package eq '::')? 'main' : $package;$package =~ s/::$//}}return ($sigil,$variable_name,$package)}sub _handle_bom {my ($self,$fh,$filename)=@_;my$pos=tell$fh;return unless defined$pos;my$buf=' ' x 2;my$count=read$fh,$buf,length$buf;return unless defined$count and $count >= 2;my$encoding;if ($buf eq "\x{FE}\x{FF}"){$encoding='UTF-16BE'}elsif ($buf eq "\x{FF}\x{FE}"){$encoding='UTF-16LE'}elsif ($buf eq "\x{EF}\x{BB}"){$buf=' ';$count=read$fh,$buf,length$buf;if (defined$count and $count >= 1 and $buf eq "\x{BF}"){$encoding='UTF-8'}}if (defined$encoding){if ("$]" >= 5.008){binmode($fh,":encoding($encoding)")}}else {seek$fh,$pos,SEEK_SET or croak(sprintf "Can't reset position to the top of '$filename'")}return$encoding}sub _parse_fh {my ($self,$fh)=@_;my($in_pod,$seen_end,$need_vers)=(0,0,0);my(@packages,%vers,%pod,@pod);my$package='main';my$pod_sect='';my$pod_data='';my$in_end=0;while (defined(my$line=<$fh>)){my$line_num=$.;chomp($line);my$is_cut;if ($line =~ /^=([a-zA-Z].*)/){my$cmd=$1;$is_cut=$cmd =~ /^cut(?:[^a-zA-Z]|$)/;$in_pod=!$is_cut}if ($in_pod){if ($line =~ /^=head[1-4]\s+(.+)\s*$/){push(@pod,$1);if ($self->{collect_pod}&& length($pod_data)){$pod{$pod_sect}=$pod_data;$pod_data=''}$pod_sect=$1}elsif ($self->{collect_pod}){$pod_data .= "$line\n"}}elsif ($is_cut){if ($self->{collect_pod}&& length($pod_data)){$pod{$pod_sect}=$pod_data;$pod_data=''}$pod_sect=''}else {next if$in_end;next if$line =~ /^\s*#/;if ($line eq '__END__'){$in_end++;next}last if$line eq '__DATA__';my($version_sigil,$version_fullname,$version_package)=index($line,'VERSION')>= 1 ? $self->_parse_version_expression($line): ();if ($line =~ /$PKG_REGEXP/o){$package=$1;my$version=$2;push(@packages,$package)unless grep($package eq $_,@packages);$need_vers=defined$version ? 0 : 1;if (not exists$vers{$package}and defined$version){my$dwim_version=eval {_dwim_version($version)};croak "Version '$version' from $self->{filename} does not appear to be valid:\n$line\n\nThe fatal error was: $@\n" unless defined$dwim_version;$vers{$package}=$dwim_version}}elsif ($version_fullname && $version_package){push(@packages,$version_package)unless grep($version_package eq $_,@packages);$need_vers=0 if$version_package eq $package;unless (defined$vers{$version_package}&& length$vers{$version_package}){$vers{$version_package}=$self->_evaluate_version_line($version_sigil,$version_fullname,$line)}}elsif ($package eq 'main' && $version_fullname &&!exists($vers{main})){$need_vers=0;my$v=$self->_evaluate_version_line($version_sigil,$version_fullname,$line);$vers{$package}=$v;push(@packages,'main')}elsif ($package eq 'main' &&!exists($vers{main})&& $line =~ /\w/){$need_vers=1;$vers{main}='';push(@packages,'main')}elsif ($version_fullname && $need_vers){$need_vers=0;my$v=$self->_evaluate_version_line($version_sigil,$version_fullname,$line);unless (defined$vers{$package}&& length$vers{$package}){$vers{$package}=$v}}}}if ($self->{collect_pod}&& length($pod_data)){$pod{$pod_sect}=$pod_data}$self->{versions}=\%vers;$self->{packages}=\@packages;$self->{pod}=\%pod;$self->{pod_headings}=\@pod}{my$pn=0;sub _evaluate_version_line {my$self=shift;my($sigil,$variable_name,$line)=@_;$pn++;my$eval=qq{ my \$dummy = q# Hide from _packages_inside()
|
|
363
|
+ #; package Module::Metadata::_version::p${pn};
|
|
364
|
+ use version;
|
|
365
|
+ sub {
|
|
366
|
+ local $sigil$variable_name;
|
|
367
|
+ $line;
|
|
368
|
+ \$$variable_name
|
|
369
|
+ };
|
|
370
|
+ };$eval=$1 if$eval =~ m{^(.+)}s;local $^W;my$vsub=__clean_eval($eval);if ($@ =~ /Can't locate/ && -d 'lib'){local@INC=('lib',@INC);$vsub=__clean_eval($eval)}warn "Error evaling version line '$eval' in $self->{filename}: $@\n" if $@;(ref($vsub)eq 'CODE')or croak "failed to build version sub for $self->{filename}";my$result=eval {$vsub->()};croak "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n" if $@;my$version=eval {_dwim_version($result)};croak "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n" unless defined$version;return$version}}{my@version_prep=(sub {return shift},sub {my$v=shift;$v =~ s{([0-9])[a-z-].*$}{$1}i;return$v},sub {my$v=shift;my$num_dots=()=$v =~ m{(\.)}g;my$num_unders=()=$v =~ m{(_)}g;my$leading_v=substr($v,0,1)eq 'v';if (!$leading_v && $num_dots < 2 && $num_unders > 1){$v =~ s{_}{}g;$num_unders=()=$v =~ m{(_)}g}return$v},sub {my$v=shift;no warnings 'numeric';return 0 + $v},);sub _dwim_version {my ($result)=shift;return$result if ref($result)eq 'version';my ($version,$error);for my$f (@version_prep){$result=$f->($result);$version=eval {version->new($result)};$error ||= $@ if $@;last if defined$version}croak$error unless defined$version;return$version}}sub name {$_[0]->{module}}sub filename {$_[0]->{filename}}sub packages_inside {@{$_[0]->{packages}}}sub pod_inside {@{$_[0]->{pod_headings}}}sub contains_pod {0+@{$_[0]->{pod_headings}}}sub version {my$self=shift;my$mod=shift || $self->{module};my$vers;if (defined($mod)&& length($mod)&& exists($self->{versions}{$mod})){return$self->{versions}{$mod}}else {return undef}}sub pod {my$self=shift;my$sect=shift;if (defined($sect)&& length($sect)&& exists($self->{pod}{$sect})){return$self->{pod}{$sect}}else {return undef}}sub is_indexable {my ($self,$package)=@_;my@indexable_packages=grep {$_ ne 'main'}$self->packages_inside;return!!grep {$_ eq $package}@indexable_packages if$package;return!!@indexable_packages}1;
|
|
371
|
+MODULE_METADATA
|
|
372
|
+
|
|
373
|
+$fatpacked{"Parse/CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PARSE_CPAN_META';
|
|
374
|
+ use 5.008001;use strict;package Parse::CPAN::Meta;our$VERSION='1.4414';use Exporter;use Carp 'croak';our@ISA=qw/Exporter/;our@EXPORT_OK=qw/Load LoadFile/;sub load_file {my ($class,$filename)=@_;my$meta=_slurp($filename);if ($filename =~ /\.ya?ml$/){return$class->load_yaml_string($meta)}elsif ($filename =~ /\.json$/){return$class->load_json_string($meta)}else {$class->load_string($meta)}}sub load_string {my ($class,$string)=@_;if ($string =~ /^---/){return$class->load_yaml_string($string)}elsif ($string =~ /^\s*\{/){return$class->load_json_string($string)}else {return$class->load_yaml_string($string)}}sub load_yaml_string {my ($class,$string)=@_;my$backend=$class->yaml_backend();my$data=eval {no strict 'refs';&{"$backend\::Load"}($string)};croak $@ if $@;return$data || {}}sub load_json_string {my ($class,$string)=@_;my$data=eval {$class->json_backend()->new->decode($string)};croak $@ if $@;return$data || {}}sub yaml_backend {if (!defined$ENV{PERL_YAML_BACKEND}){_can_load('CPAN::Meta::YAML',0.011)or croak "CPAN::Meta::YAML 0.011 is not available\n";return "CPAN::Meta::YAML"}else {my$backend=$ENV{PERL_YAML_BACKEND};_can_load($backend)or croak "Could not load PERL_YAML_BACKEND '$backend'\n";$backend->can("Load")or croak "PERL_YAML_BACKEND '$backend' does not implement Load()\n";return$backend}}sub json_backend {if (!$ENV{PERL_JSON_BACKEND}or $ENV{PERL_JSON_BACKEND}eq 'JSON::PP'){_can_load('JSON::PP'=>2.27103)or croak "JSON::PP 2.27103 is not available\n";return 'JSON::PP'}else {_can_load('JSON'=>2.5)or croak "JSON 2.5 is required for " ."\$ENV{PERL_JSON_BACKEND} = '$ENV{PERL_JSON_BACKEND}'\n";return "JSON"}}sub _slurp {require Encode;open my$fh,"<:raw","$_[0]" or die "can't open $_[0] for reading: $!";my$content=do {local $/;<$fh>};$content=Encode::decode('UTF-8',$content,Encode::PERLQQ());return$content}sub _can_load {my ($module,$version)=@_;(my$file=$module)=~ s{::}{/}g;$file .= ".pm";return 1 if$INC{$file};return 0 if exists$INC{$file};eval {require$file;1}or return 0;if (defined$version){eval {$module->VERSION($version);1}or return 0}return 1}sub LoadFile ($) {return Load(_slurp(shift))}sub Load ($) {require CPAN::Meta::YAML;my$object=eval {CPAN::Meta::YAML::Load(shift)};croak $@ if $@;return$object}1;
|
|
375
|
+PARSE_CPAN_META
|
|
376
|
+
|
|
377
|
+$fatpacked{"Parse/PMFile.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PARSE_PMFILE';
|
|
378
|
+ package Parse::PMFile;sub __clean_eval {eval $_[0]}use strict;use warnings;use Safe;use JSON::PP ();use Dumpvalue;use version ();use File::Spec ();our$VERSION='0.36';our$VERBOSE=0;our$ALLOW_DEV_VERSION=0;our$FORK=0;our$UNSAFE=$] < 5.010000 ? 1 : 0;sub new {my ($class,$meta,$opts)=@_;bless {%{$opts || {}},META_CONTENT=>$meta},$class}sub parse {my ($self,$pmfile)=@_;$pmfile =~ s|\\|/|g;my($filemtime)=(stat$pmfile)[9];$self->{MTIME}=$filemtime;$self->{PMFILE}=$pmfile;unless ($self->_version_from_meta_ok){my$version;unless (eval {$version=$self->_parse_version;1}){$self->_verbose(1,"error with version in $pmfile: $@");return}$self->{VERSION}=$version;if ($self->{VERSION}=~ /^\{.*\}$/){}elsif ($self->{VERSION}=~ /[_\s]/ &&!$self->{ALLOW_DEV_VERSION}&&!$ALLOW_DEV_VERSION){return}}my($ppp)=$self->_packages_per_pmfile;my@keys_ppp=$self->_filter_ppps(sort keys %$ppp);$self->_verbose(1,"Will check keys_ppp[@keys_ppp]\n");my ($package,%errors);my%checked_in;DBPACK: foreach$package (@keys_ppp){if ($package !~ /^\w[\w\:\']*\w?\z/ || $package !~ /\w\z/ || $package =~ /:/ && $package !~ /::/ || $package =~ /\w:\w/ || $package =~ /:::/){$self->_verbose(1,"Package[$package] did not pass the ultimate sanity check");delete$ppp->{$package};next}if ($self->{USERID}&& $self->{PERMISSIONS}&&!$self->_perm_check($package)){delete$ppp->{$package};next}{my (undef,$module)=split m{/lib/},$self->{PMFILE},2;if ($module){$module =~ s{\.pm\z}{};$module =~ s{/}{::}g;if (lc$module eq lc$package && $module ne $package){$errors{$package}={indexing_warning=>"Capitalization of package ($package) does not match filename!",infile=>$self->{PMFILE},}}}}my$pp=$ppp->{$package};if ($pp->{version}&& $pp->{version}=~ /^\{.*\}$/){my$err=JSON::PP::decode_json($pp->{version});if ($err->{x_normalize}){$errors{$package}={normalize=>$err->{version},infile=>$pp->{infile},};$pp->{version}="undef"}elsif ($err->{openerr}){$pp->{version}="undef";$self->_verbose(1,qq{Parse::PMFile was not able to
|
|
379
|
+ read the file. It issued the following error: C< $err->{r} >},);$errors{$package}={open=>$err->{r},infile=>$pp->{infile},}}else {$pp->{version}="undef";$self->_verbose(1,qq{Parse::PMFile was not able to
|
|
380
|
+ parse the following line in that file: C< $err->{line} >
|
|
381
|
+
|
|
382
|
+ Note: the indexer is running in a Safe compartement and cannot
|
|
383
|
+ provide the full functionality of perl in the VERSION line. It
|
|
384
|
+ is trying hard, but sometime it fails. As a workaround, please
|
|
385
|
+ consider writing a META.yml that contains a 'provides'
|
|
386
|
+ attribute or contact the CPAN admins to investigate (yet
|
|
387
|
+ another) workaround against "Safe" limitations.)},);$errors{$package}={parse_version=>$err->{line},infile=>$err->{file},}}}for ($package,$pp->{version},){if (!defined || /^\s*$/ || /\s/){delete$ppp->{$package};next}}$checked_in{$package}=$ppp->{$package}}return (wantarray && %errors)? (\%checked_in,\%errors): \%checked_in}sub _perm_check {my ($self,$package)=@_;my$userid=$self->{USERID};my$module=$self->{PERMISSIONS}->module_permissions($package);return 1 if!$module;return 1 if defined$module->m && $module->m eq $userid;return 1 if defined$module->f && $module->f eq $userid;return 1 if defined$module->c && grep {$_ eq $userid}@{$module->c};return}sub _parse_version {my$self=shift;use strict;my$pmfile=$self->{PMFILE};my$tmpfile=File::Spec->catfile(File::Spec->tmpdir,"ParsePMFile$$" .rand(1000));my$pmcp=$pmfile;for ($pmcp){s/([^\\](\\\\)*)@/$1\\@/g}my($v);{package main;my$pid;if ($self->{FORK}|| $FORK){$pid=fork();die "Can't fork: $!" unless defined$pid}if ($pid){waitpid($pid,0);if (open my$fh,'<',$tmpfile){$v=<$fh>}}else {my($comp)=Safe->new;my$eval=qq{
|
|
388
|
+ local(\$^W) = 0;
|
|
389
|
+ Parse::PMFile::_parse_version_safely("$pmcp");
|
|
390
|
+ };$comp->permit("entereval");$comp->share("*Parse::PMFile::_parse_version_safely");$comp->share("*version::new");$comp->share("*version::numify");$comp->share_from('main',['*version::','*charstar::','*Exporter::','*DynaLoader::']);$comp->share_from('version',['&qv']);$comp->permit(":base_math");$comp->deny(qw/enteriter iter unstack goto/);version->import('qv')if$self->{UNSAFE}|| $UNSAFE;{no strict;$v=($self->{UNSAFE}|| $UNSAFE)? eval$eval : $comp->reval($eval)}if ($@){my$err=$@;if (ref$err){if ($err->{line}=~ /([\$*])([\w\:\']*)\bVERSION\b.*?\=(.*)/){local($^W)=0;my ($sigil,$vstr)=($1,$3);$self->_restore_overloaded_stuff(1)if$err->{line}=~ /use\s+version\b|version\->|qv\(/;$v=($self->{UNSAFE}|| $UNSAFE)? eval$vstr : $comp->reval($vstr);$v=$$v if$sigil eq '*' && ref$v}if ($@ or!$v){$self->_verbose(1,sprintf("reval failed: err[%s] for eval[%s]",JSON::PP::encode_json($err),$eval,));$v=JSON::PP::encode_json($err)}}else {$v=JSON::PP::encode_json({openerr=>$err })}}if (defined$v){$v=$v->numify if ref($v)=~ /^version(::vpp)?$/}else {$v=""}if ($self->{FORK}|| $FORK){open my$fh,'>:utf8',$tmpfile;print$fh $v;exit 0}else {utf8::encode($v);$v=undef if defined$v &&!length$v;$comp->erase;$self->_restore_overloaded_stuff}}}unlink$tmpfile if ($self->{FORK}|| $FORK)&& -e $tmpfile;return$self->_normalize_version($v)}sub _restore_overloaded_stuff {my ($self,$used_version_in_safe)=@_;return if$self->{UNSAFE}|| $UNSAFE;no strict 'refs';no warnings 'redefine';my$restored;if ($INC{'version/vxs.pm'}){*{'version::(""'}=\&version::vxs::stringify;*{'version::(0+'}=\&version::vxs::numify;*{'version::(cmp'}=\&version::vxs::VCMP;*{'version::(<=>'}=\&version::vxs::VCMP;*{'version::(bool'}=\&version::vxs::boolean;$restored=1}if ($INC{'version/vpp.pm'}){{package charstar;overload->import}if (!$used_version_in_safe){package version::vpp;overload->import}unless ($restored){*{'version::(""'}=\&version::vpp::stringify;*{'version::(0+'}=\&version::vpp::numify;*{'version::(cmp'}=\&version::vpp::vcmp;*{'version::(<=>'}=\&version::vpp::vcmp;*{'version::(bool'}=\&version::vpp::vbool}*{'version::vpp::(""'}=\&version::vpp::stringify;*{'version::vpp::(0+'}=\&version::vpp::numify;*{'version::vpp::(cmp'}=\&version::vpp::vcmp;*{'version::vpp::(<=>'}=\&version::vpp::vcmp;*{'version::vpp::(bool'}=\&version::vpp::vbool;*{'charstar::(""'}=\&charstar::thischar;*{'charstar::(0+'}=\&charstar::thischar;*{'charstar::(++'}=\&charstar::increment;*{'charstar::(--'}=\&charstar::decrement;*{'charstar::(+'}=\&charstar::plus;*{'charstar::(-'}=\&charstar::minus;*{'charstar::(*'}=\&charstar::multiply;*{'charstar::(cmp'}=\&charstar::cmp;*{'charstar::(<=>'}=\&charstar::spaceship;*{'charstar::(bool'}=\&charstar::thischar;*{'charstar::(='}=\&charstar::clone;$restored=1}if (!$restored){*{'version::(""'}=\&version::stringify;*{'version::(0+'}=\&version::numify;*{'version::(cmp'}=\&version::vcmp;*{'version::(<=>'}=\&version::vcmp;*{'version::(bool'}=\&version::boolean}}sub _packages_per_pmfile {my$self=shift;my$ppp={};my$pmfile=$self->{PMFILE};my$filemtime=$self->{MTIME};my$version=$self->{VERSION};open my$fh,"<","$pmfile" or return$ppp;local $/="\n";my$inpod=0;PLINE: while (<$fh>){chomp;my($pline)=$_;$inpod=$pline =~ /^=(?!cut)/ ? 1 : $pline =~ /^=cut/ ? 0 : $inpod;next if$inpod;next if substr($pline,0,4)eq "=cut";$pline =~ s/\#.*//;next if$pline =~ /^\s*$/;if ($pline =~ /^__(?:END|DATA)__\b/ and $pmfile !~ /\.PL$/){last PLINE}my$pkg;my$strict_version;if ($pline =~ m{
|
|
391
|
+ # (.*) # takes too much time if $pline is long
|
|
392
|
+ (?<![*\$\\@%&]) # no sigils
|
|
393
|
+ \bpackage\s+
|
|
394
|
+ ([\w\:\']+)
|
|
395
|
+ \s*
|
|
396
|
+ (?: $ | [\}\;] | \{ | \s+($version::STRICT) )
|
|
397
|
+ }x){$pkg=$1;$strict_version=$2;if ($pkg eq "DB"){next PLINE}}if ($pkg){$pkg =~ s/\'/::/;next PLINE unless$pkg =~ /^[A-Za-z]/;next PLINE unless$pkg =~ /\w$/;next PLINE if$pkg eq "main";next PLINE if length($pkg)> 128;$ppp->{$pkg}{parsed}++;$ppp->{$pkg}{infile}=$pmfile;if ($self->_simile($pmfile,$pkg)){$ppp->{$pkg}{simile}=$pmfile;if ($self->_version_from_meta_ok){my$provides=$self->{META_CONTENT}{provides};if (exists$provides->{$pkg}){if (defined$provides->{$pkg}{version}){my$v=$provides->{$pkg}{version};if ($v =~ /[_\s]/ &&!$self->{ALLOW_DEV_VERSION}&&!$ALLOW_DEV_VERSION){next PLINE}unless (eval {$version=$self->_normalize_version($v);1}){$self->_verbose(1,"error with version in $pmfile: $@");next}$ppp->{$pkg}{version}=$version}else {$ppp->{$pkg}{version}="undef"}}}else {if (defined$strict_version){$ppp->{$pkg}{version}=$strict_version }else {$ppp->{$pkg}{version}=defined$version ? $version : ""}no warnings;if ($version eq 'undef'){$ppp->{$pkg}{version}=$version unless defined$ppp->{$pkg}{version}}else {$ppp->{$pkg}{version}=$version if$version > $ppp->{$pkg}{version}|| $version gt $ppp->{$pkg}{version}}}}else {$ppp->{$pkg}{version}=$version unless defined$ppp->{$pkg}{version}&& length($ppp->{$pkg}{version})}$ppp->{$pkg}{filemtime}=$filemtime}else {}}close$fh;$ppp}{no strict;sub _parse_version_safely {my($parsefile)=@_;my$result;local*FH;local $/="\n";open(FH,$parsefile)or die "Could not open '$parsefile': $!";my$inpod=0;while (<FH>){$inpod=/^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod;next if$inpod || /^\s*#/;last if /^__(?:END|DATA)__\b/;chop;if (my ($ver)=/package \s+ \S+ \s+ (\S+) \s* [;{]/x){return$ver if version::is_lax($ver)}next unless /(?<!\\)([\$*])(([\w\:\']*)\bVERSION)\b.*(?<![!><=])\=(?![=>])/;my$current_parsed_line=$_;my$eval=qq{
|
|
398
|
+ package #
|
|
399
|
+ ExtUtils::MakeMaker::_version;
|
|
400
|
+
|
|
401
|
+ local $1$2;
|
|
402
|
+ \$$2=undef; do {
|
|
403
|
+ $_
|
|
404
|
+ }; \$$2
|
|
405
|
+ };local $^W=0;local$SIG{__WARN__}=sub {};$result=__clean_eval($eval);if ($@ or!defined$result){die +{eval=>$eval,line=>$current_parsed_line,file=>$parsefile,err=>$@,}}last}close FH;$result="undef" unless defined$result;if ((ref$result)=~ /^version(?:::vpp)?\b/){$result=$result->numify}return$result}}sub _filter_ppps {my($self,@ppps)=@_;my@res;MANI: for my$ppp (@ppps){if ($self->{META_CONTENT}){my$no_index=$self->{META_CONTENT}{no_index}|| $self->{META_CONTENT}{private};if (ref($no_index)eq 'HASH'){my%map=(package=>qr{\z},namespace=>qr{::},);for my$k (qw(package namespace)){next unless my$v=$no_index->{$k};my$rest=$map{$k};if (ref$v eq "ARRAY"){for my$ve (@$v){$ve =~ s|::$||;if ($ppp =~ /^$ve$rest/){$self->_verbose(1,"Skipping ppp[$ppp] due to ve[$ve]");next MANI}else {$self->_verbose(1,"NOT skipping ppp[$ppp] due to ve[$ve]")}}}else {$v =~ s|::$||;if ($ppp =~ /^$v$rest/){$self->_verbose(1,"Skipping ppp[$ppp] due to v[$v]");next MANI}else {$self->_verbose(1,"NOT skipping ppp[$ppp] due to v[$v]")}}}}else {$self->_verbose(1,"No keyword 'no_index' or 'private' in META_CONTENT")}}else {}push@res,$ppp}$self->_verbose(1,"Result of filter_ppps: res[@res]");@res}sub _simile {my($self,$file,$package)=@_;$file =~ s|.*/||;$file =~ s|\.pm(?:\.PL)?||;my$ret=$package =~ m/\b\Q$file\E$/;$ret ||= 0;unless ($ret){$ret=1 if lc$file eq 'version'}$self->_verbose(1,"Result of simile(): file[$file] package[$package] ret[$ret]\n");$ret}sub _normalize_version {my($self,$v)=@_;$v="undef" unless defined$v;my$dv=Dumpvalue->new;my$sdv=$dv->stringify($v,1);$self->_verbose(1,"Result of normalize_version: sdv[$sdv]\n");return$v if$v eq "undef";return$v if$v =~ /^\{.*\}$/;$v =~ s/^\s+//;$v =~ s/\s+\z//;if ($v =~ /_/){return$v }if (!version::is_lax($v)){return JSON::PP::encode_json({x_normalize=>'version::is_lax failed',version=>$v })}my$vv=eval {no warnings;version->new($v)->numify};if ($@){return JSON::PP::encode_json({x_normalize=>$@,version=>$v })}if ($vv eq $v){}else {my$forced=$self->_force_numeric($v);if ($forced eq $vv){}elsif ($forced =~ /^v(.+)/){$vv=version->new($1)->numify}else {if ($forced==$vv){$vv=$forced}}}return$vv}sub _force_numeric {my($self,$v)=@_;$v=$self->_readable($v);if ($v =~ /^(\+?)(\d*)(\.(\d*))?/ && (defined $2 && length $2 || defined $4 && length $4)){my$two=defined $2 ? $2 : "";my$three=defined $3 ? $3 : "";$v="$two$three"}$v}sub _version_from_meta_ok {my($self)=@_;return$self->{VERSION_FROM_META_OK}if exists$self->{VERSION_FROM_META_OK};my$c=$self->{META_CONTENT};return($self->{VERSION_FROM_META_OK}=0)unless$c->{provides};my ($mb_v)=(defined$c->{generated_by}? $c->{generated_by}: '')=~ /Module::Build version ([\d\.]+)/;return($self->{VERSION_FROM_META_OK}=1)unless$mb_v;return($self->{VERSION_FROM_META_OK}=1)if$mb_v eq '0.250.0';if ($mb_v >= 0.19 && $mb_v < 0.26 &&!keys %{$c->{provides}}){return($self->{VERSION_FROM_META_OK}=0)}return($self->{VERSION_FROM_META_OK}=1)}sub _verbose {my($self,$level,@what)=@_;warn@what if$level <= ((ref$self && $self->{VERBOSE})|| $VERBOSE)}sub _vcmp {my($self,$l,$r)=@_;local($^W)=0;$self->_verbose(9,"l[$l] r[$r]");return 0 if$l eq $r;for ($l,$r){s/_//g}$self->_verbose(9,"l[$l] r[$r]");for ($l,$r){next unless tr/.// > 1 || /^v/;s/^v?/v/;1 while s/\.0+(\d)/.$1/}$self->_verbose(9,"l[$l] r[$r]");if ($l=~/^v/ <=> $r=~/^v/){for ($l,$r){next if /^v/;$_=$self->_float2vv($_)}}$self->_verbose(9,"l[$l] r[$r]");my$lvstring="v0";my$rvstring="v0";if ($] >= 5.006 && $l =~ /^v/ && $r =~ /^v/){$lvstring=$self->_vstring($l);$rvstring=$self->_vstring($r);$self->_verbose(9,sprintf "lv[%vd] rv[%vd]",$lvstring,$rvstring)}return (($l ne "undef")<=> ($r ne "undef")|| $lvstring cmp $rvstring || $l <=> $r || $l cmp $r)}sub _vgt {my($self,$l,$r)=@_;$self->_vcmp($l,$r)> 0}sub _vlt {my($self,$l,$r)=@_;$self->_vcmp($l,$r)< 0}sub _vge {my($self,$l,$r)=@_;$self->_vcmp($l,$r)>= 0}sub _vle {my($self,$l,$r)=@_;$self->_vcmp($l,$r)<= 0}sub _vstring {my($self,$n)=@_;$n =~ s/^v// or die "Parse::PMFile::_vstring() called with invalid arg [$n]";pack "U*",split /\./,$n}sub _float2vv {my($self,$n)=@_;my($rev)=int($n);$rev ||= 0;my($mantissa)=$n =~ /\.(\d{1,12})/;$mantissa ||= 0;$mantissa .= "0" while length($mantissa)%3;my$ret="v" .$rev;while ($mantissa){$mantissa =~ s/(\d{1,3})// or die "Panic: length>0 but not a digit? mantissa[$mantissa]";$ret .= ".".int($1)}$ret =~ s/(\.0)+/.0/;$ret}sub _readable {my($self,$n)=@_;$n =~ /^([\w\-\+\.]+)/;return $1 if defined $1 && length($1)>0;if ($] < 5.006){$self->_verbose(9,"Suspicious version string seen [$n]\n");return$n}my$better=sprintf "v%vd",$n;$self->_verbose(9,"n[$n] better[$better]");return$better}1;
|
|
406
|
+PARSE_PMFILE
|
|
407
|
+
|
|
408
|
+$fatpacked{"String/ShellQuote.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'STRING_SHELLQUOTE';
|
|
409
|
+ package String::ShellQuote;use strict;use vars qw($VERSION @ISA @EXPORT);require Exporter;$VERSION='1.04';@ISA=qw(Exporter);@EXPORT=qw(shell_quote shell_quote_best_effort shell_comment_quote);sub croak {require Carp;goto&Carp::croak}sub _shell_quote_backend {my@in=@_;my@err=();if (0){require RS::Handy;print RS::Handy::data_dump(\@in)}return \@err,'' unless@in;my$ret='';my$saw_non_equal=0;for (@in){if (!defined $_ or $_ eq ''){$_="''";next}if (s/\x00//g){push@err,"No way to quote string containing null (\\000) bytes"}my$escape=0;if (/=/){if (!$saw_non_equal){$escape=1}}else {$saw_non_equal=1}if (m|[^\w!%+,\-./:=@^]|){$escape=1}if ($escape || (!$saw_non_equal && /=/)){s/'/'\\''/g;s|((?:'\\''){2,})|q{'"} . (q{'} x (length($1) / 4)) . q{"'}|ge;$_="'$_'";s/^''//;s/''$//}}continue {$ret .= "$_ "}chop$ret;return \@err,$ret}sub shell_quote {my ($rerr,$s)=_shell_quote_backend @_;if (@$rerr){my%seen;@$rerr=grep {!$seen{$_}++}@$rerr;my$s=join '',map {"shell_quote(): $_\n"}@$rerr;chomp$s;croak$s}return$s}sub shell_quote_best_effort {my ($rerr,$s)=_shell_quote_backend @_;return$s}sub shell_comment_quote {return '' unless @_;unless (@_==1){croak "Too many arguments to shell_comment_quote " ."(got " .@_ ." expected 1)"}local $_=shift;s/\n/\n#/g;return $_}1;
|
|
410
|
+STRING_SHELLQUOTE
|
|
411
|
+
|
|
412
|
+$fatpacked{"lib/core/only.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LIB_CORE_ONLY';
|
|
413
|
+ package lib::core::only;use strict;use warnings FATAL=>'all';use Config;sub import {@INC=@Config{qw(privlibexp archlibexp)};return}1;
|
|
414
|
+LIB_CORE_ONLY
|
|
415
|
+
|
|
416
|
+$fatpacked{"local/lib.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOCAL_LIB';
|
|
417
|
+ package local::lib;use 5.006;use strict;use warnings;use Config;our$VERSION='2.000015';$VERSION=eval$VERSION;BEGIN {*_WIN32=($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'symbian')? sub(){1}: sub(){0};*_USE_FSPEC=($^O eq 'MacOS' || $^O eq 'VMS' || $INC{'File/Spec.pm'})? sub(){1}: sub(){0}}our$_DIR_JOIN=_WIN32 ? '\\' : '/';our$_DIR_SPLIT=(_WIN32 || $^O eq 'cygwin')? qr{[\\/]} : qr{/};our$_ROOT=_WIN32 ? do {my$UNC=qr{[\\/]{2}[^\\/]+[\\/][^\\/]+};qr{^(?:$UNC|[A-Za-z]:|)$_DIR_SPLIT}}: qr{^/};our$_PERL;sub _cwd {my$drive=shift;if (!$_PERL){($_PERL)=$^X =~ /(.+)/;if (_is_abs($_PERL)){}elsif (-x $Config{perlpath}){$_PERL=$Config{perlpath}}else {($_PERL)=map {/(.*)/}grep {-x $_}map {join($_DIR_JOIN,$_,$_PERL)}split /\Q$Config{path_sep}\E/,$ENV{PATH}}}local@ENV{qw(PATH IFS CDPATH ENV BASH_ENV)};my$cmd=$drive ? "eval { Cwd::getdcwd(q($drive)) }" : 'getcwd';my$cwd=`"$_PERL" -MCwd -le "print $cmd"`;chomp$cwd;if (!length$cwd && $drive){$cwd=$drive}$cwd =~ s/$_DIR_SPLIT?$/$_DIR_JOIN/;$cwd}sub _catdir {if (_USE_FSPEC){require File::Spec;File::Spec->catdir(@_)}else {my$dir=join($_DIR_JOIN,@_);$dir =~ s{($_DIR_SPLIT)(?:\.?$_DIR_SPLIT)+}{$1}g;$dir}}sub _is_abs {if (_USE_FSPEC){require File::Spec;File::Spec->file_name_is_absolute($_[0])}else {$_[0]=~ $_ROOT}}sub _rel2abs {my ($dir,$base)=@_;return$dir if _is_abs($dir);$base=_WIN32 && $dir =~ s/^([A-Za-z]:)// ? _cwd("$1"): $base ? $base : _cwd;return _catdir($base,$dir)}sub import {my ($class,@args)=@_;push@args,@ARGV if $0 eq '-';my@steps;my%opts;my$shelltype;while (@args){my$arg=shift@args;if ($arg =~ /\xE2\x88\x92/ or $arg =~ /−/){die <<'DEATH'}elsif ($arg eq '--self-contained'){die <<'DEATH'}elsif($arg =~ /^--deactivate(?:=(.*))?$/){my$path=defined $1 ? $1 : shift@args;push@steps,['deactivate',$path]}elsif ($arg eq '--deactivate-all'){push@steps,['deactivate_all']}elsif ($arg =~ /^--shelltype(?:=(.*))?$/){$shelltype=defined $1 ? $1 : shift@args}elsif ($arg eq '--no-create'){$opts{no_create}=1}elsif ($arg =~ /^--/){die "Unknown import argument: $arg"}else {push@steps,['activate',$arg]}}if (!@steps){push@steps,['activate',undef]}my$self=$class->new(%opts);for (@steps){my ($method,@args)=@$_;$self=$self->$method(@args)}if ($0 eq '-'){print$self->environment_vars_string($shelltype);exit 0}else {$self->setup_local_lib}}sub new {my$class=shift;bless {@_},$class}sub clone {my$self=shift;bless {%$self,@_},ref$self}sub inc {$_[0]->{inc}||= \@INC}sub libs {$_[0]->{libs}||= [\'PERL5LIB' ]}sub bins {$_[0]->{bins}||= [\'PATH' ]}sub roots {$_[0]->{roots}||= [\'PERL_LOCAL_LIB_ROOT' ]}sub extra {$_[0]->{extra}||= {}}sub no_create {$_[0]->{no_create}}my$_archname=$Config{archname};my$_version=$Config{version};my@_inc_version_list=reverse split / /,$Config{inc_version_list};my$_path_sep=$Config{path_sep};sub _as_list {my$list=shift;grep length,map {!(ref $_ && ref $_ eq 'SCALAR')? $_ : (defined$ENV{$$_}? split(/\Q$_path_sep/,$ENV{$$_}): ())}ref$list ? @$list : $list}sub _remove_from {my ($list,@remove)=@_;return @$list if!@remove;my%remove=map {$_=>1}@remove;grep!$remove{$_},_as_list($list)}my@_lib_subdirs=([$_version,$_archname],[$_version],[$_archname],(@_inc_version_list ? \@_inc_version_list : ()),[],);sub install_base_bin_path {my ($class,$path)=@_;return _catdir($path,'bin')}sub install_base_perl_path {my ($class,$path)=@_;return _catdir($path,'lib','perl5')}sub install_base_arch_path {my ($class,$path)=@_;_catdir($class->install_base_perl_path($path),$_archname)}sub lib_paths_for {my ($class,$path)=@_;my$base=$class->install_base_perl_path($path);return map {_catdir($base,@$_)}@_lib_subdirs}sub _mm_escape_path {my$path=shift;$path =~ s/\\/\\\\/g;if ($path =~ s/ /\\ /g){$path=qq{"$path"}}return$path}sub _mb_escape_path {my$path=shift;$path =~ s/\\/\\\\/g;return qq{"$path"}}sub installer_options_for {my ($class,$path)=@_;return (PERL_MM_OPT=>defined$path ? "INSTALL_BASE="._mm_escape_path($path): undef,PERL_MB_OPT=>defined$path ? "--install_base "._mb_escape_path($path): undef,)}sub active_paths {my ($self)=@_;$self=ref$self ? $self : $self->new;return grep {my$active_ll=$self->install_base_perl_path($_);grep {$_ eq $active_ll}@{$self->inc}}_as_list($self->roots)}sub deactivate {my ($self,$path)=@_;$self=$self->new unless ref$self;$path=$self->resolve_path($path);$path=$self->normalize_path($path);my@active_lls=$self->active_paths;if (!grep {$_ eq $path}@active_lls){warn "Tried to deactivate inactive local::lib '$path'\n";return$self}my%args=(bins=>[_remove_from($self->bins,$self->install_base_bin_path($path))],libs=>[_remove_from($self->libs,$self->install_base_perl_path($path))],inc=>[_remove_from($self->inc,$self->lib_paths_for($path))],roots=>[_remove_from($self->roots,$path)],);$args{extra}={$self->installer_options_for($args{roots}[0])};$self->clone(%args)}sub deactivate_all {my ($self)=@_;$self=$self->new unless ref$self;my@active_lls=$self->active_paths;my%args;if (@active_lls){%args=(bins=>[_remove_from($self->bins,map$self->install_base_bin_path($_),@active_lls)],libs=>[_remove_from($self->libs,map$self->install_base_perl_path($_),@active_lls)],inc=>[_remove_from($self->inc,map$self->lib_paths_for($_),@active_lls)],roots=>[_remove_from($self->roots,@active_lls)],)}$args{extra}={$self->installer_options_for(undef)};$self->clone(%args)}sub activate {my ($self,$path)=@_;$self=$self->new unless ref$self;$path=$self->resolve_path($path);$self->ensure_dir_structure_for($path)unless$self->no_create;$path=$self->normalize_path($path);my@active_lls=$self->active_paths;if (grep {$_ eq $path}@active_lls[1 .. $#active_lls]){$self=$self->deactivate($path)}my%args;if (!@active_lls || $active_lls[0]ne $path){%args=(bins=>[$self->install_base_bin_path($path),@{$self->bins}],libs=>[$self->install_base_perl_path($path),@{$self->libs}],inc=>[$self->lib_paths_for($path),@{$self->inc}],roots=>[$path,@{$self->roots}],)}$args{extra}={$self->installer_options_for($path)};$self->clone(%args)}sub normalize_path {my ($self,$path)=@_;$path=(Win32::GetShortPathName($path)|| $path)if $^O eq 'MSWin32';return$path}sub build_environment_vars_for {my$self=$_[0]->new->activate($_[1]);$self->build_environment_vars}sub build_activate_environment_vars_for {my$self=$_[0]->new->activate($_[1]);$self->build_environment_vars}sub build_deactivate_environment_vars_for {my$self=$_[0]->new->deactivate($_[1]);$self->build_environment_vars}sub build_deact_all_environment_vars_for {my$self=$_[0]->new->deactivate_all;$self->build_environment_vars}sub build_environment_vars {my$self=shift;(PATH=>join($_path_sep,_as_list($self->bins)),PERL5LIB=>join($_path_sep,_as_list($self->libs)),PERL_LOCAL_LIB_ROOT=>join($_path_sep,_as_list($self->roots)),%{$self->extra},)}sub setup_local_lib_for {my$self=$_[0]->new->activate($_[1]);$self->setup_local_lib}sub setup_local_lib {my$self=shift;require Carp::Heavy if$INC{'Carp.pm'};$self->setup_env_hash;@INC=@{$self->inc}}sub setup_env_hash_for {my$self=$_[0]->new->activate($_[1]);$self->setup_env_hash}sub setup_env_hash {my$self=shift;my%env=$self->build_environment_vars;for my$key (keys%env){if (defined$env{$key}){$ENV{$key}=$env{$key}}else {delete$ENV{$key}}}}sub print_environment_vars_for {print $_[0]->environment_vars_string_for(@_[1..$#_])}sub environment_vars_string_for {my$self=$_[0]->new->activate($_[1]);$self->environment_vars_string}sub environment_vars_string {my ($self,$shelltype)=@_;$shelltype ||= $self->guess_shelltype;my$extra=$self->extra;my@envs=(PATH=>$self->bins,PERL5LIB=>$self->libs,PERL_LOCAL_LIB_ROOT=>$self->roots,map {$_=>$extra->{$_}}sort keys %$extra,);$self->_build_env_string($shelltype,\@envs)}sub _build_env_string {my ($self,$shelltype,$envs)=@_;my@envs=@$envs;my$build_method="build_${shelltype}_env_declaration";my$out='';while (@envs){my ($name,$value)=(shift(@envs),shift(@envs));if (ref$value && @$value==1 && ref$value->[0]&& ref$value->[0]eq 'SCALAR' && ${$value->[0]}eq $name){next}$out .= $self->$build_method($name,$value)}my$wrap_method="wrap_${shelltype}_output";if ($self->can($wrap_method)){return$self->$wrap_method($out)}return$out}sub build_bourne_env_declaration {my ($class,$name,$args)=@_;my$value=$class->_interpolate($args,'${%s}',qr/["\\\$!`]/,'\\%s');if (!defined$value){return qq{unset $name;\n}}$value =~ s/(^|\G|$_path_sep)\$\{$name\}$_path_sep/$1\${$name}\${$name+$_path_sep}/g;$value =~ s/$_path_sep\$\{$name\}$/\${$name+$_path_sep}\${$name}/;qq{${name}="$value"; export ${name};\n}}sub build_csh_env_declaration {my ($class,$name,$args)=@_;my ($value,@vars)=$class->_interpolate($args,'${%s}','"','"\\%s"');if (!defined$value){return qq{unsetenv $name;\n}}my$out='';for my$var (@vars){$out .= qq{if ! \$?$name setenv $name '';\n}}my$value_without=$value;if ($value_without =~ s/(?:^|$_path_sep)\$\{$name\}(?:$_path_sep|$)//g){$out .= qq{if "\${$name}" != '' setenv $name "$value";\n};$out .= qq{if "\${$name}" == '' }}$out .= qq{setenv $name "$value_without";\n};return$out}sub build_cmd_env_declaration {my ($class,$name,$args)=@_;my$value=$class->_interpolate($args,'%%%s%%',qr(%),'%s');if (!$value){return qq{\@set $name=\n}}my$out='';my$value_without=$value;if ($value_without =~ s/(?:^|$_path_sep)%$name%(?:$_path_sep|$)//g){$out .= qq{\@if not "%$name%"=="" set "$name=$value"\n};$out .= qq{\@if "%$name%"=="" }}$out .= qq{\@set "$name=$value_without"\n};return$out}sub build_powershell_env_declaration {my ($class,$name,$args)=@_;my$value=$class->_interpolate($args,'$env:%s','"','`%s');if (!$value){return qq{Remove-Item -ErrorAction 0 Env:\\$name;\n}}my$maybe_path_sep=qq{\$(if("\$env:$name"-eq""){""}else{"$_path_sep"})};$value =~ s/(^|\G|$_path_sep)\$env:$name$_path_sep/$1\$env:$name"+$maybe_path_sep+"/g;$value =~ s/$_path_sep\$env:$name$/"+$maybe_path_sep+\$env:$name+"/;qq{\$env:$name = \$("$value");\n}}sub wrap_powershell_output {my ($class,$out)=@_;return$out || " \n"}sub build_fish_env_declaration {my ($class,$name,$args)=@_;my$value=$class->_interpolate($args,'$%s',qr/[\\"' ]/,'\\%s');if (!defined$value){return qq{set -e $name;\n}}$value =~ s/$_path_sep/ /g;qq{set -x $name $value;\n}}sub _interpolate {my ($class,$args,$var_pat,$escape,$escape_pat)=@_;return unless defined$args;my@args=ref$args ? @$args : $args;return unless@args;my@vars=map {$$_}grep {ref $_ eq 'SCALAR'}@args;my$string=join$_path_sep,map {ref $_ eq 'SCALAR' ? sprintf($var_pat,$$_): do {s/($escape)/sprintf($escape_pat, $1)/ge;$_}}@args;return wantarray ? ($string,\@vars): $string}sub pipeline;sub pipeline {my@methods=@_;my$last=pop(@methods);if (@methods){\sub {my ($obj,@args)=@_;$obj->${pipeline@methods}($obj->$last(@args))}}else {\sub {shift->$last(@_)}}}sub resolve_path {my ($class,$path)=@_;$path=$class->${pipeline qw(resolve_relative_path resolve_home_path resolve_empty_path)}($path);$path}sub resolve_empty_path {my ($class,$path)=@_;if (defined$path){$path}else {'~/perl5'}}sub resolve_home_path {my ($class,$path)=@_;$path =~ /^~([^\/]*)/ or return$path;my$user=$1;my$homedir=do {if (!length($user)&& defined$ENV{HOME}){$ENV{HOME}}else {require File::Glob;File::Glob::bsd_glob("~$user",File::Glob::GLOB_TILDE())}};unless (defined$homedir){require Carp;require Carp::Heavy;Carp::croak("Couldn't resolve homedir for " .(defined$user ? $user : 'current user'))}$path =~ s/^~[^\/]*/$homedir/;$path}sub resolve_relative_path {my ($class,$path)=@_;_rel2abs($path)}sub ensure_dir_structure_for {my ($class,$path)=@_;unless (-d $path){warn "Attempting to create directory ${path}\n"}require File::Basename;my@dirs;while(!-d $path){push@dirs,$path;$path=File::Basename::dirname($path)}mkdir $_ for reverse@dirs;return}sub guess_shelltype {my$shellbin =defined$ENV{SHELL}? ($ENV{SHELL}=~ /([\w.]+)$/)[-1]: ($^O eq 'MSWin32' && exists$ENV{'!EXITCODE'})? 'bash' : ($^O eq 'MSWin32' && $ENV{PROMPT}&& $ENV{COMSPEC})? ($ENV{COMSPEC}=~ /([\w.]+)$/)[-1]: ($^O eq 'MSWin32' &&!$ENV{PROMPT})? 'powershell.exe' : 'sh';for ($shellbin){return /csh$/ ? 'csh' : /fish/ ? 'fish' : /command(?:\.com)?$/i ? 'cmd' : /cmd(?:\.exe)?$/i ? 'cmd' : /4nt(?:\.exe)?$/i ? 'cmd' : /powershell(?:\.exe)?$/i ? 'powershell' : 'bourne'}}1;
|
|
418
|
+ WHOA THERE! It looks like you've got some fancy dashes in your commandline!
|
|
419
|
+ These are *not* the traditional -- dashes that software recognizes. You
|
|
420
|
+ probably got these by copy-pasting from the perldoc for this module as
|
|
421
|
+ rendered by a UTF8-capable formatter. This most typically happens on an OS X
|
|
422
|
+ terminal, but can happen elsewhere too. Please try again after replacing the
|
|
423
|
+ dashes with normal minus signs.
|
|
424
|
+ DEATH
|
|
425
|
+ FATAL: The local::lib --self-contained flag has never worked reliably and the
|
|
426
|
+ original author, Mark Stosberg, was unable or unwilling to maintain it. As
|
|
427
|
+ such, this flag has been removed from the local::lib codebase in order to
|
|
428
|
+ prevent misunderstandings and potentially broken builds. The local::lib authors
|
|
429
|
+ recommend that you look at the lib::core::only module shipped with this
|
|
430
|
+ distribution in order to create a more robust environment that is equivalent to
|
|
431
|
+ what --self-contained provided (although quite possibly not what you originally
|
|
432
|
+ thought it provided due to the poor quality of the documentation, for which we
|
|
433
|
+ apologise).
|
|
434
|
+ DEATH
|
|
435
|
+LOCAL_LIB
|
|
436
|
+
|
|
437
|
+$fatpacked{"parent.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PARENT';
|
|
438
|
+ package parent;use strict;use vars qw($VERSION);$VERSION='0.228';sub import {my$class=shift;my$inheritor=caller(0);if (@_ and $_[0]eq '-norequire'){shift @_}else {for (my@filename=@_){if ($_ eq $inheritor){warn "Class '$inheritor' tried to inherit from itself\n"};s{::|'}{/}g;require "$_.pm"}}{no strict 'refs';push @{"$inheritor\::ISA"},@_}};"All your base are belong to us"
|
|
439
|
+PARENT
|
|
440
|
+
|
|
441
|
+$fatpacked{"version.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'VERSION';
|
|
442
|
+ package version;use 5.006002;use strict;use warnings::register;if ($] >= 5.015){warnings::register_categories(qw/version/)}use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv);$VERSION=0.9912;$CLASS='version';{local$SIG{'__DIE__'};if (1){eval "use version::vpp $VERSION";die "$@" if ($@);push@ISA,"version::vpp";local $^W;*version::qv=\&version::vpp::qv;*version::declare=\&version::vpp::declare;*version::_VERSION=\&version::vpp::_VERSION;*version::vcmp=\&version::vpp::vcmp;*version::new=\&version::vpp::new;*version::numify=\&version::vpp::numify;*version::normal=\&version::vpp::normal;if ($] >= 5.009000){no strict 'refs';*version::stringify=\&version::vpp::stringify;*{'version::(""'}=\&version::vpp::stringify;*{'version::(<=>'}=\&version::vpp::vcmp;*version::parse=\&version::vpp::parse}}else {push@ISA,"version::vxs";local $^W;*version::declare=\&version::vxs::declare;*version::qv=\&version::vxs::qv;*version::_VERSION=\&version::vxs::_VERSION;*version::vcmp=\&version::vxs::VCMP;*version::new=\&version::vxs::new;*version::numify=\&version::vxs::numify;*version::normal=\&version::vxs::normal;if ($] >= 5.009000){no strict 'refs';*version::stringify=\&version::vxs::stringify;*{'version::(""'}=\&version::vxs::stringify;*{'version::(<=>'}=\&version::vxs::VCMP;*version::parse=\&version::vxs::parse}}}require version::regex;*version::is_lax=\&version::regex::is_lax;*version::is_strict=\&version::regex::is_strict;*LAX=\$version::regex::LAX;*STRICT=\$version::regex::STRICT;sub import {no strict 'refs';my ($class)=shift;unless ($class eq $CLASS){local $^W;*{$class.'::declare'}=\&{$CLASS.'::declare'};*{$class.'::qv'}=\&{$CLASS.'::qv'}}my%args;if (@_){map {$args{$_}=1}@_}else {%args=(qv=>1,'UNIVERSAL::VERSION'=>1,)}my$callpkg=caller();if (exists($args{declare})){*{$callpkg.'::declare'}=sub {return$class->declare(shift)}unless defined(&{$callpkg.'::declare'})}if (exists($args{qv})){*{$callpkg.'::qv'}=sub {return$class->qv(shift)}unless defined(&{$callpkg.'::qv'})}if (exists($args{'UNIVERSAL::VERSION'})){local $^W;*UNIVERSAL::VERSION =\&{$CLASS.'::_VERSION'}}if (exists($args{'VERSION'})){*{$callpkg.'::VERSION'}=\&{$CLASS.'::_VERSION'}}if (exists($args{'is_strict'})){*{$callpkg.'::is_strict'}=\&{$CLASS.'::is_strict'}unless defined(&{$callpkg.'::is_strict'})}if (exists($args{'is_lax'})){*{$callpkg.'::is_lax'}=\&{$CLASS.'::is_lax'}unless defined(&{$callpkg.'::is_lax'})}}1;
|
|
443
|
+VERSION
|
|
444
|
+
|
|
445
|
+$fatpacked{"version/regex.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'VERSION_REGEX';
|
|
446
|
+ package version::regex;use strict;use vars qw($VERSION $CLASS $STRICT $LAX);$VERSION=0.9912;my$FRACTION_PART=qr/\.[0-9]+/;my$STRICT_INTEGER_PART=qr/0|[1-9][0-9]*/;my$LAX_INTEGER_PART=qr/[0-9]+/;my$STRICT_DOTTED_DECIMAL_PART=qr/\.[0-9]{1,3}/;my$LAX_DOTTED_DECIMAL_PART=qr/\.[0-9]+/;my$LAX_ALPHA_PART=qr/_[0-9]+/;my$STRICT_DECIMAL_VERSION=qr/ $STRICT_INTEGER_PART $FRACTION_PART? /x;my$STRICT_DOTTED_DECIMAL_VERSION=qr/ v $STRICT_INTEGER_PART $STRICT_DOTTED_DECIMAL_PART{2,} /x;$STRICT=qr/ $STRICT_DECIMAL_VERSION | $STRICT_DOTTED_DECIMAL_VERSION /x;my$LAX_DECIMAL_VERSION=qr/ $LAX_INTEGER_PART (?: \. | $FRACTION_PART $LAX_ALPHA_PART? )?
|
|
447
|
+ |
|
|
448
|
+ $FRACTION_PART $LAX_ALPHA_PART?
|
|
449
|
+ /x;my$LAX_DOTTED_DECIMAL_VERSION=qr/
|
|
450
|
+ v $LAX_INTEGER_PART (?: $LAX_DOTTED_DECIMAL_PART+ $LAX_ALPHA_PART? )?
|
|
451
|
+ |
|
|
452
|
+ $LAX_INTEGER_PART? $LAX_DOTTED_DECIMAL_PART{2,} $LAX_ALPHA_PART?
|
|
453
|
+ /x;$LAX=qr/ undef | $LAX_DECIMAL_VERSION | $LAX_DOTTED_DECIMAL_VERSION /x;sub is_strict {defined $_[0]&& $_[0]=~ qr/ \A $STRICT \z /x}sub is_lax {defined $_[0]&& $_[0]=~ qr/ \A $LAX \z /x}1;
|
|
454
|
+VERSION_REGEX
|
|
455
|
+
|
|
456
|
+$fatpacked{"version/vpp.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'VERSION_VPP';
|
|
457
|
+ package charstar;use overload ('""'=>\&thischar,'0+'=>\&thischar,'++'=>\&increment,'--'=>\&decrement,'+'=>\&plus,'-'=>\&minus,'*'=>\&multiply,'cmp'=>\&cmp,'<=>'=>\&spaceship,'bool'=>\&thischar,'='=>\&clone,);sub new {my ($self,$string)=@_;my$class=ref($self)|| $self;my$obj={string=>[split(//,$string)],current=>0,};return bless$obj,$class}sub thischar {my ($self)=@_;my$last=$#{$self->{string}};my$curr=$self->{current};if ($curr >= 0 && $curr <= $last){return$self->{string}->[$curr]}else {return ''}}sub increment {my ($self)=@_;$self->{current}++}sub decrement {my ($self)=@_;$self->{current}--}sub plus {my ($self,$offset)=@_;my$rself=$self->clone;$rself->{current}+= $offset;return$rself}sub minus {my ($self,$offset)=@_;my$rself=$self->clone;$rself->{current}-= $offset;return$rself}sub multiply {my ($left,$right,$swapped)=@_;my$char=$left->thischar();return$char * $right}sub spaceship {my ($left,$right,$swapped)=@_;unless (ref($right)){$right=$left->new($right)}return$left->{current}<=> $right->{current}}sub cmp {my ($left,$right,$swapped)=@_;unless (ref($right)){if (length($right)==1){return$left->thischar cmp $right}$right=$left->new($right)}return$left->currstr cmp $right->currstr}sub bool {my ($self)=@_;my$char=$self->thischar;return ($char ne '')}sub clone {my ($left,$right,$swapped)=@_;$right={string=>[@{$left->{string}}],current=>$left->{current},};return bless$right,ref($left)}sub currstr {my ($self,$s)=@_;my$curr=$self->{current};my$last=$#{$self->{string}};if (defined($s)&& $s->{current}< $last){$last=$s->{current}}my$string=join('',@{$self->{string}}[$curr..$last]);return$string}package version::vpp;use 5.006002;use strict;use warnings::register;use Config;use vars qw($VERSION $CLASS @ISA $LAX $STRICT $WARN_CATEGORY);$VERSION=0.9912;$CLASS='version::vpp';if ($] > 5.015){warnings::register_categories(qw/version/);$WARN_CATEGORY='version'}else {$WARN_CATEGORY='numeric'}require version::regex;*version::vpp::is_strict=\&version::regex::is_strict;*version::vpp::is_lax=\&version::regex::is_lax;*LAX=\$version::regex::LAX;*STRICT=\$version::regex::STRICT;use overload ('""'=>\&stringify,'0+'=>\&numify,'cmp'=>\&vcmp,'<=>'=>\&vcmp,'bool'=>\&vbool,'+'=>\&vnoop,'-'=>\&vnoop,'*'=>\&vnoop,'/'=>\&vnoop,'+='=>\&vnoop,'-='=>\&vnoop,'*='=>\&vnoop,'/='=>\&vnoop,'abs'=>\&vnoop,);sub import {no strict 'refs';my ($class)=shift;unless ($class eq $CLASS){local $^W;*{$class.'::declare'}=\&{$CLASS.'::declare'};*{$class.'::qv'}=\&{$CLASS.'::qv'}}my%args;if (@_){map {$args{$_}=1}@_}else {%args=(qv=>1,'UNIVERSAL::VERSION'=>1,)}my$callpkg=caller();if (exists($args{declare})){*{$callpkg.'::declare'}=sub {return$class->declare(shift)}unless defined(&{$callpkg.'::declare'})}if (exists($args{qv})){*{$callpkg.'::qv'}=sub {return$class->qv(shift)}unless defined(&{$callpkg.'::qv'})}if (exists($args{'UNIVERSAL::VERSION'})){no warnings qw/redefine/;*UNIVERSAL::VERSION =\&{$CLASS.'::_VERSION'}}if (exists($args{'VERSION'})){*{$callpkg.'::VERSION'}=\&{$CLASS.'::_VERSION'}}if (exists($args{'is_strict'})){*{$callpkg.'::is_strict'}=\&{$CLASS.'::is_strict'}unless defined(&{$callpkg.'::is_strict'})}if (exists($args{'is_lax'})){*{$callpkg.'::is_lax'}=\&{$CLASS.'::is_lax'}unless defined(&{$callpkg.'::is_lax'})}}my$VERSION_MAX=0x7FFFFFFF;use constant TRUE=>1;use constant FALSE=>0;sub isDIGIT {my ($char)=shift->thischar();return ($char =~ /\d/)}sub isALPHA {my ($char)=shift->thischar();return ($char =~ /[a-zA-Z]/)}sub isSPACE {my ($char)=shift->thischar();return ($char =~ /\s/)}sub BADVERSION {my ($s,$errstr,$error)=@_;if ($errstr){$$errstr=$error}return$s}sub prescan_version {my ($s,$strict,$errstr,$sqv,$ssaw_decimal,$swidth,$salpha)=@_;my$qv=defined$sqv ? $$sqv : FALSE;my$saw_decimal=defined$ssaw_decimal ? $$ssaw_decimal : 0;my$width=defined$swidth ? $$swidth : 3;my$alpha=defined$salpha ? $$salpha : FALSE;my$d=$s;if ($qv && isDIGIT($d)){goto dotted_decimal_version}if ($d eq 'v'){$d++;if (isDIGIT($d)){$qv=TRUE}else {return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)")}dotted_decimal_version: if ($strict && $d eq '0' && isDIGIT($d+1)){return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)")}while (isDIGIT($d)){$d++}if ($d eq '.'){$saw_decimal++;$d++}else {if ($strict){return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)")}else {goto version_prescan_finish}}{my$i=0;my$j=0;while (isDIGIT($d)){$i++;while (isDIGIT($d)){$d++;$j++;if ($strict && $j > 3){return BADVERSION($s,$errstr,"Invalid version format (maximum 3 digits between decimals)")}}if ($d eq '_'){if ($strict){return BADVERSION($s,$errstr,"Invalid version format (no underscores)")}if ($alpha){return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)")}$d++;$alpha=TRUE}elsif ($d eq '.'){if ($alpha){return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)")}$saw_decimal++;$d++}elsif (!isDIGIT($d)){last}$j=0}if ($strict && $i < 2){return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)")}}}else {my$j=0;if ($strict){if ($d eq '.'){return BADVERSION($s,$errstr,"Invalid version format (0 before decimal required)")}if ($d eq '0' && isDIGIT($d+1)){return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)")}}if ($d eq '-'){return BADVERSION($s,$errstr,"Invalid version format (negative version number)")}while (isDIGIT($d)){$d++}if ($d eq '.'){$saw_decimal++;$d++}elsif (!$d || $d eq ';' || isSPACE($d)|| $d eq '}'){if ($d==$s){return BADVERSION($s,$errstr,"Invalid version format (version required)")}goto version_prescan_finish}elsif ($d==$s){return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)")}elsif ($d eq '_'){if ($strict){return BADVERSION($s,$errstr,"Invalid version format (no underscores)")}elsif (isDIGIT($d+1)){return BADVERSION($s,$errstr,"Invalid version format (alpha without decimal)")}else {return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)")}}elsif ($d){return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)")}if ($d &&!isDIGIT($d)&& ($strict ||!($d eq ';' || isSPACE($d)|| $d eq '}'))){return BADVERSION($s,$errstr,"Invalid version format (fractional part required)")}while (isDIGIT($d)){$d++;$j++;if ($d eq '.' && isDIGIT($d-1)){if ($alpha){return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)")}if ($strict){return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions must begin with 'v')")}$d=$s;$qv=TRUE;goto dotted_decimal_version}if ($d eq '_'){if ($strict){return BADVERSION($s,$errstr,"Invalid version format (no underscores)")}if ($alpha){return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)")}if (!isDIGIT($d+1)){return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)")}$width=$j;$d++;$alpha=TRUE}}}version_prescan_finish: while (isSPACE($d)){$d++}if ($d &&!isDIGIT($d)&& (!($d eq ';' || $d eq '}'))){return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)")}if ($saw_decimal > 1 && ($d-1)eq '.'){return BADVERSION($s,$errstr,"Invalid version format (trailing decimal)")}if (defined$sqv){$$sqv=$qv}if (defined$swidth){$$swidth=$width}if (defined$ssaw_decimal){$$ssaw_decimal=$saw_decimal}if (defined$salpha){$$salpha=$alpha}return$d}sub scan_version {my ($s,$rv,$qv)=@_;my$start;my$pos;my$last;my$errstr;my$saw_decimal=0;my$width=3;my$alpha=FALSE;my$vinf=FALSE;my@av;$s=new charstar$s;while (isSPACE($s)){$s++}$last=prescan_version($s,FALSE,\$errstr,\$qv,\$saw_decimal,\$width,\$alpha);if ($errstr){if ($s ne 'undef'){require Carp;Carp::croak($errstr)}}$start=$s;if ($s eq 'v'){$s++}$pos=$s;if ($qv){$$rv->{qv}=$qv}if ($alpha){$$rv->{alpha}=$alpha}if (!$qv && $width < 3){$$rv->{width}=$width}while (isDIGIT($pos)){$pos++}if (!isALPHA($pos)){my$rev;for (;;){$rev=0;{my$end=$pos;my$mult=1;my$orev;if (!$qv && $s > $start && $saw_decimal==1){$mult *= 100;while ($s < $end){$orev=$rev;$rev += $s * $mult;$mult /= 10;if ((abs($orev)> abs($rev))|| (abs($rev)> $VERSION_MAX)){warn("Integer overflow in version %d",$VERSION_MAX);$s=$end - 1;$rev=$VERSION_MAX;$vinf=1}$s++;if ($s eq '_'){$s++}}}else {while (--$end >= $s){$orev=$rev;$rev += $end * $mult;$mult *= 10;if ((abs($orev)> abs($rev))|| (abs($rev)> $VERSION_MAX)){warn("Integer overflow in version");$end=$s - 1;$rev=$VERSION_MAX;$vinf=1}}}}push@av,$rev;if ($vinf){$s=$last;last}elsif ($pos eq '.'){$pos++;if ($qv){while ($pos eq '0'){$pos++}}$s=$pos}elsif ($pos eq '_' && isDIGIT($pos+1)){$s=++$pos}elsif ($pos eq ',' && isDIGIT($pos+1)){$s=++$pos}elsif (isDIGIT($pos)){$s=$pos}else {$s=$pos;last}if ($qv){while (isDIGIT($pos)){$pos++}}else {my$digits=0;while ((isDIGIT($pos)|| $pos eq '_')&& $digits < 3){if ($pos ne '_'){$digits++}$pos++}}}}if ($qv){my$len=$#av;$len=2 - $len;while ($len-- > 0){push@av,0}}if ($vinf){$$rv->{original}="v.Inf";$$rv->{vinf}=1}elsif ($s > $start){$$rv->{original}=$start->currstr($s);if ($qv && $saw_decimal==1 && $start ne 'v'){$$rv->{original}='v' .$$rv->{original}}}else {$$rv->{original}='0';push(@av,0)}$$rv->{version}=\@av;if ($s eq 'undef'){$s += 5}return$s}sub new {my$class=shift;unless (defined$class or $#_ > 1){require Carp;Carp::croak('Usage: version::new(class, version)')}my$self=bless ({},ref ($class)|| $class);my$qv=FALSE;if ($#_==1){$qv=TRUE}my$value=pop;if (ref($value)&& eval('$value->isa("version")')){$self->{version}=[@{$value->{version}}];$self->{qv}=1 if$value->{qv};$self->{alpha}=1 if$value->{alpha};$self->{original}=''.$value->{original};return$self}if (not defined$value or $value =~ /^undef$/){push @{$self->{version}},0;$self->{original}="0";return ($self)}if (ref($value)=~ m/ARRAY|HASH/){require Carp;Carp::croak("Invalid version format (non-numeric data)")}$value=_un_vstring($value);if ($Config{d_setlocale}){use POSIX qw/locale_h/;use if$Config{d_setlocale},'locale';my$currlocale=setlocale(LC_ALL);if (localeconv()->{decimal_point}eq ','){$value =~ tr/,/./}}if ($value =~ /\d+.?\d*e[-+]?\d+/){$value=sprintf("%.9f",$value);$value =~ s/(0+)$//}my$s=scan_version($value,\$self,$qv);if ($s){warn("Version string '%s' contains invalid data; " ."ignoring: '%s'",$value,$s)}return ($self)}*parse=\&new;sub numify {my ($self)=@_;unless (_verify($self)){require Carp;Carp::croak("Invalid version object")}my$width=$self->{width}|| 3;my$alpha=$self->{alpha}|| "";my$len=$#{$self->{version}};my$digit=$self->{version}[0];my$string=sprintf("%d.",$digit);if ($alpha and warnings::enabled()){warnings::warn($WARN_CATEGORY,'alpha->numify() is lossy')}for (my$i=1 ;$i < $len ;$i++ ){$digit=$self->{version}[$i];if ($width < 3){my$denom=10**(3-$width);my$quot=int($digit/$denom);my$rem=$digit - ($quot * $denom);$string .= sprintf("%0".$width."d_%d",$quot,$rem)}else {$string .= sprintf("%03d",$digit)}}if ($len > 0){$digit=$self->{version}[$len];if ($alpha && $width==3){$string .= "_"}$string .= sprintf("%0".$width."d",$digit)}else {$string .= sprintf("000")}return$string}sub normal {my ($self)=@_;unless (_verify($self)){require Carp;Carp::croak("Invalid version object")}my$alpha=$self->{alpha}|| "";my$qv=$self->{qv}|| "";my$len=$#{$self->{version}};my$digit=$self->{version}[0];my$string=sprintf("v%d",$digit);for (my$i=1 ;$i < $len ;$i++ ){$digit=$self->{version}[$i];$string .= sprintf(".%d",$digit)}if ($len > 0){$digit=$self->{version}[$len];if ($alpha){$string .= sprintf("_%0d",$digit)}else {$string .= sprintf(".%0d",$digit)}}if ($len <= 2){for ($len=2 - $len;$len!=0;$len-- ){$string .= sprintf(".%0d",0)}}return$string}sub stringify {my ($self)=@_;unless (_verify($self)){require Carp;Carp::croak("Invalid version object")}return exists$self->{original}? $self->{original}: exists$self->{qv}? $self->normal : $self->numify}sub vcmp {require UNIVERSAL;my ($left,$right,$swap)=@_;my$class=ref($left);unless (UNIVERSAL::isa($right,$class)){$right=$class->new($right)}if ($swap){($left,$right)=($right,$left)}unless (_verify($left)){require Carp;Carp::croak("Invalid version object")}unless (_verify($right)){require Carp;Carp::croak("Invalid version format")}my$l=$#{$left->{version}};my$r=$#{$right->{version}};my$m=$l < $r ? $l : $r;my$lalpha=$left->is_alpha;my$ralpha=$right->is_alpha;my$retval=0;my$i=0;while ($i <= $m && $retval==0){$retval=$left->{version}[$i]<=> $right->{version}[$i];$i++}if ($retval==0 && $l==$r && $left->{version}[$m]==$right->{version}[$m]&& ($lalpha || $ralpha)){if ($lalpha &&!$ralpha){$retval=-1}elsif ($ralpha &&!$lalpha){$retval=+1}}if ($retval==0 && $l!=$r){if ($l < $r){while ($i <= $r && $retval==0){if ($right->{version}[$i]!=0){$retval=-1}$i++}}else {while ($i <= $l && $retval==0){if ($left->{version}[$i]!=0){$retval=+1}$i++}}}return$retval}sub vbool {my ($self)=@_;return vcmp($self,$self->new("0"),1)}sub vnoop {require Carp;Carp::croak("operation not supported with version object")}sub is_alpha {my ($self)=@_;return (exists$self->{alpha})}sub qv {my$value=shift;my$class=$CLASS;if (@_){$class=ref($value)|| $value;$value=shift}$value=_un_vstring($value);$value='v'.$value unless$value =~ /(^v|\d+\.\d+\.\d)/;my$obj=$CLASS->new($value);return bless$obj,$class}*declare=\&qv;sub is_qv {my ($self)=@_;return (exists$self->{qv})}sub _verify {my ($self)=@_;if (ref($self)&& eval {exists$self->{version}}&& ref($self->{version})eq 'ARRAY'){return 1}else {return 0}}sub _is_non_alphanumeric {my$s=shift;$s=new charstar$s;while ($s){return 0 if isSPACE($s);return 1 unless (isALPHA($s)|| isDIGIT($s)|| $s =~ /[.-]/);$s++}return 0}sub _un_vstring {my$value=shift;if (length($value)>= 1 && $value !~ /[,._]/ && _is_non_alphanumeric($value)){my$tvalue;if ($] >= 5.008_001){$tvalue=_find_magic_vstring($value);$value=$tvalue if length$tvalue}elsif ($] >= 5.006_000){$tvalue=sprintf("v%vd",$value);if ($tvalue =~ /^v\d+(\.\d+)*$/){$value=$tvalue}}}return$value}sub _find_magic_vstring {my$value=shift;my$tvalue='';require B;my$sv=B::svref_2object(\$value);my$magic=ref($sv)eq 'B::PVMG' ? $sv->MAGIC : undef;while ($magic){if ($magic->TYPE eq 'V'){$tvalue=$magic->PTR;$tvalue =~ s/^v?(.+)$/v$1/;last}else {$magic=$magic->MOREMAGIC}}return$tvalue}sub _VERSION {my ($obj,$req)=@_;my$class=ref($obj)|| $obj;no strict 'refs';if (exists$INC{"$class.pm"}and not %{"$class\::"}and $] >= 5.008){require Carp;Carp::croak("$class defines neither package nor VERSION" ."--version check failed")}my$version=eval "\$$class\::VERSION";if (defined$version){local $^W if $] <= 5.008;$version=version::vpp->new($version)}if (defined$req){unless (defined$version){require Carp;my$msg=$] < 5.006 ? "$class version $req required--this is only version " : "$class does not define \$$class\::VERSION" ."--version check failed";if ($ENV{VERSION_DEBUG}){Carp::confess($msg)}else {Carp::croak($msg)}}$req=version::vpp->new($req);if ($req > $version){require Carp;if ($req->is_qv){Carp::croak(sprintf ("%s version %s required--"."this is only version %s",$class,$req->normal,$version->normal))}else {Carp::croak(sprintf ("%s version %s required--"."this is only version %s",$class,$req->stringify,$version->stringify))}}}return defined$version ? $version->stringify : undef}1;
|
12159
|
458
|
VERSION_VPP
|
12160
|
459
|
|
12161
|
460
|
s/^ //mg for values %fatpacked;
|
12162
|
461
|
|
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;
|
|
462
|
+my $class = 'FatPacked::'.(0+\%fatpacked);
|
|
463
|
+no strict 'refs';
|
|
464
|
+*{"${class}::files"} = sub { keys %{$_[0]} };
|
|
465
|
+
|
|
466
|
+if ($] < 5.008) {
|
|
467
|
+ *{"${class}::INC"} = sub {
|
|
468
|
+ if (my $fat = $_[0]{$_[1]}) {
|
|
469
|
+ my $pos = 0;
|
|
470
|
+ my $last = length $fat;
|
|
471
|
+ return (sub {
|
|
472
|
+ return 0 if $pos == $last;
|
|
473
|
+ my $next = (1 + index $fat, "\n", $pos) || $last;
|
|
474
|
+ $_ .= substr $fat, $pos, $next - $pos;
|
|
475
|
+ $pos = $next;
|
12170
|
476
|
return 1;
|
12171
|
|
- };
|
|
477
|
+ });
|
12172
|
478
|
}
|
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
|
|
-};
|
|
479
|
+ };
|
|
480
|
+}
|
|
481
|
+
|
|
482
|
+else {
|
|
483
|
+ *{"${class}::INC"} = sub {
|
|
484
|
+ if (my $fat = $_[0]{$_[1]}) {
|
|
485
|
+ open my $fh, '<', \$fat
|
|
486
|
+ or die "FatPacker error loading $_[1] (could be a perl installation issue?)";
|
|
487
|
+ return $fh;
|
|
488
|
+ }
|
|
489
|
+ return;
|
|
490
|
+ };
|
|
491
|
+}
|
|
492
|
+
|
|
493
|
+unshift @INC, bless \%fatpacked, $class;
|
|
494
|
+ } # END OF FATPACK CODE
|
|
495
|
+
|
12179
|
496
|
|
12180
|
|
-} # END OF FATPACK CODE
|
12181
|
497
|
|
12182
|
498
|
use strict;
|
12183
|
499
|
use App::cpanminus::script;
|
12184
|
500
|
|
|
501
|
+
|
12185
|
502
|
unless (caller) {
|
12186
|
503
|
my $app = App::cpanminus::script->new;
|
12187
|
504
|
$app->parse_options(@ARGV);
|
12188
|
|
- $app->doit or exit(1);
|
|
505
|
+ exit $app->doit;
|
12189
|
506
|
}
|
12190
|
507
|
|
12191
|
508
|
__END__
|
...
|
...
|
@@ -12205,7 +522,7 @@ cpanm - get, unpack build and install modules from CPAN
|
12205
|
522
|
cpanm --installdeps . # install all the deps for the current directory
|
12206
|
523
|
cpanm -L extlib Plack # install Plack and all non-core deps into extlib
|
12207
|
524
|
cpanm --mirror http://cpan.cpantesters.org/ DBI # use the fast-syncing mirror
|
12208
|
|
- cpanm --scandeps Moose # See what modules will be installed for Moose
|
|
525
|
+ cpanm --from https://cpan.metacpan.org/ Plack # use only the HTTPS mirror
|
12209
|
526
|
|
12210
|
527
|
=head1 COMMANDS
|
12211
|
528
|
|
...
|
...
|
@@ -12222,7 +539,7 @@ will all work as you expect.
|
12222
|
539
|
cpanm MIYAGAWA/Plack-1.0000.tar.gz
|
12223
|
540
|
cpanm /path/to/Plack-1.0000.tar.gz
|
12224
|
541
|
cpanm http://cpan.metacpan.org/authors/id/M/MI/MIYAGAWA/Plack-0.9990.tar.gz
|
12225
|
|
- cpanm git://github.com/miyagawa/Plack.git
|
|
542
|
+ cpanm git://github.com/plack/Plack.git
|
12226
|
543
|
|
12227
|
544
|
Additionally, you can use the notation using C<~> and C<@> to specify
|
12228
|
545
|
version for a given module. C<~> specifies the version requirement in
|
...
|
...
|
@@ -12241,8 +558,8 @@ which case, archived versions will be filtered out.
|
12241
|
558
|
For a git repository, you can specify a branch, tag, or commit SHA to
|
12242
|
559
|
build. The default is C<master>
|
12243
|
560
|
|
12244
|
|
- cpanm git://github.com/miyagawa/Plack.git@1.0000 # tag
|
12245
|
|
- cpanm git://github.com/miyagawa/Plack.git@devel # branch
|
|
561
|
+ cpanm git://github.com/plack/Plack.git@1.0000 # tag
|
|
562
|
+ cpanm git://github.com/plack/Plack.git@devel # branch
|
12246
|
563
|
|
12247
|
564
|
=item -i, --install
|
12248
|
565
|
|
...
|
...
|
@@ -12328,8 +645,8 @@ configuration. (See --interactive)
|
12328
|
645
|
|
12329
|
646
|
=item -q, --quiet
|
12330
|
647
|
|
12331
|
|
-Makes the output even more quiet than the default. It doesn't print
|
12332
|
|
-anything to the STDERR.
|
|
648
|
+Makes the output even more quiet than the default. It only shows the
|
|
649
|
+successful/failed dependencies to the output.
|
12333
|
650
|
|
12334
|
651
|
=item -l, --local-lib
|
12335
|
652
|
|
...
|
...
|
@@ -12340,10 +657,9 @@ as well.
|
12340
|
657
|
|
12341
|
658
|
=item -L, --local-lib-contained
|
12342
|
659
|
|
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.
|
|
660
|
+Same with C<--local-lib> but with L<--self-contained> set. All
|
|
661
|
+non-core dependencies will be installed even if they're already
|
|
662
|
+installed.
|
12347
|
663
|
|
12348
|
664
|
For instance,
|
12349
|
665
|
|
...
|
...
|
@@ -12354,6 +670,24 @@ directory C<extlib>, which can be loaded from your application with:
|
12354
|
670
|
|
12355
|
671
|
use local::lib '/path/to/extlib';
|
12356
|
672
|
|
|
673
|
+Note that this option does B<NOT> reliably work with perl installations
|
|
674
|
+supplied by operating system vendors that strips standard modules from perl,
|
|
675
|
+such as RHEL, Fedora and CentOS, B<UNLESS> you also install packages supplying
|
|
676
|
+all the modules that have been stripped. For these systems you will probably
|
|
677
|
+want to install the C<perl-core> meta-package which does just that.
|
|
678
|
+
|
|
679
|
+=item --self-contained
|
|
680
|
+
|
|
681
|
+When examining the dependencies, assume no non-core modules are
|
|
682
|
+installed on the system. Handy if you want to bundle application
|
|
683
|
+dependencies in one directory so you can distribute to other machines.
|
|
684
|
+
|
|
685
|
+=item --exclude-vendor
|
|
686
|
+
|
|
687
|
+Don't include modules installed under the 'vendor' paths when searching for
|
|
688
|
+core modules when the C<--self-contained> flag is in effect. This restores
|
|
689
|
+the behaviour from before version 1.7023
|
|
690
|
+
|
12357
|
691
|
=item --mirror
|
12358
|
692
|
|
12359
|
693
|
Specifies the base URL for the CPAN mirror to use, such as
|
...
|
...
|
@@ -12368,28 +702,58 @@ scheme), it is considered as a file scheme as well.
|
12368
|
702
|
cpanm --mirror file:///path/to/mirror
|
12369
|
703
|
cpanm --mirror ~/minicpan # Because shell expands ~ to /home/user
|
12370
|
704
|
|
12371
|
|
-Defaults to C<http://search.cpan.org/CPAN> which is a geo location
|
12372
|
|
-aware redirector.
|
|
705
|
+Defaults to C<http://www.cpan.org/>.
|
12373
|
706
|
|
12374
|
707
|
=item --mirror-only
|
12375
|
708
|
|
12376
|
709
|
Download the mirror's 02packages.details.txt.gz index file instead of
|
12377
|
|
-querying the CPAN Meta DB.
|
|
710
|
+querying the CPAN Meta DB. This will also effectively opt out sending
|
|
711
|
+your local perl versions to backend database servers such as CPAN Meta
|
|
712
|
+DB and MetaCPAN.
|
12378
|
713
|
|
12379
|
714
|
Select this option if you are using a local mirror of CPAN, such as
|
12380
|
715
|
minicpan when you're offline, or your own CPAN index (a.k.a darkpan).
|
12381
|
716
|
|
12382
|
|
-B<Tip:> It might be useful if you name these mirror options with your
|
12383
|
|
-shell aliases, like:
|
|
717
|
+=item --from, -M
|
|
718
|
+
|
|
719
|
+ cpanm -M https://cpan.metacpan.org/
|
|
720
|
+ cpanm --from https://cpan.metacpan.org/
|
|
721
|
+
|
|
722
|
+Use the given mirror URL and its index as the I<only> source to search
|
|
723
|
+and download modules from.
|
12384
|
724
|
|
12385
|
|
- alias minicpanm='cpanm --mirror ~/minicpan --mirror-only'
|
12386
|
|
- alias darkpan='cpanm --mirror http://mycompany.example.com/DPAN --mirror-only'
|
|
725
|
+It works similar to C<--mirror> and C<--mirror-only> combined, with a
|
|
726
|
+small difference: unlike C<--mirror> which I<appends> the URL to the
|
|
727
|
+list of mirrors, C<--from> (or C<-M> for short) uses the specified URL
|
|
728
|
+as its I<only> source to download index and modules from. This makes
|
|
729
|
+the option always override the default mirror, which might have been
|
|
730
|
+set via global options such as the one set by C<PERL_CPANM_OPT>
|
|
731
|
+environment variable.
|
|
732
|
+
|
|
733
|
+B<Tip:> It might be useful if you name these options with your shell
|
|
734
|
+aliases, like:
|
|
735
|
+
|
|
736
|
+ alias minicpanm='cpanm --from ~/minicpan'
|
|
737
|
+ alias darkpan='cpanm --from http://mycompany.example.com/DPAN'
|
12387
|
738
|
|
12388
|
739
|
=item --mirror-index
|
12389
|
740
|
|
12390
|
741
|
B<EXPERIMENTAL>: Specifies the file path to C<02packages.details.txt>
|
12391
|
742
|
for module search index.
|
12392
|
743
|
|
|
744
|
+=item --cpanmetadb
|
|
745
|
+
|
|
746
|
+B<EXPERIMENTAL>: Specifies an alternate URI for CPAN MetaDB index lookups.
|
|
747
|
+
|
|
748
|
+=item --metacpan
|
|
749
|
+
|
|
750
|
+Prefers MetaCPAN API over CPAN MetaDB.
|
|
751
|
+
|
|
752
|
+=item --cpanfile
|
|
753
|
+
|
|
754
|
+B<EXPERIMENTAL>: Specified an alternate path for cpanfile to search for,
|
|
755
|
+when C<--installdeps> command is in use. Defaults to C<cpanfile>.
|
|
756
|
+
|
12393
|
757
|
=item --prompt
|
12394
|
758
|
|
12395
|
759
|
Prompts when a test fails so that you can skip, force install, retry
|
...
|
...
|
@@ -12426,10 +790,67 @@ requires custom configuration or Task:: distributions.
|
12426
|
790
|
Defaults to false, and you can say C<--no-interactive> to override
|
12427
|
791
|
when it's set in the default options in C<PERL_CPANM_OPT>.
|
12428
|
792
|
|
|
793
|
+=item --pp, --pureperl
|
|
794
|
+
|
|
795
|
+Prefer Pure perl build of modules by setting C<PUREPERL_ONLY=1> for
|
|
796
|
+MakeMaker and C<--pureperl-only> for Build.PL based
|
|
797
|
+distributions. Note that not all of the CPAN modules support this
|
|
798
|
+convention yet.
|
|
799
|
+
|
|
800
|
+=item --with-recommends, --with-suggests
|
|
801
|
+
|
|
802
|
+B<EXPERIMENTAL>: Installs dependencies declared as C<recommends> and
|
|
803
|
+C<suggests> respectively, per META spec. When these dependencies fail
|
|
804
|
+to install, cpanm continues the installation, since they're just
|
|
805
|
+recommendation/suggestion.
|
|
806
|
+
|
|
807
|
+Enabling this could potentially make a circular dependency for a few
|
|
808
|
+modules on CPAN, when C<recommends> adds a module that C<recommends>
|
|
809
|
+back the module in return.
|
|
810
|
+
|
|
811
|
+There's also C<--without-recommend> and C<--without-suggests> to
|
|
812
|
+override the default decision made earlier in C<PERL_CPANM_OPT>.
|
|
813
|
+
|
|
814
|
+Defaults to false for both.
|
|
815
|
+
|
|
816
|
+=item --with-develop
|
|
817
|
+
|
|
818
|
+B<EXPERIMENTAL>: Installs develop phase dependencies in META files or
|
|
819
|
+C<cpanfile> when used with C<--installdeps>. Defaults to false.
|
|
820
|
+
|
|
821
|
+=item --with-feature, --without-feature, --with-all-features
|
|
822
|
+
|
|
823
|
+B<EXPERIMENTAL>: Specifies the feature to enable, if a module supports
|
|
824
|
+optional features per META spec 2.0.
|
|
825
|
+
|
|
826
|
+ cpanm --with-feature=opt_csv Spreadsheet::Read
|
|
827
|
+
|
|
828
|
+the features can also be interactively chosen when C<--interactive>
|
|
829
|
+option is enabled.
|
|
830
|
+
|
|
831
|
+C<--with-all-features> enables all the optional features, and
|
|
832
|
+C<--without-feature> can select a feature to disable.
|
|
833
|
+
|
|
834
|
+=item --configure-timeout, --build-timeout, --test-timeout
|
|
835
|
+
|
|
836
|
+Specify the timeout length (in seconds) to wait for the configure,
|
|
837
|
+build and test process. Current default values are: 60 for configure,
|
|
838
|
+3600 for build and 1800 for test.
|
|
839
|
+
|
|
840
|
+=item --configure-args, --build-args, --test-args, --install-args
|
|
841
|
+
|
|
842
|
+B<EXPERIMENTAL>: Pass arguments for configure/build/test/install
|
|
843
|
+commands respectively, for a given module to install.
|
|
844
|
+
|
|
845
|
+ cpanm DBD::mysql --configure-args="--cflags=... --libs=..."
|
|
846
|
+
|
|
847
|
+The argument is only enabled for the module passed as a command line
|
|
848
|
+argument, not dependencies.
|
|
849
|
+
|
12429
|
850
|
=item --scandeps
|
12430
|
851
|
|
12431
|
|
-Scans the depencencies of given modules and output the tree in a text
|
12432
|
|
-format. (See C<--format> below for more options)
|
|
852
|
+B<DEPRECATED>: Scans the depencencies of given modules and output the
|
|
853
|
+tree in a text format. (See C<--format> below for more options)
|
12433
|
854
|
|
12434
|
855
|
Because this command doesn't actually install any distributions, it
|
12435
|
856
|
will be useful that by typing:
|
...
|
...
|
@@ -12445,8 +866,9 @@ combine it with C<-L> option.
|
12445
|
866
|
|
12446
|
867
|
=item --format
|
12447
|
868
|
|
12448
|
|
-Determines what format to display the scanned dependency
|
12449
|
|
-tree. Available options are C<tree>, C<json>, C<yaml> and C<dists>.
|
|
869
|
+B<DEPRECATED>: Determines what format to display the scanned
|
|
870
|
+dependency tree. Available options are C<tree>, C<json>, C<yaml> and
|
|
871
|
+C<dists>.
|
12450
|
872
|
|
12451
|
873
|
=over 8
|
12452
|
874
|
|
...
|
...
|
@@ -12490,6 +912,10 @@ Specifies the optional directory path to copy downloaded tarballs in
|
12490
|
912
|
the CPAN mirror compatible directory structure
|
12491
|
913
|
i.e. I<authors/id/A/AU/AUTHORS/Foo-Bar-version.tar.gz>
|
12492
|
914
|
|
|
915
|
+If the distro tarball did not come from CPAN, for example from a local
|
|
916
|
+file or from GitHub, then it will be saved under
|
|
917
|
+I<vendor/Foo-Bar-version.tar.gz>.
|
|
918
|
+
|
12493
|
919
|
=item --uninst-shadows
|
12494
|
920
|
|
12495
|
921
|
Uninstalls the shadow files of the distribution that you're
|
...
|
...
|
@@ -12512,6 +938,22 @@ I<before> the perl core library path, and uninstalling shadows is not
|
12512
|
938
|
necessary anymore and does more harm by deleting files from the core
|
12513
|
939
|
library path.
|
12514
|
940
|
|
|
941
|
+=item --uninstall, -U
|
|
942
|
+
|
|
943
|
+Uninstalls a module from the library path. It finds a packlist for
|
|
944
|
+given modules, and removes all the files included in the same
|
|
945
|
+distribution.
|
|
946
|
+
|
|
947
|
+If you enable local::lib, it only removes files from the local::lib
|
|
948
|
+directory.
|
|
949
|
+
|
|
950
|
+If you try to uninstall a module in C<perl> directory (i.e. core
|
|
951
|
+module), an error will be thrown.
|
|
952
|
+
|
|
953
|
+A dialog will be prompted to confirm the files to be deleted. If you pass
|
|
954
|
+C<-f> option as well, the dialog will be skipped and uninstallation
|
|
955
|
+will be forced.
|
|
956
|
+
|
12515
|
957
|
=item --cascade-search
|
12516
|
958
|
|
12517
|
959
|
B<EXPERIMENTAL>: Specifies whether to cascade search when you specify
|
...
|
...
|
@@ -12523,8 +965,9 @@ version of the module than requested. Defaults to false.
|
12523
|
965
|
Specifies whether a module given in the command line is skipped if its latest
|
12524
|
966
|
version is already installed. Defaults to true.
|
12525
|
967
|
|
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>.
|
|
968
|
+B<NOTE>: The C<PERL5LIB> environment variable have to be correctly set
|
|
969
|
+for this to work with modules installed using L<local::lib>, unless
|
|
970
|
+you always use the C<-l> option.
|
12528
|
971
|
|
12529
|
972
|
=item --skip-satisfied
|
12530
|
973
|
|
...
|
...
|
@@ -12548,6 +991,13 @@ Defaults to false.
|
12548
|
991
|
Verify the integrity of distribution files retrieved from PAUSE using
|
12549
|
992
|
CHECKSUMS and SIGNATURES (if found). Defaults to false.
|
12550
|
993
|
|
|
994
|
+=item --report-perl-version
|
|
995
|
+
|
|
996
|
+Whether it reports the locally installed perl version to the various
|
|
997
|
+web server as part of User-Agent. Defaults to true unless CI related
|
|
998
|
+environment variables such as C<TRAVIS>, C<CI> or C<AUTOMATED_TESTING>
|
|
999
|
+is enabled. You can disable it by using C<--no-report-perl-version>.
|
|
1000
|
+
|
12551
|
1001
|
=item --auto-cleanup
|
12552
|
1002
|
|
12553
|
1003
|
Specifies the number of days in which cpanm's work directories
|
...
|
...
|
@@ -12561,9 +1011,9 @@ directories.
|
12561
|
1011
|
|
12562
|
1012
|
Generates man pages for executables (man1) and libraries (man3).
|
12563
|
1013
|
|
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>.
|
|
1014
|
+Defaults to true (man pages generated) unless C<-L|--local-lib-contained>
|
|
1015
|
+option is supplied in which case it's set to false. You can disable
|
|
1016
|
+it with C<--no-man-pages>.
|
12567
|
1017
|
|
12568
|
1018
|
=item --lwp
|
12569
|
1019
|
|
...
|
...
|
@@ -12594,7 +1044,7 @@ L<App::cpanminus>
|
12594
|
1044
|
|
12595
|
1045
|
=head1 COPYRIGHT
|
12596
|
1046
|
|
12597
|
|
-Copyright 2010 Tatsuhiko Miyagawa.
|
|
1047
|
+Copyright 2010- Tatsuhiko Miyagawa.
|
12598
|
1048
|
|
12599
|
1049
|
=head1 AUTHOR
|
12600
|
1050
|
|