gitprep / cpanm /
Newer Older
11316 lines | 327.146kb
copy gitweblite soruce code
root authored on 2012-11-23
1
#!/usr/bin/env perl
2
#
3
# You want to install cpanminus? Run the following command and it will
4
# install itself for you. You might want to run it as a root with sudo
5
# if you want to install to places like /usr/local/bin.
6
#
7
#   % curl -L http://cpanmin.us | perl - --self-upgrade
8
#
9
# If you don't have curl but wget, replace `curl -L` with `wget -O -`.
10
#
11
# For more details about this program, visit http://search.cpan.org/dist/App-cpanminus
12
#
13
# DO NOT EDIT -- this is an auto generated file
14
# This chunk of stuff was generated by App::FatPacker. To find the original
15
# file's code, look for the end of this BEGIN block or the string 'FATPACK'
16
BEGIN {
17
my %fatpacked;
18

            
19
$fatpacked{"App/cpanminus.pm"} = <<'APP_CPANMINUS';
20
  package App::cpanminus;
21
  our $VERSION = "1.5007";
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> 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 running on Google AppEngine at
137
  L<http://cpanmetadb.plackperl.org/>. The site is updated every hour to reflect
138
  the latest changes from fast syncing mirrors. The script then also falls back
139
  to scrape the site L<http://search.cpan.org/>.
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> Copyright (c) 2010 by David Golden and Ricardo Signes
251
  
252
  =item L<Try::Tiny> Copyright (c) 2009 Yuval Kogman
253
  
254
  =item L<parent> Copyright (c) 2007-10 Max Maischein
255
  
256
  =item L<Version::Requirements> copyright (c) 2010 by Ricardo Signes
257
  
258
  =item L<CPAN::Meta::YAML> copyright (c) 2010 by Adam Kennedy
259
  
260
  =back
261
  
262
  =head1 LICENSE
263
  
264
  Same as Perl.
265
  
266
  =head1 CREDITS
267
  
268
  =head2 CONTRIBUTORS
269
  
270
  Patches and code improvements were contributed by:
271
  
272
  Goro Fuji, Kazuhiro Osawa, Tokuhiro Matsuno, Kenichi Ishigaki, Ian
273
  Wells, Pedro Melo, Masayoshi Sekimura, Matt S Trout (mst), squeeky,
274
  horus and Ingy dot Net.
275
  
276
  =head2 ACKNOWLEDGEMENTS
277
  
278
  Bug reports, suggestions and feedbacks were sent by, or general
279
  acknowledgement goes to:
280
  
281
  Jesse Vincent, David Golden, Andreas Koenig, Jos Boumans, Chris
282
  Williams, Adam Kennedy, Audrey Tang, J. Shirley, Chris Prather, Jesse
283
  Luehrs, Marcus Ramberg, Shawn M Moore, chocolateboy, Chirs Nehren,
284
  Jonathan Rockway, Leon Brocard, Simon Elliott, Ricardo Signes, AEvar
285
  Arnfjord Bjarmason, Eric Wilhelm, Florian Ragwitz and xaicron.
286
  
287
  =head1 COMMUNITY
288
  
289
  =over 4
290
  
291
  =item L<http://github.com/miyagawa/cpanminus> - source code repository, issue tracker
292
  
293
  =item L<irc://irc.perl.org/#toolchain> - discussions about Perl toolchain. I'm there.
294
  
295
  =back
296
  
297
  =head1 NO WARRANTY
298
  
299
  This software is provided "as-is," without any express or implied
300
  warranty. In no event shall the author be held liable for any damages
301
  arising from the use of the software.
302
  
303
  =head1 SEE ALSO
304
  
305
  L<CPAN> L<CPANPLUS> L<pip>
306
  
307
  =cut
308
  
309
  1;
310
APP_CPANMINUS
311

            
312
$fatpacked{"App/cpanminus/script.pm"} = <<'APP_CPANMINUS_SCRIPT';
313
  package App::cpanminus::script;
314
  use strict;
315
  use Config;
316
  use Cwd ();
317
  use File::Basename ();
318
  use File::Find ();
319
  use File::Path ();
320
  use File::Spec ();
321
  use File::Copy ();
322
  use Getopt::Long ();
323
  use Parse::CPAN::Meta;
324
  use Symbol ();
325
  
326
  use constant WIN32 => $^O eq 'MSWin32';
327
  use constant SUNOS => $^O eq 'solaris';
328
  
329
  our $VERSION = "1.5007";
330
  
331
  my $quote = WIN32 ? q/"/ : q/'/;
332
  
333
  sub new {
334
      my $class = shift;
335
  
336
      bless {
337
          home => "$ENV{HOME}/.cpanm",
338
          cmd  => 'install',
339
          seen => {},
340
          notest => undef,
341
          installdeps => undef,
342
          force => undef,
343
          sudo => undef,
344
          make  => undef,
345
          verbose => undef,
346
          quiet => undef,
347
          interactive => undef,
348
          log => undef,
349
          mirrors => [],
350
          mirror_only => undef,
351
          mirror_index => undef,
352
          perl => $^X,
353
          argv => [],
354
          local_lib => undef,
355
          self_contained => undef,
356
          prompt_timeout => 0,
357
          prompt => undef,
358
          configure_timeout => 60,
359
          try_lwp => 1,
360
          try_wget => 1,
361
          try_curl => 1,
362
          uninstall_shadows => ($] < 5.012),
363
          skip_installed => 1,
364
          skip_satisfied => 0,
365
          auto_cleanup => 7, # days
366
          pod2man => 1,
367
          installed_dists => 0,
368
          showdeps => 0,
369
          scandeps => 0,
370
          scandeps_tree => [],
371
          format   => 'tree',
372
          save_dists => undef,
373
          skip_configure => 0,
374
          @_,
375
      }, $class;
376
  }
377
  
378
  sub env {
379
      my($self, $key) = @_;
380
      $ENV{"PERL_CPANM_" . $key};
381
  }
382
  
383
  sub parse_options {
384
      my $self = shift;
385
  
386
      local @ARGV = @{$self->{argv}};
387
      push @ARGV, split /\s+/, $self->env('OPT');
388
      push @ARGV, @_;
389
  
390
      Getopt::Long::Configure("bundling");
391
      Getopt::Long::GetOptions(
392
          'f|force'   => sub { $self->{skip_installed} = 0; $self->{force} = 1 },
393
          'n|notest!' => \$self->{notest},
394
          'S|sudo!'   => \$self->{sudo},
395
          'v|verbose' => sub { $self->{verbose} = $self->{interactive} = 1 },
396
          'q|quiet!'  => \$self->{quiet},
397
          'h|help'    => sub { $self->{action} = 'show_help' },
398
          'V|version' => sub { $self->{action} = 'show_version' },
399
          'perl=s'    => \$self->{perl},
400
          'l|local-lib=s' => sub { $self->{local_lib} = $self->maybe_abs($_[1]) },
401
          'L|local-lib-contained=s' => sub {
402
              $self->{local_lib} = $self->maybe_abs($_[1]);
403
              $self->{self_contained} = 1;
404
              $self->{pod2man} = undef;
405
          },
406
          'mirror=s@' => $self->{mirrors},
407
          'mirror-only!' => \$self->{mirror_only},
408
          'mirror-index=s'  => sub { $self->{mirror_index} = $_[1]; $self->{mirror_only} = 1 },
409
          'cascade-search!' => \$self->{cascade_search},
410
          'prompt!'   => \$self->{prompt},
411
          'installdeps' => \$self->{installdeps},
412
          'skip-installed!' => \$self->{skip_installed},
413
          'skip-satisfied!' => \$self->{skip_satisfied},
414
          'reinstall'    => sub { $self->{skip_installed} = 0 },
415
          'interactive!' => \$self->{interactive},
416
          'i|install' => sub { $self->{cmd} = 'install' },
417
          'info'      => sub { $self->{cmd} = 'info' },
418
          'look'      => sub { $self->{cmd} = 'look'; $self->{skip_installed} = 0 },
419
          'self-upgrade' => sub { $self->{cmd} = 'install'; $self->{skip_installed} = 1; push @ARGV, 'App::cpanminus' },
420
          'uninst-shadows!'  => \$self->{uninstall_shadows},
421
          'lwp!'    => \$self->{try_lwp},
422
          'wget!'   => \$self->{try_wget},
423
          'curl!'   => \$self->{try_curl},
424
          'auto-cleanup=s' => \$self->{auto_cleanup},
425
          'man-pages!' => \$self->{pod2man},
426
          'scandeps'   => \$self->{scandeps},
427
          'showdeps'   => sub { $self->{showdeps} = 1; $self->{skip_installed} = 0 },
428
          'format=s'   => \$self->{format},
429
          'save-dists=s' => sub {
430
              $self->{save_dists} = $self->maybe_abs($_[1]);
431
          },
432
          'skip-configure!' => \$self->{skip_configure},
433
          'metacpan'   => \$self->{metacpan},
434
      );
435
  
436
      if (!@ARGV && $0 ne '-' && !-t STDIN){ # e.g. # cpanm < author/requires.cpanm
437
          push @ARGV, $self->load_argv_from_fh(\*STDIN);
438
          $self->{load_from_stdin} = 1;
439
      }
440
  
441
      $self->{argv} = \@ARGV;
442
  }
443
  
444
  sub check_libs {
445
      my $self = shift;
446
      return if $self->{_checked}++;
447
  
448
      $self->bootstrap_local_lib;
449
      if (@{$self->{bootstrap_deps} || []}) {
450
          local $self->{notest} = 1; # test failure in bootstrap should be tolerated
451
          local $self->{scandeps} = 0;
452
          $self->install_deps(Cwd::cwd, 0, @{$self->{bootstrap_deps}});
453
      }
454
  }
455
  
456
  sub doit {
457
      my $self = shift;
458
  
459
      $self->setup_home;
460
      $self->init_tools;
461
  
462
      if (my $action = $self->{action}) {
463
          $self->$action() and return 1;
464
      }
465
  
466
      $self->show_help(1)
467
          unless @{$self->{argv}} or $self->{load_from_stdin};
468
  
469
      $self->configure_mirrors;
470
  
471
      my $cwd = Cwd::cwd;
472
  
473
      my @fail;
474
      for my $module (@{$self->{argv}}) {
475
          if ($module =~ s/\.pm$//i) {
476
              my ($volume, $dirs, $file) = File::Spec->splitpath($module);
477
              $module = join '::', grep { $_ } File::Spec->splitdir($dirs), $file;
478
          }
479
  
480
          ($module, my $version) = split /\~/, $module, 2;
481
          if ($self->{skip_satisfied} or defined $version) {
482
              $self->check_libs;
483
              my($ok, $local) = $self->check_module($module, $version || 0);
484
              if ($ok) {
485
                  $self->diag("You have $module (" . ($local || 'undef') . ")\n", 1);
486
                  next;
487
              }
488
          }
489
  
490
          $self->chdir($cwd);
491
          $self->install_module($module, 0, $version)
492
              or push @fail, $module;
493
      }
494
  
495
      if ($self->{base} && $self->{auto_cleanup}) {
496
          $self->cleanup_workdirs;
497
      }
498
  
499
      if ($self->{installed_dists}) {
500
          my $dists = $self->{installed_dists} > 1 ? "distributions" : "distribution";
501
          $self->diag("$self->{installed_dists} $dists installed\n", 1);
502
      }
503
  
504
      if ($self->{scandeps}) {
505
          $self->dump_scandeps();
506
      }
507
  
508
      return !@fail;
509
  }
510
  
511
  sub setup_home {
512
      my $self = shift;
513
  
514
      $self->{home} = $self->env('HOME') if $self->env('HOME');
515
  
516
      unless (_writable($self->{home})) {
517
          die "Can't write to cpanm home '$self->{home}': You should fix it with chown/chmod first.\n";
518
      }
519
  
520
      $self->{base} = "$self->{home}/work/" . time . ".$$";
521
      File::Path::mkpath([ $self->{base} ], 0, 0777);
522
  
523
      my $link = "$self->{home}/latest-build";
524
      eval { unlink $link; symlink $self->{base}, $link };
525
  
526
      $self->{log} = File::Spec->catfile($self->{home}, "build.log"); # because we use shell redirect
527
  
528
      {
529
          my $log = $self->{log}; my $base = $self->{base};
530
          $self->{at_exit} = sub {
531
              my $self = shift;
532
              File::Copy::copy($self->{log}, "$self->{base}/build.log");
533
          };
534
      }
535
  
536
      { open my $out, ">$self->{log}" or die "$self->{log}: $!" }
537
  
538
      $self->chat("cpanm (App::cpanminus) $VERSION on perl $] built for $Config{archname}\n" .
539
                  "Work directory is $self->{base}\n");
540
  }
541
  
542
  sub fetch_meta_sco {
543
      my($self, $dist) = @_;
544
      return if $self->{mirror_only};
545
  
546
      my $meta_yml = $self->get("http://search.cpan.org/meta/$dist->{distvname}/META.yml");
547
      return $self->parse_meta_string($meta_yml);
548
  }
549
  
550
  sub package_index_for {
551
      my ($self, $mirror) = @_;
552
      return $self->source_for($mirror) . "/02packages.details.txt";
553
  }
554
  
555
  sub generate_mirror_index {
556
      my ($self, $mirror) = @_;
557
      my $file = $self->package_index_for($mirror);
558
      my $gz_file = $file . '.gz';
559
      my $index_mtime = (stat $gz_file)[9];
560
  
561
      unless (-e $file && (stat $file)[9] >= $index_mtime) {
562
          $self->chat("Uncompressing index file...\n");
563
          if (eval {require Compress::Zlib}) {
564
              my $gz = Compress::Zlib::gzopen($gz_file, "rb")
565
                  or do { $self->diag_fail("$Compress::Zlib::gzerrno opening compressed index"); return};
566
              open my $fh, '>', $file
567
                  or do { $self->diag_fail("$! opening uncompressed index for write"); return };
568
              my $buffer;
569
              while (my $status = $gz->gzread($buffer)) {
570
                  if ($status < 0) {
571
                      $self->diag_fail($gz->gzerror . " reading compressed index");
572
                      return;
573
                  }
574
                  print $fh $buffer;
575
              }
576
          } else {
577
              if (system("gunzip -c $gz_file > $file")) {
578
                  $self->diag_fail("Cannot uncompress -- please install gunzip or Compress::Zlib");
579
                  return;
580
              }
581
          }
582
          utime $index_mtime, $index_mtime, $file;
583
      }
584
      return 1;
585
  }
586
  
587
  sub search_mirror_index {
588
      my ($self, $mirror, $module, $version) = @_;
589
      $self->search_mirror_index_file($self->package_index_for($mirror), $module, $version);
590
  }
591
  
592
  sub search_mirror_index_file {
593
      my($self, $file, $module, $version) = @_;
594
  
595
      open my $fh, '<', $file or return;
596
      my $found;
597
      while (<$fh>) {
598
          if (m!^\Q$module\E\s+([\w\.]+)\s+(.*)!m) {
599
              $found = $self->cpan_module($module, $2, $1);
600
              last;
601
          }
602
      }
603
  
604
      return $found unless $self->{cascade_search};
605
  
606
      if ($found) {
607
          if (!$version or
608
              version->new($found->{version} || 0) >= version->new($version)) {
609
              return $found;
610
          } else {
611
              $self->chat("Found $module version $found->{version} < $version.\n");
612
          }
613
      }
614
  
615
      return;
616
  }
617
  
618
  sub search_module {
619
      my($self, $module, $version) = @_;
620
  
621
      unless ($self->{mirror_only}) {
622
          if ($self->{metacpan}) {
623
              require JSON::PP;
624
              $self->chat("Searching $module on metacpan ...\n");
625
              my $module_uri  = "http://api.metacpan.org/module/$module";
626
              my $module_json = $self->get($module_uri);
627
              my $module_meta = eval { JSON::PP::decode_json($module_json) };
628
              if ($module_meta && $module_meta->{distribution}) {
629
                  my $dist_uri = "http://api.metacpan.org/release/$module_meta->{distribution}";
630
                  my $dist_json = $self->get($dist_uri);
631
                  my $dist_meta = eval { JSON::PP::decode_json($dist_json) };
632
                  if ($dist_meta && $dist_meta->{download_url}) {
633
                      (my $distfile = $dist_meta->{download_url}) =~ s!.+/authors/id/!!;
634
                      local $self->{mirrors} = $self->{mirrors};
635
                      if ($dist_meta->{stat}->{mtime} > time()-24*60*60) {
636
                          $self->{mirrors} = ['http://cpan.metacpan.org'];
637
                      }
638
                      return $self->cpan_module($module, $distfile, $dist_meta->{version});
639
                  }
640
              }
641
              $self->diag_fail("Finding $module on metacpan failed.");
642
          }
643
  
644
          $self->chat("Searching $module on cpanmetadb ...\n");
645
          my $uri  = "http://cpanmetadb.plackperl.org/v1.0/package/$module";
646
          my $yaml = $self->get($uri);
647
          my $meta = $self->parse_meta_string($yaml);
648
          if ($meta && $meta->{distfile}) {
649
              return $self->cpan_module($module, $meta->{distfile}, $meta->{version});
650
          }
651
  
652
          $self->diag_fail("Finding $module on cpanmetadb failed.");
653
  
654
          $self->chat("Searching $module on search.cpan.org ...\n");
655
          my $uri  = "http://search.cpan.org/perldoc?$module";
656
          my $html = $self->get($uri);
657
          $html =~ m!<a href="/CPAN/authors/id/(.*?\.(?:tar\.gz|tgz|tar\.bz2|zip))">!
658
              and return $self->cpan_module($module, $1);
659
  
660
          $self->diag_fail("Finding $module on search.cpan.org failed.");
661
      }
662
  
663
      if ($self->{mirror_index}) {
664
          $self->chat("Searching $module on mirror index $self->{mirror_index} ...\n");
665
          my $pkg = $self->search_mirror_index_file($self->{mirror_index}, $module, $version);
666
          return $pkg if $pkg;
667
      }
668
  
669
      MIRROR: for my $mirror (@{ $self->{mirrors} }) {
670
          $self->chat("Searching $module on mirror $mirror ...\n");
671
          my $name = '02packages.details.txt.gz';
672
          my $uri  = "$mirror/modules/$name";
673
          my $gz_file = $self->package_index_for($mirror) . '.gz';
674
  
675
          unless ($self->{pkgs}{$uri}) {
676
              $self->chat("Downloading index file $uri ...\n");
677
              $self->mirror($uri, $gz_file);
678
              $self->generate_mirror_index($mirror) or next MIRROR;
679
              $self->{pkgs}{$uri} = "!!retrieved!!";
680
          }
681
  
682
          my $pkg = $self->search_mirror_index($mirror, $module, $version);
683
          return $pkg if $pkg;
684
  
685
          $self->diag_fail("Finding $module ($version) on mirror $mirror failed.");
686
      }
687
  
688
      return;
689
  }
690
  
691
  sub source_for {
692
      my($self, $mirror) = @_;
693
      $mirror =~ s/[^\w\.\-]+/%/g;
694
  
695
      my $dir = "$self->{home}/sources/$mirror";
696
      File::Path::mkpath([ $dir ], 0, 0777);
697
  
698
      return $dir;
699
  }
700
  
701
  sub load_argv_from_fh {
702
      my($self, $fh) = @_;
703
  
704
      my @argv;
705
      while(defined(my $line = <$fh>)){
706
          chomp $line;
707
          $line =~ s/#.+$//; # comment
708
          $line =~ s/^\s+//; # trim spaces
709
          $line =~ s/\s+$//; # trim spaces
710
  
711
          push @argv, split ' ', $line if $line;
712
      }
713
      return @argv;
714
  }
715
  
716
  sub show_version {
717
      print "cpanm (App::cpanminus) version $VERSION\n";
718
      return 1;
719
  }
720
  
721
  sub show_help {
722
      my $self = shift;
723
  
724
      if ($_[0]) {
725
          die <<USAGE;
726
  Usage: cpanm [options] Module [...]
727
  
728
  Try `cpanm --help` or `man cpanm` for more options.
729
  USAGE
730
      }
731
  
732
      print <<HELP;
733
  Usage: cpanm [options] Module [...]
734
  
735
  Options:
736
    -v,--verbose              Turns on chatty output
737
    -q,--quiet                Turns off the most output
738
    --interactive             Turns on interactive configure (required for Task:: modules)
739
    -f,--force                force install
740
    -n,--notest               Do not run unit tests
741
    -S,--sudo                 sudo to run install commands
742
    --installdeps             Only install dependencies
743
    --showdeps                Only display direct dependencies
744
    --reinstall               Reinstall the distribution even if you already have the latest version installed
745
    --mirror                  Specify the base URL for the mirror (e.g. http://cpan.cpantesters.org/)
746
    --mirror-only             Use the mirror's index file instead of the CPAN Meta DB
747
    --prompt                  Prompt when configure/build/test fails
748
    -l,--local-lib            Specify the install base to install modules
749
    -L,--local-lib-contained  Specify the install base to install all non-core modules
750
    --auto-cleanup            Number of days that cpanm's work directories expire in. Defaults to 7
751
  
752
  Commands:
753
    --self-upgrade            upgrades itself
754
    --info                    Displays distribution info on CPAN
755
    --look                    Opens the distribution with your SHELL
756
    -V,--version              Displays software version
757
  
758
  Examples:
759
  
760
    cpanm Test::More                                          # install Test::More
761
    cpanm MIYAGAWA/Plack-0.99_05.tar.gz                       # full distribution path
762
    cpanm http://example.org/LDS/CGI.pm-3.20.tar.gz           # install from URL
763
    cpanm ~/dists/MyCompany-Enterprise-1.00.tar.gz            # install from a local file
764
    cpanm --interactive Task::Kensho                          # Configure interactively
765
    cpanm .                                                   # install from local directory
766
    cpanm --installdeps .                                     # install all the deps for the current directory
767
    cpanm -L extlib Plack                                     # install Plack and all non-core deps into extlib
768
    cpanm --mirror http://cpan.cpantesters.org/ DBI           # use the fast-syncing mirror
769
  
770
  You can also specify the default options in PERL_CPANM_OPT environment variable in the shell rc:
771
  
772
    export PERL_CPANM_OPT="--prompt --reinstall -l ~/perl --mirror http://cpan.cpantesters.org"
773
  
774
  Type `man cpanm` or `perldoc cpanm` for the more detailed explanation of the options.
775
  
776
  HELP
777
  
778
      return 1;
779
  }
780
  
781
  sub _writable {
782
      my $dir = shift;
783
      my @dir = File::Spec->splitdir($dir);
784
      while (@dir) {
785
          $dir = File::Spec->catdir(@dir);
786
          if (-e $dir) {
787
              return -w _;
788
          }
789
          pop @dir;
790
      }
791
  
792
      return;
793
  }
794
  
795
  sub maybe_abs {
796
      my($self, $lib) = @_;
797
      return $lib if $lib eq '_'; # special case: gh-113
798
      $lib =~ /^[~\/]/ ? $lib : File::Spec->canonpath(Cwd::cwd . "/$lib");
799
  }
800
  
801
  sub bootstrap_local_lib {
802
      my $self = shift;
803
  
804
      # If -l is specified, use that.
805
      if ($self->{local_lib}) {
806
          return $self->setup_local_lib($self->{local_lib});
807
      }
808
  
809
      # root, locally-installed perl or --sudo: don't care about install_base
810
      return if $self->{sudo} or (_writable($Config{installsitelib}) and _writable($Config{installsitebin}));
811
  
812
      # local::lib is configured in the shell -- yay
813
      if ($ENV{PERL_MM_OPT} and ($ENV{MODULEBUILDRC} or $ENV{PERL_MB_OPT})) {
814
          $self->bootstrap_local_lib_deps;
815
          return;
816
      }
817
  
818
      $self->setup_local_lib;
819
  
820
      $self->diag(<<DIAG);
821
  !
822
  ! Can't write to $Config{installsitelib} and $Config{installsitebin}: Installing modules to $ENV{HOME}/perl5
823
  ! To turn off this warning, you have to do one of the following:
824
  !   - run me as a root or with --sudo option (to install to $Config{installsitelib} and $Config{installsitebin})
825
  |   - run me with --local-lib option e.g. cpanm --local-lib=~/perl5
826
  !   - Set PERL_CPANM_OPT="--local-lib=~/perl5" environment variable (in your shell rc file)
827
  !   - Configure local::lib in your shell to set PERL_MM_OPT etc.
828
  !
829
  DIAG
830
      sleep 2;
831
  }
832
  
833
  sub _core_only_inc {
834
      my($self, $base) = @_;
835
      require local::lib;
836
      (
837
          local::lib->install_base_perl_path($base),
838
          local::lib->install_base_arch_path($base),
839
          @Config{qw(privlibexp archlibexp)},
840
      );
841
  }
842
  
843
  sub _diff {
844
      my($self, $old, $new) = @_;
845
  
846
      my @diff;
847
      my %old = map { $_ => 1 } @$old;
848
      for my $n (@$new) {
849
          push @diff, $n unless exists $old{$n};
850
      }
851
  
852
      @diff;
853
  }
854
  
855
  sub _setup_local_lib_env {
856
      my($self, $base) = @_;
857
      local $SIG{__WARN__} = sub { }; # catch 'Attempting to write ...'
858
      local::lib->setup_env_hash_for($base);
859
  }
860
  
861
  sub setup_local_lib {
862
      my($self, $base) = @_;
863
      $base = undef if $base eq '_';
864
  
865
      require local::lib;
866
      {
867
          local $0 = 'cpanm'; # so curl/wget | perl works
868
          $base ||= "~/perl5";
869
          if ($self->{self_contained}) {
870
              my @inc = $self->_core_only_inc($base);
871
              $self->{search_inc} = [ @inc ];
872
          } else {
873
              $self->{search_inc} = [
874
                  local::lib->install_base_arch_path($base),
875
                  local::lib->install_base_perl_path($base),
876
                  @INC,
877
              ];
878
          }
879
          $self->_setup_local_lib_env($base);
880
      }
881
  
882
      $self->bootstrap_local_lib_deps;
883
  }
884
  
885
  sub bootstrap_local_lib_deps {
886
      my $self = shift;
887
      push @{$self->{bootstrap_deps}},
888
          'ExtUtils::MakeMaker' => 6.31,
889
          'ExtUtils::Install'   => 1.46;
890
  }
891
  
892
  sub prompt_bool {
893
      my($self, $mess, $def) = @_;
894
  
895
      my $val = $self->prompt($mess, $def);
896
      return lc $val eq 'y';
897
  }
898
  
899
  sub prompt {
900
      my($self, $mess, $def) = @_;
901
  
902
      my $isa_tty = -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT)) ;
903
      my $dispdef = defined $def ? "[$def] " : " ";
904
      $def = defined $def ? $def : "";
905
  
906
      if (!$self->{prompt} || (!$isa_tty && eof STDIN)) {
907
          return $def;
908
      }
909
  
910
      local $|=1;
911
      local $\;
912
      my $ans;
913
      eval {
914
          local $SIG{ALRM} = sub { undef $ans; die "alarm\n" };
915
          print STDOUT "$mess $dispdef";
916
          alarm $self->{prompt_timeout} if $self->{prompt_timeout};
917
          $ans = <STDIN>;
918
          alarm 0;
919
      };
920
      if ( defined $ans ) {
921
          chomp $ans;
922
      } else { # user hit ctrl-D or alarm timeout
923
          print STDOUT "\n";
924
      }
925
  
926
      return (!defined $ans || $ans eq '') ? $def : $ans;
927
  }
928
  
929
  sub diag_ok {
930
      my($self, $msg) = @_;
931
      chomp $msg;
932
      $msg ||= "OK";
933
      if ($self->{in_progress}) {
934
          $self->_diag("$msg\n");
935
          $self->{in_progress} = 0;
936
      }
937
      $self->log("-> $msg\n");
938
  }
939
  
940
  sub diag_fail {
941
      my($self, $msg, $always) = @_;
942
      chomp $msg;
943
      if ($self->{in_progress}) {
944
          $self->_diag("FAIL\n");
945
          $self->{in_progress} = 0;
946
      }
947
  
948
      if ($msg) {
949
          $self->_diag("! $msg\n", $always);
950
          $self->log("-> FAIL $msg\n");
951
      }
952
  }
953
  
954
  sub diag_progress {
955
      my($self, $msg) = @_;
956
      chomp $msg;
957
      $self->{in_progress} = 1;
958
      $self->_diag("$msg ... ");
959
      $self->log("$msg\n");
960
  }
961
  
962
  sub _diag {
963
      my($self, $msg, $always) = @_;
964
      print STDERR $msg if $always or $self->{verbose} or !$self->{quiet};
965
  }
966
  
967
  sub diag {
968
      my($self, $msg, $always) = @_;
969
      $self->_diag($msg, $always);
970
      $self->log($msg);
971
  }
972
  
973
  sub chat {
974
      my $self = shift;
975
      print STDERR @_ if $self->{verbose};
976
      $self->log(@_);
977
  }
978
  
979
  sub log {
980
      my $self = shift;
981
      open my $out, ">>$self->{log}";
982
      print $out @_;
983
  }
984
  
985
  sub run {
986
      my($self, $cmd) = @_;
987
  
988
      if (WIN32 && ref $cmd eq 'ARRAY') {
989
          $cmd = join q{ }, map { $self->shell_quote($_) } @$cmd;
990
      }
991
  
992
      if (ref $cmd eq 'ARRAY') {
993
          my $pid = fork;
994
          if ($pid) {
995
              waitpid $pid, 0;
996
              return !$?;
997
          } else {
998
              $self->run_exec($cmd);
999
          }
1000
      } else {
1001
          unless ($self->{verbose}) {
1002
              $cmd .= " >> " . $self->shell_quote($self->{log}) . " 2>&1";
1003
          }
1004
          !system $cmd;
1005
      }
1006
  }
1007
  
1008
  sub run_exec {
1009
      my($self, $cmd) = @_;
1010
  
1011
      if (ref $cmd eq 'ARRAY') {
1012
          unless ($self->{verbose}) {
1013
              open my $logfh, ">>", $self->{log};
1014
              open STDERR, '>&', $logfh;
1015
              open STDOUT, '>&', $logfh;
1016
              close $logfh;
1017
          }
1018
          exec @$cmd;
1019
      } else {
1020
          unless ($self->{verbose}) {
1021
              $cmd .= " >> " . $self->shell_quote($self->{log}) . " 2>&1";
1022
          }
1023
          exec $cmd;
1024
      }
1025
  }
1026
  
1027
  sub run_timeout {
1028
      my($self, $cmd, $timeout) = @_;
1029
      return $self->run($cmd) if WIN32 || $self->{verbose} || !$timeout;
1030
  
1031
      my $pid = fork;
1032
      if ($pid) {
1033
          eval {
1034
              local $SIG{ALRM} = sub { die "alarm\n" };
1035
              alarm $timeout;
1036
              waitpid $pid, 0;
1037
              alarm 0;
1038
          };
1039
          if ($@ && $@ eq "alarm\n") {
1040
              $self->diag_fail("Timed out (> ${timeout}s). Use --verbose to retry.");
1041
              local $SIG{TERM} = 'IGNORE';
1042
              kill TERM => 0;
1043
              waitpid $pid, 0;
1044
              return;
1045
          }
1046
          return !$?;
1047
      } elsif ($pid == 0) {
1048
          $self->run_exec($cmd);
1049
      } else {
1050
          $self->chat("! fork failed: falling back to system()\n");
1051
          $self->run($cmd);
1052
      }
1053
  }
1054
  
1055
  sub configure {
1056
      my($self, $cmd) = @_;
1057
  
1058
      # trick AutoInstall
1059
      local $ENV{PERL5_CPAN_IS_RUNNING} = local $ENV{PERL5_CPANPLUS_IS_RUNNING} = $$;
1060
  
1061
      # e.g. skip CPAN configuration on local::lib
1062
      local $ENV{PERL5_CPANM_IS_RUNNING} = $$;
1063
  
1064
      my $use_default = !$self->{interactive};
1065
      local $ENV{PERL_MM_USE_DEFAULT} = $use_default;
1066
  
1067
      # skip man page generation
1068
      local $ENV{PERL_MM_OPT} = $ENV{PERL_MM_OPT};
1069
      unless ($self->{pod2man}) {
1070
          $ENV{PERL_MM_OPT} .= " INSTALLMAN1DIR=none INSTALLMAN3DIR=none";
1071
      }
1072
  
1073
      local $self->{verbose} = $self->{verbose} || $self->{interactive};
1074
      $self->run_timeout($cmd, $self->{configure_timeout});
1075
  }
1076
  
1077
  sub build {
1078
      my($self, $cmd, $distname) = @_;
1079
  
1080
      return 1 if $self->run_timeout($cmd, $self->{build_timeout});
1081
      while (1) {
1082
          my $ans = lc $self->prompt("Building $distname failed.\nYou can s)kip, r)etry, e)xamine build log, or l)ook ?", "s");
1083
          return                               if $ans eq 's';
1084
          return $self->build($cmd, $distname) if $ans eq 'r';
1085
          $self->show_build_log                if $ans eq 'e';
1086
          $self->look                          if $ans eq 'l';
1087
      }
1088
  }
1089
  
1090
  sub test {
1091
      my($self, $cmd, $distname) = @_;
1092
      return 1 if $self->{notest};
1093
  
1094
      # https://rt.cpan.org/Ticket/Display.html?id=48965#txn-1013385
1095
      local $ENV{PERL_MM_USE_DEFAULT} = 1;
1096
  
1097
      return 1 if $self->run_timeout($cmd, $self->{test_timeout});
1098
      if ($self->{force}) {
1099
          $self->diag_fail("Testing $distname failed but installing it anyway.");
1100
          return 1;
1101
      } else {
1102
          $self->diag_fail;
1103
          while (1) {
1104
              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");
1105
              return                              if $ans eq 's';
1106
              return $self->test($cmd, $distname) if $ans eq 'r';
1107
              return 1                            if $ans eq 'f';
1108
              $self->show_build_log               if $ans eq 'e';
1109
              $self->look                         if $ans eq 'l';
1110
          }
1111
      }
1112
  }
1113
  
1114
  sub install {
1115
      my($self, $cmd, $uninst_opts) = @_;
1116
  
1117
      if ($self->{sudo}) {
1118
          unshift @$cmd, "sudo";
1119
      }
1120
  
1121
      if ($self->{uninstall_shadows} && !$ENV{PERL_MM_OPT}) {
1122
          push @$cmd, @$uninst_opts;
1123
      }
1124
  
1125
      $self->run($cmd);
1126
  }
1127
  
1128
  sub look {
1129
      my $self = shift;
1130
  
1131
      my $shell = $ENV{SHELL};
1132
      $shell  ||= $ENV{COMSPEC} if WIN32;
1133
      if ($shell) {
1134
          my $cwd = Cwd::cwd;
1135
          $self->diag("Entering $cwd with $shell\n");
1136
          system $shell;
1137
      } else {
1138
          $self->diag_fail("You don't seem to have a SHELL :/");
1139
      }
1140
  }
1141
  
1142
  sub show_build_log {
1143
      my $self = shift;
1144
  
1145
      my @pagers = (
1146
          $ENV{PAGER},
1147
          (WIN32 ? () : ('less')),
1148
          'more'
1149
      );
1150
      my $pager;
1151
      while (@pagers) {
1152
          $pager = shift @pagers;
1153
          next unless $pager;
1154
          $pager = $self->which($pager);
1155
          next unless $pager;
1156
          last;
1157
      }
1158
  
1159
      if ($pager) {
1160
          # win32 'more' doesn't allow "more build.log", the < is required
1161
          system("$pager < $self->{log}");
1162
      }
1163
      else {
1164
          $self->diag_fail("You don't seem to have a PAGER :/");
1165
      }
1166
  }
1167
  
1168
  sub chdir {
1169
      my $self = shift;
1170
      Cwd::chdir(File::Spec->canonpath($_[0])) or die "$_[0]: $!";
1171
  }
1172
  
1173
  sub configure_mirrors {
1174
      my $self = shift;
1175
      unless (@{$self->{mirrors}}) {
1176
          $self->{mirrors} = [ 'http://search.cpan.org/CPAN' ];
1177
      }
1178
      for (@{$self->{mirrors}}) {
1179
          s!^/!file:///!;
1180
          s!/$!!;
1181
      }
1182
  }
1183
  
1184
  sub self_upgrade {
1185
      my $self = shift;
1186
      $self->{argv} = [ 'App::cpanminus' ];
1187
      return; # continue
1188
  }
1189
  
1190
  sub install_module {
1191
      my($self, $module, $depth, $version) = @_;
1192
  
1193
      if ($self->{seen}{$module}++) {
1194
          $self->chat("Already tried $module. Skipping.\n");
1195
          return 1;
1196
      }
1197
  
1198
      my $dist = $self->resolve_name($module, $version);
1199
      unless ($dist) {
1200
          $self->diag_fail("Couldn't find module or a distribution $module ($version)", 1);
1201
          return;
1202
      }
1203
  
1204
      if ($dist->{distvname} && $self->{seen}{$dist->{distvname}}++) {
1205
          $self->chat("Already tried $dist->{distvname}. Skipping.\n");
1206
          return 1;
1207
      }
1208
  
1209
      if ($self->{cmd} eq 'info') {
1210
          print $self->format_dist($dist), "\n";
1211
          return 1;
1212
      }
1213
  
1214
      $self->check_libs;
1215
      $self->setup_module_build_patch unless $self->{pod2man};
1216
  
1217
      if ($dist->{module}) {
1218
          my($ok, $local) = $self->check_module($dist->{module}, $dist->{module_version} || 0);
1219
          if ($self->{skip_installed} && $ok) {
1220
              $self->diag("$dist->{module} is up to date. ($local)\n", 1);
1221
              return 1;
1222
          }
1223
      }
1224
  
1225
      if ($dist->{dist} eq 'perl'){
1226
          $self->diag("skipping $dist->{pathname}\n");
1227
          return 1;
1228
      }
1229
  
1230
      $self->diag("--> Working on $module\n");
1231
  
1232
      $dist->{dir} ||= $self->fetch_module($dist);
1233
  
1234
      unless ($dist->{dir}) {
1235
          $self->diag_fail("Failed to fetch distribution $dist->{distvname}", 1);
1236
          return;
1237
      }
1238
  
1239
      $self->chat("Entering $dist->{dir}\n");
1240
      $self->chdir($self->{base});
1241
      $self->chdir($dist->{dir});
1242
  
1243
      if ($self->{cmd} eq 'look') {
1244
          $self->look;
1245
          return 1;
1246
      }
1247
  
1248
      return $self->build_stuff($module, $dist, $depth);
1249
  }
1250
  
1251
  sub format_dist {
1252
      my($self, $dist) = @_;
1253
  
1254
      # TODO support --dist-format?
1255
      return "$dist->{cpanid}/$dist->{filename}";
1256
  }
1257
  
1258
  sub fetch_module {
1259
      my($self, $dist) = @_;
1260
  
1261
      $self->chdir($self->{base});
1262
  
1263
      for my $uri (@{$dist->{uris}}) {
1264
          $self->diag_progress("Fetching $uri");
1265
  
1266
          # Ugh, $dist->{filename} can contain sub directory
1267
          my $filename = $dist->{filename} || $uri;
1268
          my $name = File::Basename::basename($filename);
1269
  
1270
          my $cancelled;
1271
          my $fetch = sub {
1272
              my $file;
1273
              eval {
1274
                  local $SIG{INT} = sub { $cancelled = 1; die "SIGINT\n" };
1275
                  $self->mirror($uri, $name);
1276
                  $file = $name if -e $name;
1277
              };
1278
              $self->chat("$@") if $@ && $@ ne "SIGINT\n";
1279
              return $file;
1280
          };
1281
  
1282
          my($try, $file);
1283
          while ($try++ < 3) {
1284
              $file = $fetch->();
1285
              last if $cancelled or $file;
1286
              $self->diag_fail("Download $uri failed. Retrying ... ");
1287
          }
1288
  
1289
          if ($cancelled) {
1290
              $self->diag_fail("Download cancelled.");
1291
              return;
1292
          }
1293
  
1294
          unless ($file) {
1295
              $self->diag_fail("Failed to download $uri");
1296
              next;
1297
          }
1298
  
1299
          $self->diag_ok;
1300
          $dist->{local_path} = File::Spec->rel2abs($name);
1301
  
1302
          my $dir = $self->unpack($file);
1303
          next unless $dir; # unpack failed
1304
  
1305
          if (my $save = $self->{save_dists}) {
1306
              my $path = "$save/authors/id/$dist->{pathname}";
1307
              $self->chat("Copying $name to $path\n");
1308
              File::Path::mkpath([ File::Basename::dirname($path) ], 0, 0777);
1309
              File::Copy::copy($file, $path) or warn $!;
1310
          }
1311
  
1312
          return $dist, $dir;
1313
      }
1314
  }
1315
  
1316
  sub unpack {
1317
      my($self, $file) = @_;
1318
      $self->chat("Unpacking $file\n");
1319
      my $dir = $file =~ /\.zip/i ? $self->unzip($file) : $self->untar($file);
1320
      unless ($dir) {
1321
          $self->diag_fail("Failed to unpack $file: no directory");
1322
      }
1323
      return $dir;
1324
  }
1325
  
1326
  sub resolve_name {
1327
      my($self, $module, $version) = @_;
1328
  
1329
      # URL
1330
      if ($module =~ /^(ftp|https?|file):/) {
1331
          if ($module =~ m!authors/id/!) {
1332
              return $self->cpan_dist($module, $module);
1333
          } else {
1334
              return { uris => [ $module ] };
1335
          }
1336
      }
1337
  
1338
      # Directory
1339
      if ($module =~ m!^[\./]! && -d $module) {
1340
          return {
1341
              source => 'local',
1342
              dir => Cwd::abs_path($module),
1343
          };
1344
      }
1345
  
1346
      # File
1347
      if (-f $module) {
1348
          return {
1349
              source => 'local',
1350
              uris => [ "file://" . Cwd::abs_path($module) ],
1351
          };
1352
      }
1353
  
1354
      # cpan URI
1355
      if ($module =~ s!^cpan:///distfile/!!) {
1356
          return $self->cpan_dist($module);
1357
      }
1358
  
1359
      # PAUSEID/foo
1360
      if ($module =~ m!([A-Z]{3,})/!) {
1361
          return $self->cpan_dist($module);
1362
      }
1363
  
1364
      # Module name
1365
      return $self->search_module($module, $version);
1366
  }
1367
  
1368
  sub cpan_module {
1369
      my($self, $module, $dist, $version) = @_;
1370
  
1371
      my $dist = $self->cpan_dist($dist);
1372
      $dist->{module} = $module;
1373
      $dist->{module_version} = $version if $version && $version ne 'undef';
1374
  
1375
      return $dist;
1376
  }
1377
  
1378
  sub cpan_dist {
1379
      my($self, $dist, $url) = @_;
1380
  
1381
      $dist =~ s!^([A-Z]{3})!substr($1,0,1)."/".substr($1,0,2)."/".$1!e;
1382
  
1383
      require CPAN::DistnameInfo;
1384
      my $d = CPAN::DistnameInfo->new($dist);
1385
  
1386
      if ($url) {
1387
          $url = [ $url ] unless ref $url eq 'ARRAY';
1388
      } else {
1389
          my $id = $d->cpanid;
1390
          my $fn = substr($id, 0, 1) . "/" . substr($id, 0, 2) . "/" . $id . "/" . $d->filename;
1391
  
1392
          my @mirrors = @{$self->{mirrors}};
1393
          my @urls    = map "$_/authors/id/$fn", @mirrors;
1394
  
1395
          $url = \@urls,
1396
      }
1397
  
1398
      return {
1399
          $d->properties,
1400
          source  => 'cpan',
1401
          uris    => $url,
1402
      };
1403
  }
1404
  
1405
  sub setup_module_build_patch {
1406
      my $self = shift;
1407
  
1408
      open my $out, ">$self->{base}/ModuleBuildSkipMan.pm" or die $!;
1409
      print $out <<EOF;
1410
  package ModuleBuildSkipMan;
1411
  CHECK {
1412
    if (%Module::Build::) {
1413
      no warnings 'redefine';
1414
      *Module::Build::Base::ACTION_manpages = sub {};
1415
      *Module::Build::Base::ACTION_docs     = sub {};
1416
    }
1417
  }
1418
  1;
1419
  EOF
1420
  }
1421
  
1422
  sub check_module {
1423
      my($self, $mod, $want_ver) = @_;
1424
  
1425
      require Module::Metadata;
1426
      my $meta = Module::Metadata->new_from_module($mod, inc => $self->{search_inc})
1427
          or return 0, undef;
1428
  
1429
      my $version = $meta->version;
1430
  
1431
      # When -L is in use, the version loaded from 'perl' library path
1432
      # might be newer than (or actually wasn't core at) the version
1433
      # that is shipped with the current perl
1434
      if ($self->{self_contained} && $self->loaded_from_perl_lib($meta)) {
1435
          require Module::CoreList;
1436
          unless (exists $Module::CoreList::version{$]+0}{$mod}) {
1437
              return 0, undef;
1438
          }
1439
          $version = $Module::CoreList::version{$]+0}{$mod};
1440
      }
1441
  
1442
      $self->{local_versions}{$mod} = $version;
1443
  
1444
      if ($self->is_deprecated($meta)){
1445
          return 0, $version;
1446
      } elsif (!$want_ver or $version >= version->new($want_ver)) {
1447
          return 1, ($version || 'undef');
1448
      } else {
1449
          return 0, $version;
1450
      }
1451
  }
1452
  
1453
  sub is_deprecated {
1454
      my($self, $meta) = @_;
1455
  
1456
      my $deprecated = eval {
1457
          require Module::CoreList;
1458
          Module::CoreList::is_deprecated($meta->{module});
1459
      };
1460
  
1461
      return unless $deprecated;
1462
      return $self->loaded_from_perl_lib($meta);
1463
  }
1464
  
1465
  sub loaded_from_perl_lib {
1466
      my($self, $meta) = @_;
1467
  
1468
      require Config;
1469
      for my $dir (qw(archlibexp privlibexp)) {
1470
          my $confdir = $Config{$dir};
1471
          if ($confdir eq substr($meta->filename, 0, length($confdir))) {
1472
              return 1;
1473
          }
1474
      }
1475
  
1476
      return;
1477
  }
1478
  
1479
  sub should_install {
1480
      my($self, $mod, $ver) = @_;
1481
  
1482
      $self->chat("Checking if you have $mod $ver ... ");
1483
      my($ok, $local) = $self->check_module($mod, $ver);
1484
  
1485
      if ($ok)       { $self->chat("Yes ($local)\n") }
1486
      elsif ($local) { $self->chat("No ($local < $ver)\n") }
1487
      else           { $self->chat("No\n") }
1488
  
1489
      return $mod unless $ok;
1490
      return;
1491
  }
1492
  
1493
  sub install_deps {
1494
      my($self, $dir, $depth, @deps) = @_;
1495
  
1496
      my(@install, %seen);
1497
      while (my($mod, $ver) = splice @deps, 0, 2) {
1498
          next if $seen{$mod} or $mod eq 'perl' or $mod eq 'Config';
1499
          if ($self->should_install($mod, $ver)) {
1500
              push @install, [ $mod, $ver ];
1501
              $seen{$mod} = 1;
1502
          }
1503
      }
1504
  
1505
      if (@install) {
1506
          $self->diag("==> Found dependencies: " . join(", ",  map $_->[0], @install) . "\n");
1507
      }
1508
  
1509
      my @fail;
1510
      for my $mod (@install) {
1511
          $self->install_module($mod->[0], $depth + 1, $mod->[1])
1512
              or push @fail, $mod->[0];
1513
      }
1514
  
1515
      $self->chdir($self->{base});
1516
      $self->chdir($dir) if $dir;
1517
  
1518
      return @fail;
1519
  }
1520
  
1521
  sub install_deps_bailout {
1522
      my($self, $target, $dir, $depth, @deps) = @_;
1523
  
1524
      my @fail = $self->install_deps($dir, $depth, @deps);
1525
      if (@fail) {
1526
          unless ($self->prompt_bool("Installing the following dependencies failed:\n==> " .
1527
                                     join(", ", @fail) . "\nDo you want to continue building $target anyway?", "n")) {
1528
              $self->diag_fail("Bailing out the installation for $target. Retry with --prompt or --force.", 1);
1529
              return;
1530
          }
1531
      }
1532
  
1533
      return 1;
1534
  }
1535
  
1536
  sub build_stuff {
1537
      my($self, $stuff, $dist, $depth) = @_;
1538
  
1539
      my @config_deps;
1540
      if (!%{$dist->{meta} || {}} && -e 'META.yml') {
1541
          $self->chat("Checking configure dependencies from META.yml\n");
1542
          $dist->{meta} = $self->parse_meta('META.yml');
1543
      }
1544
  
1545
      if (!$dist->{meta} && $dist->{source} eq 'cpan') {
1546
          $self->chat("META.yml not found or unparsable. Fetching META.yml from search.cpan.org\n");
1547
          $dist->{meta} = $self->fetch_meta_sco($dist);
1548
      }
1549
  
1550
      $dist->{meta} ||= {};
1551
  
1552
      push @config_deps, %{$dist->{meta}{configure_requires} || {}};
1553
  
1554
      my $target = $dist->{meta}{name} ? "$dist->{meta}{name}-$dist->{meta}{version}" : $dist->{dir};
1555
  
1556
      $self->install_deps_bailout($target, $dist->{dir}, $depth, @config_deps)
1557
          or return;
1558
  
1559
      $self->diag_progress("Configuring $target");
1560
  
1561
      my $configure_state = $self->configure_this($dist);
1562
  
1563
      $self->diag_ok($configure_state->{configured_ok} ? "OK" : "N/A");
1564
  
1565
      my @deps = $self->find_prereqs($dist);
1566
      my $module_name = $self->find_module_name($configure_state) || $dist->{meta}{name};
1567
      $module_name =~ s/-/::/g;
1568
  
1569
      if ($self->{showdeps}) {
1570
          my %rootdeps = (@config_deps, @deps); # merge
1571
          for my $mod (keys %rootdeps) {
1572
              my $ver = $rootdeps{$mod};
1573
              print $mod, ($ver ? "~$ver" : ""), "\n";
1574
          }
1575
          return 1;
1576
      }
1577
  
1578
      my $distname = $dist->{meta}{name} ? "$dist->{meta}{name}-$dist->{meta}{version}" : $stuff;
1579
  
1580
      my $walkup;
1581
      if ($self->{scandeps}) {
1582
          $walkup = $self->scandeps_append_child($dist);
1583
      }
1584
  
1585
      $self->install_deps_bailout($distname, $dist->{dir}, $depth, @deps)
1586
          or return;
1587
  
1588
      if ($self->{scandeps}) {
1589
          unless ($configure_state->{configured_ok}) {
1590
              my $diag = <<DIAG;
1591
  ! Configuring $distname failed. See $self->{log} for details.
1592
  ! You might have to install the following modules first to get --scandeps working correctly.
1593
  DIAG
1594
              if (@config_deps) {
1595
                  my @tree = @{$self->{scandeps_tree}};
1596
                  $diag .= "!\n" . join("", map "! * $_->[0]{module}\n", @tree[0..$#tree-1]) if @tree;
1597
              }
1598
              $self->diag("!\n$diag!\n", 1);
1599
          }
1600
          $walkup->();
1601
          return 1;
1602
      }
1603
  
1604
      if ($self->{installdeps} && $depth == 0) {
1605
          if ($configure_state->{configured_ok}) {
1606
              $self->diag("<== Installed dependencies for $stuff. Finishing.\n");
1607
              return 1;
1608
          } else {
1609
              $self->diag("! Configuring $distname failed. See $self->{log} for details.\n", 1);
1610
              return;
1611
          }
1612
      }
1613
  
1614
      my $installed;
1615
      if ($configure_state->{use_module_build} && -e 'Build' && -f _) {
1616
          my @switches = $self->{pod2man} ? () : ("-I$self->{base}", "-MModuleBuildSkipMan");
1617
          $self->diag_progress("Building " . ($self->{notest} ? "" : "and testing ") . $distname);
1618
          $self->build([ $self->{perl}, @switches, "./Build" ], $distname) &&
1619
          $self->test([ $self->{perl}, "./Build", "test" ], $distname) &&
1620
          $self->install([ $self->{perl}, @switches, "./Build", "install" ], [ "--uninst", 1 ]) &&
1621
          $installed++;
1622
      } elsif ($self->{make} && -e 'Makefile') {
1623
          $self->diag_progress("Building " . ($self->{notest} ? "" : "and testing ") . $distname);
1624
          $self->build([ $self->{make} ], $distname) &&
1625
          $self->test([ $self->{make}, "test" ], $distname) &&
1626
          $self->install([ $self->{make}, "install" ], [ "UNINST=1" ]) &&
1627
          $installed++;
1628
      } else {
1629
          my $why;
1630
          my $configure_failed = $configure_state->{configured} && !$configure_state->{configured_ok};
1631
          if ($configure_failed) { $why = "Configure failed for $distname." }
1632
          elsif ($self->{make})  { $why = "The distribution doesn't have a proper Makefile.PL/Build.PL" }
1633
          else                   { $why = "Can't configure the distribution. You probably need to have 'make'." }
1634
  
1635
          $self->diag_fail("$why See $self->{log} for details.", 1);
1636
          return;
1637
      }
1638
  
1639
      if ($installed) {
1640
          my $local   = $self->{local_versions}{$dist->{module} || ''};
1641
          my $version = $dist->{module_version} || $dist->{meta}{version} || $dist->{version};
1642
          my $reinstall = $local && ($local eq $version);
1643
  
1644
          my $how = $reinstall ? "reinstalled $distname"
1645
                  : $local     ? "installed $distname (upgraded from $local)"
1646
                               : "installed $distname" ;
1647
          my $msg = "Successfully $how";
1648
          $self->diag_ok;
1649
          $self->diag("$msg\n", 1);
1650
          $self->{installed_dists}++;
1651
          $self->save_meta($stuff, $dist, $module_name, \@config_deps, \@deps);
1652
          return 1;
1653
      } else {
1654
          my $msg = "Building $distname failed";
1655
          $self->diag_fail("Installing $stuff failed. See $self->{log} for details.", 1);
1656
          return;
1657
      }
1658
  }
1659
  
1660
  sub configure_this {
1661
      my($self, $dist) = @_;
1662
  
1663
      if ($self->{skip_configure}) {
1664
          my $eumm = -e 'Makefile';
1665
          my $mb   = -e 'Build' && -f _;
1666
          return {
1667
              configured => 1,
1668
              configured_ok => $eumm || $mb,
1669
              use_module_build => $mb,
1670
          };
1671
      }
1672
  
1673
      my @mb_switches;
1674
      unless ($self->{pod2man}) {
1675
          # it has to be push, so Module::Build is loaded from the adjusted path when -L is in use
1676
          push @mb_switches, ("-I$self->{base}", "-MModuleBuildSkipMan");
1677
      }
1678
  
1679
      my $state = {};
1680
  
1681
      my $try_eumm = sub {
1682
          if (-e 'Makefile.PL') {
1683
              $self->chat("Running Makefile.PL\n");
1684
  
1685
              # NOTE: according to Devel::CheckLib, most XS modules exit
1686
              # with 0 even if header files are missing, to avoid receiving
1687
              # tons of FAIL reports in such cases. So exit code can't be
1688
              # trusted if it went well.
1689
              if ($self->configure([ $self->{perl}, "Makefile.PL" ])) {
1690
                  $state->{configured_ok} = -e 'Makefile';
1691
              }
1692
              $state->{configured}++;
1693
          }
1694
      };
1695
  
1696
      my $try_mb = sub {
1697
          if (-e 'Build.PL') {
1698
              $self->chat("Running Build.PL\n");
1699
              if ($self->configure([ $self->{perl}, @mb_switches, "Build.PL" ])) {
1700
                  $state->{configured_ok} = -e 'Build' && -f _;
1701
              }
1702
              $state->{use_module_build}++;
1703
              $state->{configured}++;
1704
          }
1705
      };
1706
  
1707
      # Module::Build deps should use MakeMaker because that causes circular deps and fail
1708
      # Otherwise we should prefer Build.PL
1709
      my %should_use_mm = map { $_ => 1 } qw( version ExtUtils-ParseXS ExtUtils-Install ExtUtils-Manifest );
1710
  
1711
      my @try;
1712
      if ($dist->{dist} && $should_use_mm{$dist->{dist}}) {
1713
          @try = ($try_eumm, $try_mb);
1714
      } else {
1715
          @try = ($try_mb, $try_eumm);
1716
      }
1717
  
1718
      for my $try (@try) {
1719
          $try->();
1720
          last if $state->{configured_ok};
1721
      }
1722
  
1723
      unless ($state->{configured_ok}) {
1724
          while (1) {
1725
              my $ans = lc $self->prompt("Configuring $dist->{dist} failed.\nYou can s)kip, r)etry, e)xamine build log, or l)ook ?", "s");
1726
              last                                if $ans eq 's';
1727
              return $self->configure_this($dist) if $ans eq 'r';
1728
              $self->show_build_log               if $ans eq 'e';
1729
              $self->look                         if $ans eq 'l';
1730
          }
1731
      }
1732
  
1733
      return $state;
1734
  }
1735
  
1736
  sub find_module_name {
1737
      my($self, $state) = @_;
1738
  
1739
      return unless $state->{configured_ok};
1740
  
1741
      if ($state->{use_module_build} &&
1742
          -e "_build/build_params") {
1743
          my $params = do { open my $in, "_build/build_params"; $self->safe_eval(join "", <$in>) };
1744
          return eval { $params->[2]{module_name} } || undef;
1745
      } elsif (-e "Makefile") {
1746
          open my $mf, "Makefile";
1747
          while (<$mf>) {
1748
              if (/^\#\s+NAME\s+=>\s+(.*)/) {
1749
                  return $self->safe_eval($1);
1750
              }
1751
          }
1752
      }
1753
  
1754
      return;
1755
  }
1756
  
1757
  sub save_meta {
1758
      my($self, $module, $dist, $module_name, $config_deps, $build_deps) = @_;
1759
  
1760
      return unless $dist->{distvname} && $dist->{source} eq 'cpan';
1761
  
1762
      my $base = ($ENV{PERL_MM_OPT} || '') =~ /INSTALL_BASE=/
1763
          ? ($self->install_base($ENV{PERL_MM_OPT}) . "/lib/perl5") : $Config{sitelibexp};
1764
  
1765
      my $provides = $self->_merge_hashref(
1766
          map Module::Metadata->package_versions_from_directory($_),
1767
              qw( blib/lib blib/arch ) # FCGI.pm :(
1768
      );
1769
  
1770
      mkdir "blib/meta", 0777 or die $!;
1771
  
1772
      my $local = {
1773
          name => $module_name,
1774
          module => $module,
1775
          version => $provides->{$module}{version} || $dist->{version},
1776
          dist => $dist->{distvname},
1777
          pathname => $dist->{pathname},
1778
          provides => $provides,
1779
      };
1780
  
1781
      require JSON::PP;
1782
      open my $fh, ">", "blib/meta/install.json" or die $!;
1783
      print $fh JSON::PP::encode_json($local);
1784
  
1785
      # Existence of MYMETA.* Depends on EUMM/M::B versions and CPAN::Meta
1786
      if (-e "MYMETA.json") {
1787
          File::Copy::copy("MYMETA.json", "blib/meta/MYMETA.json");
1788
      }
1789
  
1790
      my @cmd = (
1791
          ($self->{sudo} ? 'sudo' : ()),
1792
          $^X,
1793
          '-MExtUtils::Install=install',
1794
          '-e',
1795
          qq[install({ 'blib/meta' => '$base/$Config{archname}/.meta/$dist->{distvname}' })],
1796
      );
1797
      $self->run(\@cmd);
1798
  }
1799
  
1800
  sub _merge_hashref {
1801
      my($self, @hashrefs) = @_;
1802
  
1803
      my %hash;
1804
      for my $h (@hashrefs) {
1805
          %hash = (%hash, %$h);
1806
      }
1807
  
1808
      return \%hash;
1809
  }
1810
  
1811
  sub install_base {
1812
      my($self, $mm_opt) = @_;
1813
      $mm_opt =~ /INSTALL_BASE=(\S+)/ and return $1;
1814
      die "Your PERL_MM_OPT doesn't contain INSTALL_BASE";
1815
  }
1816
  
1817
  sub safe_eval {
1818
      my($self, $code) = @_;
1819
      eval $code;
1820
  }
1821
  
1822
  sub find_prereqs {
1823
      my($self, $dist) = @_;
1824
  
1825
      my @deps = $self->extract_meta_prereqs($dist);
1826
  
1827
      if ($dist->{module} =~ /^Bundle::/i) {
1828
          push @deps, $self->bundle_deps($dist);
1829
      }
1830
  
1831
      return @deps;
1832
  }
1833
  
1834
  sub extract_meta_prereqs {
1835
      my($self, $dist) = @_;
1836
  
1837
      my $meta = $dist->{meta};
1838
  
1839
      my @deps;
1840
      if (-e "MYMETA.json") {
1841
          require JSON::PP;
1842
          $self->chat("Checking dependencies from MYMETA.json ...\n");
1843
          my $json = do { open my $in, "<MYMETA.json"; local $/; <$in> };
1844
          my $mymeta = JSON::PP::decode_json($json);
1845
          if ($mymeta) {
1846
              $meta->{$_} = $mymeta->{$_} for qw(name version);
1847
              return $self->extract_requires($mymeta);
1848
          }
1849
      }
1850
  
1851
      if (-e 'MYMETA.yml') {
1852
          $self->chat("Checking dependencies from MYMETA.yml ...\n");
1853
          my $mymeta = $self->parse_meta('MYMETA.yml');
1854
          if ($mymeta) {
1855
              $meta->{$_} = $mymeta->{$_} for qw(name version);
1856
              return $self->extract_requires($mymeta);
1857
          }
1858
      }
1859
  
1860
      if (-e '_build/prereqs') {
1861
          $self->chat("Checking dependencies from _build/prereqs ...\n");
1862
          my $mymeta = do { open my $in, "_build/prereqs"; $self->safe_eval(join "", <$in>) };
1863
          @deps = $self->extract_requires($mymeta);
1864
      } elsif (-e 'Makefile') {
1865
          $self->chat("Finding PREREQ from Makefile ...\n");
1866
          open my $mf, "Makefile";
1867
          while (<$mf>) {
1868
              if (/^\#\s+PREREQ_PM => {\s*(.*?)\s*}/) {
1869
                  my @all;
1870
                  my @pairs = split ', ', $1;
1871
                  for (@pairs) {
1872
                      my ($pkg, $v) = split '=>', $_;
1873
                      push @all, [ $pkg, $v ];
1874
                  }
1875
                  my $list = join ", ", map { "'$_->[0]' => $_->[1]" } @all;
1876
                  my $prereq = $self->safe_eval("no strict; +{ $list }");
1877
                  push @deps, %$prereq if $prereq;
1878
                  last;
1879
              }
1880
          }
1881
      }
1882
  
1883
      return @deps;
1884
  }
1885
  
1886
  sub bundle_deps {
1887
      my($self, $dist) = @_;
1888
  
1889
      my @files;
1890
      File::Find::find({
1891
          wanted => sub { push @files, File::Spec->rel2abs($_) if /\.pm/i },
1892
          no_chdir => 1,
1893
      }, '.');
1894
  
1895
      my @deps;
1896
  
1897
      for my $file (@files) {
1898
          open my $pod, "<", $file or next;
1899
          my $in_contents;
1900
          while (<$pod>) {
1901
              if (/^=head\d\s+CONTENTS/) {
1902
                  $in_contents = 1;
1903
              } elsif (/^=/) {
1904
                  $in_contents = 0;
1905
              } elsif ($in_contents) {
1906
                  /^(\S+)\s*(\S+)?/
1907
                      and push @deps, $1, $self->maybe_version($2);
1908
              }
1909
          }
1910
      }
1911
  
1912
      return @deps;
1913
  }
1914
  
1915
  sub maybe_version {
1916
      my($self, $string) = @_;
1917
      return $string && $string =~ /^\.?\d/ ? $string : undef;
1918
  }
1919
  
1920
  sub extract_requires {
1921
      my($self, $meta) = @_;
1922
  
1923
      if ($meta->{'meta-spec'} && $meta->{'meta-spec'}{version} == 2) {
1924
          my @phase = $self->{notest} ? qw( build runtime ) : qw( build test runtime );
1925
          my @deps = map {
1926
              my $p = $meta->{prereqs}{$_} || {};
1927
              %{$p->{requires} || {}};
1928
          } @phase;
1929
          return @deps;
1930
      }
1931
  
1932
      my @deps;
1933
      push @deps, %{$meta->{build_requires}} if $meta->{build_requires};
1934
      push @deps, %{$meta->{requires}} if $meta->{requires};
1935
  
1936
      return @deps;
1937
  }
1938
  
1939
  sub cleanup_workdirs {
1940
      my $self = shift;
1941
  
1942
      my $expire = time - 24 * 60 * 60 * $self->{auto_cleanup};
1943
      my @targets;
1944
  
1945
      opendir my $dh, "$self->{home}/work";
1946
      while (my $e = readdir $dh) {
1947
          next if $e !~ /^(\d+)\.\d+$/; # {UNIX time}.{PID}
1948
          my $time = $1;
1949
          if ($time < $expire) {
1950
              push @targets, "$self->{home}/work/$e";
1951
          }
1952
      }
1953
  
1954
      if (@targets) {
1955
          $self->chat("Expiring ", scalar(@targets), " work directories.\n");
1956
          File::Path::rmtree(\@targets, 0, 0); # safe = 0, since blib usually doesn't have write bits
1957
      }
1958
  }
1959
  
1960
  sub scandeps_append_child {
1961
      my($self, $dist) = @_;
1962
  
1963
      my $new_node = [ $dist, [] ];
1964
  
1965
      my $curr_node = $self->{scandeps_current} || [ undef, $self->{scandeps_tree} ];
1966
      push @{$curr_node->[1]}, $new_node;
1967
  
1968
      $self->{scandeps_current} = $new_node;
1969
  
1970
      return sub { $self->{scandeps_current} = $curr_node };
1971
  }
1972
  
1973
  sub dump_scandeps {
1974
      my $self = shift;
1975
  
1976
      if ($self->{format} eq 'tree') {
1977
          $self->walk_down(sub {
1978
              my($dist, $depth) = @_;
1979
              if ($depth == 0) {
1980
                  print "$dist->{distvname}\n";
1981
              } else {
1982
                  print " " x ($depth - 1);
1983
                  print "\\_ $dist->{distvname}\n";
1984
              }
1985
          }, 1);
1986
      } elsif ($self->{format} =~ /^dists?$/) {
1987
          $self->walk_down(sub {
1988
              my($dist, $depth) = @_;
1989
              print $self->format_dist($dist), "\n";
1990
          }, 0);
1991
      } elsif ($self->{format} eq 'json') {
1992
          require JSON::PP;
1993
          print JSON::PP::encode_json($self->{scandeps_tree});
1994
      } elsif ($self->{format} eq 'yaml') {
1995
          require YAML;
1996
          print YAML::Dump($self->{scandeps_tree});
1997
      } else {
1998
          $self->diag("Unknown format: $self->{format}\n");
1999
      }
2000
  }
2001
  
2002
  sub walk_down {
2003
      my($self, $cb, $pre) = @_;
2004
      $self->_do_walk_down($self->{scandeps_tree}, $cb, 0, $pre);
2005
  }
2006
  
2007
  sub _do_walk_down {
2008
      my($self, $children, $cb, $depth, $pre) = @_;
2009
  
2010
      # DFS - $pre determines when we call the callback
2011
      for my $node (@$children) {
2012
          $cb->($node->[0], $depth) if $pre;
2013
          $self->_do_walk_down($node->[1], $cb, $depth + 1, $pre);
2014
          $cb->($node->[0], $depth) unless $pre;
2015
      }
2016
  }
2017
  
2018
  sub DESTROY {
2019
      my $self = shift;
2020
      $self->{at_exit}->($self) if $self->{at_exit};
2021
  }
2022
  
2023
  # Utils
2024
  
2025
  sub shell_quote {
2026
      my($self, $stuff) = @_;
2027
      $stuff =~ /^${quote}.+${quote}$/ ? $stuff : ($quote . $stuff . $quote);
2028
  }
2029
  
2030
  sub which {
2031
      my($self, $name) = @_;
2032
      my $exe_ext = $Config{_exe};
2033
      for my $dir (File::Spec->path) {
2034
          my $fullpath = File::Spec->catfile($dir, $name);
2035
          if (-x $fullpath || -x ($fullpath .= $exe_ext)) {
2036
              if ($fullpath =~ /\s/ && $fullpath !~ /^$quote/) {
2037
                  $fullpath = $self->shell_quote($fullpath);
2038
              }
2039
              return $fullpath;
2040
          }
2041
      }
2042
      return;
2043
  }
2044
  
2045
  sub get      { $_[0]->{_backends}{get}->(@_) };
2046
  sub mirror   { $_[0]->{_backends}{mirror}->(@_) };
2047
  sub untar    { $_[0]->{_backends}{untar}->(@_) };
2048
  sub unzip    { $_[0]->{_backends}{unzip}->(@_) };
2049
  
2050
  sub file_get {
2051
      my($self, $uri) = @_;
2052
      open my $fh, "<$uri" or return;
2053
      join '', <$fh>;
2054
  }
2055
  
2056
  sub file_mirror {
2057
      my($self, $uri, $path) = @_;
2058
      File::Copy::copy($uri, $path);
2059
  }
2060
  
2061
  sub init_tools {
2062
      my $self = shift;
2063
  
2064
      return if $self->{initialized}++;
2065
  
2066
      if ($self->{make} = $self->which($Config{make})) {
2067
          $self->chat("You have make $self->{make}\n");
2068
      }
2069
  
2070
      # use --no-lwp if they have a broken LWP, to upgrade LWP
2071
      if ($self->{try_lwp} && eval { require LWP::UserAgent; LWP::UserAgent->VERSION(5.802) }) {
2072
          $self->chat("You have LWP $LWP::VERSION\n");
2073
          my $ua = sub {
2074
              LWP::UserAgent->new(
2075
                  parse_head => 0,
2076
                  env_proxy => 1,
2077
                  agent => "cpanminus/$VERSION",
2078
                  timeout => 30,
2079
                  @_,
2080
              );
2081
          };
2082
          $self->{_backends}{get} = sub {
2083
              my $self = shift;
2084
              my $res = $ua->()->request(HTTP::Request->new(GET => $_[0]));
2085
              return unless $res->is_success;
2086
              return $res->decoded_content;
2087
          };
2088
          $self->{_backends}{mirror} = sub {
2089
              my $self = shift;
2090
              my $res = $ua->()->mirror(@_);
2091
              $res->code;
2092
          };
2093
      } elsif ($self->{try_wget} and my $wget = $self->which('wget')) {
2094
          $self->chat("You have $wget\n");
2095
          $self->{_backends}{get} = sub {
2096
              my($self, $uri) = @_;
2097
              return $self->file_get($uri) if $uri =~ s!^file:/+!/!;
2098
              $self->safeexec( my $fh, $wget, $uri, ( $self->{verbose} ? () : '-q' ), '-O', '-' ) or die "wget $uri: $!";
2099
              local $/;
2100
              <$fh>;
2101
          };
2102
          $self->{_backends}{mirror} = sub {
2103
              my($self, $uri, $path) = @_;
2104
              return $self->file_mirror($uri, $path) if $uri =~ s!^file:/+!/!;
2105
              $self->safeexec( my $fh, $wget, '--retry-connrefused', $uri, ( $self->{verbose} ? () : '-q' ), '-O', $path ) or die "wget $uri: $!";
2106
              local $/;
2107
              <$fh>;
2108
          };
2109
      } elsif ($self->{try_curl} and my $curl = $self->which('curl')) {
2110
          $self->chat("You have $curl\n");
2111
          $self->{_backends}{get} = sub {
2112
              my($self, $uri) = @_;
2113
              return $self->file_get($uri) if $uri =~ s!^file:/+!/!;
2114
              $self->safeexec( my $fh, $curl, '-L', ( $self->{verbose} ? () : '-s' ), $uri ) or die "curl $uri: $!";
2115
              local $/;
2116
              <$fh>;
2117
          };
2118
          $self->{_backends}{mirror} = sub {
2119
              my($self, $uri, $path) = @_;
2120
              return $self->file_mirror($uri, $path) if $uri =~ s!^file:/+!/!;
2121
              $self->safeexec( my $fh, $curl, '-L', $uri, ( $self->{verbose} ? () : '-s' ), '-#', '-o', $path ) or die "curl $uri: $!";
2122
              local $/;
2123
              <$fh>;
2124
          };
2125
      } else {
2126
          require HTTP::Tiny;
2127
          $self->chat("Falling back to HTTP::Tiny $HTTP::Tiny::VERSION\n");
2128
  
2129
          $self->{_backends}{get} = sub {
2130
              my $self = shift;
2131
              my $res = HTTP::Tiny->new->get($_[0]);
2132
              return unless $res->{success};
2133
              return $res->{content};
2134
          };
2135
          $self->{_backends}{mirror} = sub {
2136
              my $self = shift;
2137
              my $res = HTTP::Tiny->new->mirror(@_);
2138
              return $res->{status};
2139
          };
2140
      }
2141
  
2142
      my $tar = $self->which('tar');
2143
      my $tar_ver;
2144
      my $maybe_bad_tar = sub { WIN32 || SUNOS || (($tar_ver = `$tar --version 2>/dev/null`) =~ /GNU.*1\.13/i) };
2145
  
2146
      if ($tar && !$maybe_bad_tar->()) {
2147
          chomp $tar_ver;
2148
          $self->chat("You have $tar: $tar_ver\n");
2149
          $self->{_backends}{untar} = sub {
2150
              my($self, $tarfile) = @_;
2151
  
2152
              my $xf = "xf" . ($self->{verbose} ? 'v' : '');
2153
              my $ar = $tarfile =~ /bz2$/ ? 'j' : 'z';
2154
  
2155
              my($root, @others) = `$tar tf$ar $tarfile`
2156
                  or return undef;
2157
  
2158
              chomp $root;
2159
              $root =~ s!^\./!!;
2160
              $root =~ s{^(.+?)/.*$}{$1};
2161
  
2162
              system "$tar $xf$ar $tarfile";
2163
              return $root if -d $root;
2164
  
2165
              $self->diag_fail("Bad archive: $tarfile");
2166
              return undef;
2167
          }
2168
      } elsif (    $tar
2169
               and my $gzip = $self->which('gzip')
2170
               and my $bzip2 = $self->which('bzip2')) {
2171
          $self->chat("You have $tar, $gzip and $bzip2\n");
2172
          $self->{_backends}{untar} = sub {
2173
              my($self, $tarfile) = @_;
2174
  
2175
              my $x  = "x" . ($self->{verbose} ? 'v' : '') . "f -";
2176
              my $ar = $tarfile =~ /bz2$/ ? $bzip2 : $gzip;
2177
  
2178
              my($root, @others) = `$ar -dc $tarfile | $tar tf -`
2179
                  or return undef;
2180
  
2181
              chomp $root;
2182
              $root =~ s{^(.+?)/.*$}{$1};
2183
  
2184
              system "$ar -dc $tarfile | $tar $x";
2185
              return $root if -d $root;
2186
  
2187
              $self->diag_fail("Bad archive: $tarfile");
2188
              return undef;
2189
          }
2190
      } elsif (eval { require Archive::Tar }) { # uses too much memory!
2191
          $self->chat("Falling back to Archive::Tar $Archive::Tar::VERSION\n");
2192
          $self->{_backends}{untar} = sub {
2193
              my $self = shift;
2194
              my $t = Archive::Tar->new($_[0]);
2195
              my $root = ($t->list_files)[0];
2196
              $root =~ s{^(.+?)/.*$}{$1};
2197
              $t->extract;
2198
              return -d $root ? $root : undef;
2199
          };
2200
      } else {
2201
          $self->{_backends}{untar} = sub {
2202
              die "Failed to extract $_[1] - You need to have tar or Archive::Tar installed.\n";
2203
          };
2204
      }
2205
  
2206
      if (my $unzip = $self->which('unzip')) {
2207
          $self->chat("You have $unzip\n");
2208
          $self->{_backends}{unzip} = sub {
2209
              my($self, $zipfile) = @_;
2210
  
2211
              my $opt = $self->{verbose} ? '' : '-q';
2212
              my(undef, $root, @others) = `$unzip -t $zipfile`
2213
                  or return undef;
2214
  
2215
              chomp $root;
2216
              $root =~ s{^\s+testing:\s+(.+?)/\s+OK$}{$1};
2217
  
2218
              system "$unzip $opt $zipfile";
2219
              return $root if -d $root;
2220
  
2221
              $self->diag_fail("Bad archive: [$root] $zipfile");
2222
              return undef;
2223
          }
2224
      } else {
2225
          $self->{_backends}{unzip} = sub {
2226
              eval { require Archive::Zip }
2227
                  or  die "Failed to extract $_[1] - You need to have unzip or Archive::Zip installed.\n";
2228
              my($self, $file) = @_;
2229
              my $zip = Archive::Zip->new();
2230
              my $status;
2231
              $status = $zip->read($file);
2232
              $self->diag_fail("Read of file[$file] failed")
2233
                  if $status != Archive::Zip::AZ_OK();
2234
              my @members = $zip->members();
2235
              my $root;
2236
              for my $member ( @members ) {
2237
                  my $af = $member->fileName();
2238
                  next if ($af =~ m!^(/|\.\./)!);
2239
                  $root = $af unless $root;
2240
                  $status = $member->extractToFileNamed( $af );
2241
                  $self->diag_fail("Extracting of file[$af] from zipfile[$file failed")
2242
                      if $status != Archive::Zip::AZ_OK();
2243
              }
2244
              return -d $root ? $root : undef;
2245
          };
2246
      }
2247
  }
2248
  
2249
  sub safeexec {
2250
      my $self = shift;
2251
      my $rdr = $_[0] ||= Symbol::gensym();
2252
  
2253
      if (WIN32) {
2254
          my $cmd = join q{ }, map { $self->shell_quote($_) } @_[ 1 .. $#_ ];
2255
          return open( $rdr, "$cmd |" );
2256
      }
2257
  
2258
      if ( my $pid = open( $rdr, '-|' ) ) {
2259
          return $pid;
2260
      }
2261
      elsif ( defined $pid ) {
2262
          exec( @_[ 1 .. $#_ ] );
2263
          exit 1;
2264
      }
2265
      else {
2266
          return;
2267
      }
2268
  }
2269
  
2270
  sub parse_meta {
2271
      my($self, $file) = @_;
2272
      return eval { (Parse::CPAN::Meta::LoadFile($file))[0] } || undef;
2273
  }
2274
  
2275
  sub parse_meta_string {
2276
      my($self, $yaml) = @_;
2277
      return eval { (Parse::CPAN::Meta::Load($yaml))[0] } || undef;
2278
  }
2279
  
2280
  1;
2281
APP_CPANMINUS_SCRIPT
2282

            
2283
$fatpacked{"CPAN/DistnameInfo.pm"} = <<'CPAN_DISTNAMEINFO';
2284
  
2285
  package CPAN::DistnameInfo;
2286
  
2287
  $VERSION = "0.11";
2288
  use strict;
2289
  
2290
  sub distname_info {
2291
    my $file = shift or return;
2292
  
2293
    my ($dist, $version) = $file =~ /^
2294
      ((?:[-+.]*(?:[A-Za-z0-9]+|(?<=\D)_|_(?=\D))*
2295
       (?:
2296
  	[A-Za-z](?=[^A-Za-z]|$)
2297
  	|
2298
  	\d(?=-)
2299
       )(?<![._-][vV])
2300
      )+)(.*)
2301
    $/xs or return ($file,undef,undef);
2302
  
2303
    if ($dist =~ /-undef\z/ and ! length $version) {
2304
      $dist =~ s/-undef\z//;
2305
    }
2306
  
2307
    # Remove potential -withoutworldwriteables suffix
2308
    $version =~ s/-withoutworldwriteables$//;
2309
  
2310
    if ($version =~ /^(-[Vv].*)-(\d.*)/) {
2311
     
2312
      # Catch names like Unicode-Collate-Standard-V3_1_1-0.1
2313
      # where the V3_1_1 is part of the distname
2314
      $dist .= $1;
2315
      $version = $2;
2316
    }
2317
  
2318
    # Normalize the Dist.pm-1.23 convention which CGI.pm and
2319
    # a few others use.
2320
    $dist =~ s{\.pm$}{};
2321
  
2322
    $version = $1
2323
      if !length $version and $dist =~ s/-(\d+\w)$//;
2324
  
2325
    $version = $1 . $version
2326
      if $version =~ /^\d+$/ and $dist =~ s/-(\w+)$//;
2327
  
2328
    if ($version =~ /\d\.\d/) {
2329
      $version =~ s/^[-_.]+//;
2330
    }
2331
    else {
2332
      $version =~ s/^[-_]+//;
2333
    }
2334
  
2335
    my $dev;
2336
    if (length $version) {
2337
      if ($file =~ /^perl-?\d+\.(\d+)(?:\D(\d+))?(-(?:TRIAL|RC)\d+)?$/) {
2338
        $dev = 1 if (($1 > 6 and $1 & 1) or ($2 and $2 >= 50)) or $3;
2339
      }
2340
      elsif ($version =~ /\d\D\d+_\d/ or $version =~ /-TRIAL/) {
2341
        $dev = 1;
2342
      }
2343
    }
2344
    else {
2345
      $version = undef;
2346
    }
2347
  
2348
    ($dist, $version, $dev);
2349
  }
2350
  
2351
  sub new {
2352
    my $class = shift;
2353
    my $distfile = shift;
2354
  
2355
    $distfile =~ s,//+,/,g;
2356
  
2357
    my %info = ( pathname => $distfile );
2358
  
2359
    ($info{filename} = $distfile) =~ s,^(((.*?/)?authors/)?id/)?([A-Z])/(\4[A-Z])/(\5[-A-Z0-9]*)/,,
2360
      and $info{cpanid} = $6;
2361
  
2362
    if ($distfile =~ m,([^/]+)\.(tar\.(?:g?z|bz2)|zip|tgz)$,i) { # support more ?
2363
      $info{distvname} = $1;
2364
      $info{extension} = $2;
2365
    }
2366
  
2367
    @info{qw(dist version beta)} = distname_info($info{distvname});
2368
    $info{maturity} = delete $info{beta} ? 'developer' : 'released';
2369
  
2370
    return bless \%info, $class;
2371
  }
2372
  
2373
  sub dist      { shift->{dist} }
2374
  sub version   { shift->{version} }
2375
  sub maturity  { shift->{maturity} }
2376
  sub filename  { shift->{filename} }
2377
  sub cpanid    { shift->{cpanid} }
2378
  sub distvname { shift->{distvname} }
2379
  sub extension { shift->{extension} }
2380
  sub pathname  { shift->{pathname} }
2381
  
2382
  sub properties { %{ $_[0] } }
2383
  
2384
  1;
2385
  
2386
  __END__
2387
  
2388
CPAN_DISTNAMEINFO
2389

            
2390
$fatpacked{"CPAN/Meta.pm"} = <<'CPAN_META';
2391
  use 5.006;
2392
  use strict;
2393
  use warnings;
2394
  package CPAN::Meta;
2395
  BEGIN {
2396
    $CPAN::Meta::VERSION = '2.110930';
2397
  }
2398
  # ABSTRACT: the distribution metadata for a CPAN dist
2399
  
2400
  
2401
  use Carp qw(carp croak);
2402
  use CPAN::Meta::Feature;
2403
  use CPAN::Meta::Prereqs;
2404
  use CPAN::Meta::Converter;
2405
  use CPAN::Meta::Validator;
2406
  use Parse::CPAN::Meta 1.4400 ();
2407
  
2408
  sub _dclone {
2409
    my $ref = shift;
2410
    my $backend = Parse::CPAN::Meta->json_backend();
2411
    return $backend->new->decode(
2412
      $backend->new->convert_blessed->encode($ref)
2413
    );
2414
  }
2415
  
2416
  
2417
  BEGIN {
2418
    my @STRING_READERS = qw(
2419
      abstract
2420
      description
2421
      dynamic_config
2422
      generated_by
2423
      name
2424
      release_status
2425
      version
2426
    );
2427
  
2428
    no strict 'refs';
2429
    for my $attr (@STRING_READERS) {
2430
      *$attr = sub { $_[0]{ $attr } };
2431
    }
2432
  }
2433
  
2434
  
2435
  BEGIN {
2436
    my @LIST_READERS = qw(
2437
      author
2438
      keywords
2439
      license
2440
    );
2441
  
2442
    no strict 'refs';
2443
    for my $attr (@LIST_READERS) {
2444
      *$attr = sub {
2445
        my $value = $_[0]{ $attr };
2446
        croak "$attr must be called in list context"
2447
          unless wantarray;
2448
        return @{ _dclone($value) } if ref $value;
2449
        return $value;
2450
      };
2451
    }
2452
  }
2453
  
2454
  sub authors  { $_[0]->author }
2455
  sub licenses { $_[0]->license }
2456
  
2457
  
2458
  BEGIN {
2459
    my @MAP_READERS = qw(
2460
      meta-spec
2461
      resources
2462
      provides
2463
      no_index
2464
  
2465
      prereqs
2466
      optional_features
2467
    );
2468
  
2469
    no strict 'refs';
2470
    for my $attr (@MAP_READERS) {
2471
      (my $subname = $attr) =~ s/-/_/;
2472
      *$subname = sub {
2473
        my $value = $_[0]{ $attr };
2474
        return _dclone($value) if $value;
2475
        return {};
2476
      };
2477
    }
2478
  }
2479
  
2480
  
2481
  sub custom_keys {
2482
    return grep { /^x_/i } keys %{$_[0]};
2483
  }
2484
  
2485
  sub custom {
2486
    my ($self, $attr) = @_;
2487
    my $value = $self->{$attr};
2488
    return _dclone($value) if ref $value;
2489
    return $value;
2490
  }
2491
  
2492
  
2493
  sub _new {
2494
    my ($class, $struct, $options) = @_;
2495
    my $self;
2496
  
2497
    if ( $options->{lazy_validation} ) {
2498
      # try to convert to a valid structure; if succeeds, then return it
2499
      my $cmc = CPAN::Meta::Converter->new( $struct );
2500
      $self = $cmc->convert( version => 2 ); # valid or dies
2501
      return bless $self, $class;
2502
    }
2503
    else {
2504
      # validate original struct
2505
      my $cmv = CPAN::Meta::Validator->new( $struct );
2506
      unless ( $cmv->is_valid) {
2507
        die "Invalid metadata structure. Errors: "
2508
          . join(", ", $cmv->errors) . "\n";
2509
      }
2510
    }
2511
  
2512
    # up-convert older spec versions
2513
    my $version = $struct->{'meta-spec'}{version} || '1.0';
2514
    if ( $version == 2 ) {
2515
      $self = $struct;
2516
    }
2517
    else {
2518
      my $cmc = CPAN::Meta::Converter->new( $struct );
2519
      $self = $cmc->convert( version => 2 );
2520
    }
2521
  
2522
    return bless $self, $class;
2523
  }
2524
  
2525
  sub new {
2526
    my ($class, $struct, $options) = @_;
2527
    my $self = eval { $class->_new($struct, $options) };
2528
    croak($@) if $@;
2529
    return $self;
2530
  }
2531
  
2532
  
2533
  sub create {
2534
    my ($class, $struct, $options) = @_;
2535
    my $version = __PACKAGE__->VERSION || 2;
2536
    $struct->{generated_by} ||= __PACKAGE__ . " version $version" ;
2537
    $struct->{'meta-spec'}{version} ||= int($version);
2538
    my $self = eval { $class->_new($struct, $options) };
2539
    croak ($@) if $@;
2540
    return $self;
2541
  }
2542
  
2543
  
2544
  sub load_file {
2545
    my ($class, $file, $options) = @_;
2546
    $options->{lazy_validation} = 1 unless exists $options->{lazy_validation};
2547
  
2548
    croak "load_file() requires a valid, readable filename"
2549
      unless -r $file;
2550
  
2551
    my $self;
2552
    eval {
2553
      my $struct = Parse::CPAN::Meta->load_file( $file );
2554
      $self = $class->_new($struct, $options);
2555
    };
2556
    croak($@) if $@;
2557
    return $self;
2558
  }
2559
  
2560
  
2561
  sub load_yaml_string {
2562
    my ($class, $yaml, $options) = @_;
2563
    $options->{lazy_validation} = 1 unless exists $options->{lazy_validation};
2564
  
2565
    my $self;
2566
    eval {
2567
      my ($struct) = Parse::CPAN::Meta->load_yaml_string( $yaml );
2568
      $self = $class->_new($struct, $options);
2569
    };
2570
    croak($@) if $@;
2571
    return $self;
2572
  }
2573
  
2574
  
2575
  sub load_json_string {
2576
    my ($class, $json, $options) = @_;
2577
    $options->{lazy_validation} = 1 unless exists $options->{lazy_validation};
2578
  
2579
    my $self;
2580
    eval {
2581
      my $struct = Parse::CPAN::Meta->load_json_string( $json );
2582
      $self = $class->_new($struct, $options);
2583
    };
2584
    croak($@) if $@;
2585
    return $self;
2586
  }
2587
  
2588
  
2589
  sub save {
2590
    my ($self, $file, $options) = @_;
2591
  
2592
    my $version = $options->{version} || '2';
2593
    my $layer = $] ge '5.008001' ? ':utf8' : '';
2594
  
2595
    if ( $version ge '2' ) {
2596
      carp "'$file' should end in '.json'"
2597
        unless $file =~ m{\.json$};
2598
    }
2599
    else {
2600
      carp "'$file' should end in '.yml'"
2601
        unless $file =~ m{\.yml$};
2602
    }
2603
  
2604
    my $data = $self->as_string( $options );
2605
    open my $fh, ">$layer", $file
2606
      or die "Error opening '$file' for writing: $!\n";
2607
  
2608
    print {$fh} $data;
2609
    close $fh
2610
      or die "Error closing '$file': $!\n";
2611
  
2612
    return 1;
2613
  }
2614
  
2615
  
2616
  sub meta_spec_version {
2617
    my ($self) = @_;
2618
    return $self->meta_spec->{version};
2619
  }
2620
  
2621
  
2622
  sub effective_prereqs {
2623
    my ($self, $features) = @_;
2624
    $features ||= [];
2625
  
2626
    my $prereq = CPAN::Meta::Prereqs->new($self->prereqs);
2627
  
2628
    return $prereq unless @$features;
2629
  
2630
    my @other = map {; $self->feature($_)->prereqs } @$features;
2631
  
2632
    return $prereq->with_merged_prereqs(\@other);
2633
  }
2634
  
2635
  
2636
  sub should_index_file {
2637
    my ($self, $filename) = @_;
2638
  
2639
    for my $no_index_file (@{ $self->no_index->{file} || [] }) {
2640
      return if $filename eq $no_index_file;
2641
    }
2642
  
2643
    for my $no_index_dir (@{ $self->no_index->{directory} }) {
2644
      $no_index_dir =~ s{$}{/} unless $no_index_dir =~ m{/\z};
2645
      return if index($filename, $no_index_dir) == 0;
2646
    }
2647
  
2648
    return 1;
2649
  }
2650
  
2651
  
2652
  sub should_index_package {
2653
    my ($self, $package) = @_;
2654
  
2655
    for my $no_index_pkg (@{ $self->no_index->{package} || [] }) {
2656
      return if $package eq $no_index_pkg;
2657
    }
2658
  
2659
    for my $no_index_ns (@{ $self->no_index->{namespace} }) {
2660
      return if index($package, "${no_index_ns}::") == 0;
2661
    }
2662
  
2663
    return 1;
2664
  }
2665
  
2666
  
2667
  sub features {
2668
    my ($self) = @_;
2669
  
2670
    my $opt_f = $self->optional_features;
2671
    my @features = map {; CPAN::Meta::Feature->new($_ => $opt_f->{ $_ }) }
2672
                   keys %$opt_f;
2673
  
2674
    return @features;
2675
  }
2676
  
2677
  
2678
  sub feature {
2679
    my ($self, $ident) = @_;
2680
  
2681
    croak "no feature named $ident"
2682
      unless my $f = $self->optional_features->{ $ident };
2683
  
2684
    return CPAN::Meta::Feature->new($ident, $f);
2685
  }
2686
  
2687
  
2688
  sub as_struct {
2689
    my ($self, $options) = @_;
2690
    my $struct = _dclone($self);
2691
    if ( $options->{version} ) {
2692
      my $cmc = CPAN::Meta::Converter->new( $struct );
2693
      $struct = $cmc->convert( version => $options->{version} );
2694
    }
2695
    return $struct;
2696
  }
2697
  
2698
  
2699
  sub as_string {
2700
    my ($self, $options) = @_;
2701
  
2702
    my $version = $options->{version} || '2';
2703
  
2704
    my $struct;
2705
    if ( $self->meta_spec_version ne $version ) {
2706
      my $cmc = CPAN::Meta::Converter->new( $self->as_struct );
2707
      $struct = $cmc->convert( version => $version );
2708
    }
2709
    else {
2710
      $struct = $self->as_struct;
2711
    }
2712
  
2713
    my ($data, $backend);
2714
    if ( $version ge '2' ) {
2715
      $backend = Parse::CPAN::Meta->json_backend();
2716
      $data = $backend->new->pretty->canonical->encode($struct);
2717
    }
2718
    else {
2719
      $backend = Parse::CPAN::Meta->yaml_backend();
2720
      $data = eval { no strict 'refs'; &{"$backend\::Dump"}($struct) };
2721
      if ( $@ ) {
2722
        croak $backend->can('errstr') ? $backend->errstr : $@
2723
      }
2724
    }
2725
  
2726
    return $data;
2727
  }
2728
  
2729
  # Used by JSON::PP, etc. for "convert_blessed"
2730
  sub TO_JSON {
2731
    return { %{ $_[0] } };
2732
  }
2733
  
2734
  1;
2735
  
2736
  
2737
  
2738
  
2739
  __END__
2740
  
2741
  
2742
CPAN_META
2743

            
2744
$fatpacked{"CPAN/Meta/Converter.pm"} = <<'CPAN_META_CONVERTER';
2745
  use 5.006;
2746
  use strict;
2747
  use warnings;
2748
  package CPAN::Meta::Converter;
2749
  BEGIN {
2750
    $CPAN::Meta::Converter::VERSION = '2.110930';
2751
  }
2752
  # ABSTRACT: Convert CPAN distribution metadata structures
2753
  
2754
  
2755
  use CPAN::Meta::Validator;
2756
  use version 0.82 ();
2757
  use Parse::CPAN::Meta 1.4400 ();
2758
  
2759
  sub _dclone {
2760
    my $ref = shift;
2761
    my $backend = Parse::CPAN::Meta->json_backend();
2762
    return $backend->new->decode(
2763
      $backend->new->convert_blessed->encode($ref)
2764
    );
2765
  }
2766
  
2767
  my %known_specs = (
2768
      '2'   => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec',
2769
      '1.4' => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
2770
      '1.3' => 'http://module-build.sourceforge.net/META-spec-v1.3.html',
2771
      '1.2' => 'http://module-build.sourceforge.net/META-spec-v1.2.html',
2772
      '1.1' => 'http://module-build.sourceforge.net/META-spec-v1.1.html',
2773
      '1.0' => 'http://module-build.sourceforge.net/META-spec-v1.0.html'
2774
  );
2775
  
2776
  my @spec_list = sort { $a <=> $b } keys %known_specs;
2777
  my ($LOWEST, $HIGHEST) = @spec_list[0,-1];
2778
  
2779
  #--------------------------------------------------------------------------#
2780
  # converters
2781
  #
2782
  # called as $converter->($element, $field_name, $full_meta, $to_version)
2783
  #
2784
  # defined return value used for field
2785
  # undef return value means field is skipped
2786
  #--------------------------------------------------------------------------#
2787
  
2788
  sub _keep { $_[0] }
2789
  
2790
  sub _keep_or_one { defined($_[0]) ? $_[0] : 1 }
2791
  
2792
  sub _keep_or_zero { defined($_[0]) ? $_[0] : 0 }
2793
  
2794
  sub _keep_or_unknown { defined($_[0]) && length($_[0]) ? $_[0] : "unknown" }
2795
  
2796
  sub _generated_by {
2797
    my $gen = shift;
2798
    my $sig = __PACKAGE__ . " version " . (__PACKAGE__->VERSION || "<dev>");
2799
  
2800
    return $sig unless defined $gen and length $gen;
2801
    return $gen if $gen =~ /(, )\Q$sig/;
2802
    return "$gen, $sig";
2803
  }
2804
  
2805
  sub _listify { ! defined $_[0] ? undef : ref $_[0] eq 'ARRAY' ? $_[0] : [$_[0]] }
2806
  
2807
  sub _prefix_custom {
2808
    my $key = shift;
2809
    $key =~ s/^(?!x_)   # Unless it already starts with x_
2810
               (?:x-?)? # Remove leading x- or x (if present)
2811
             /x_/ix;    # and prepend x_
2812
    return $key;
2813
  }
2814
  
2815
  sub _ucfirst_custom {
2816
    my $key = shift;
2817
    $key = ucfirst $key unless $key =~ /[A-Z]/;
2818
    return $key;
2819
  }
2820
  
2821
  sub _change_meta_spec {
2822
    my ($element, undef, undef, $version) = @_;
2823
    $element->{version} = $version;
2824
    $element->{url} = $known_specs{$version};
2825
    return $element;
2826
  }
2827
  
2828
  my @valid_licenses_1 = (
2829
    'perl',
2830
    'gpl',
2831
    'apache',
2832
    'artistic',
2833
    'artistic_2',
2834
    'lgpl',
2835
    'bsd',
2836
    'gpl',
2837
    'mit',
2838
    'mozilla',
2839
    'open_source',
2840
    'unrestricted',
2841
    'restrictive',
2842
    'unknown',
2843
  );
2844
  
2845
  my %license_map_1 = (
2846
    ( map { $_ => $_ } @valid_licenses_1 ),
2847
    artistic2 => 'artistic_2',
2848
  );
2849
  
2850
  sub _license_1 {
2851
    my ($element) = @_;
2852
    return 'unknown' unless defined $element;
2853
    if ( $license_map_1{lc $element} ) {
2854
      return $license_map_1{lc $element};
2855
    }
2856
    return 'unknown';
2857
  }
2858
  
2859
  my @valid_licenses_2 = qw(
2860
    agpl_3
2861
    apache_1_1
2862
    apache_2_0
2863
    artistic_1
2864
    artistic_2
2865
    bsd
2866
    freebsd
2867
    gfdl_1_2
2868
    gfdl_1_3
2869
    gpl_1
2870
    gpl_2
2871
    gpl_3
2872
    lgpl_2_1
2873
    lgpl_3_0
2874
    mit
2875
    mozilla_1_0
2876
    mozilla_1_1
2877
    openssl
2878
    perl_5
2879
    qpl_1_0
2880
    ssleay
2881
    sun
2882
    zlib
2883
    open_source
2884
    restricted
2885
    unrestricted
2886
    unknown
2887
  );
2888
  
2889
  # The "old" values were defined by Module::Build, and were often vague.  I have
2890
  # made the decisions below based on reading Module::Build::API and how clearly
2891
  # it specifies the version of the license.
2892
  my %license_map_2 = (
2893
    (map { $_ => $_ } @valid_licenses_2),
2894
    apache      => 'apache_2_0',  # clearly stated as 2.0
2895
    artistic    => 'artistic_1',  # clearly stated as 1
2896
    artistic2   => 'artistic_2',  # clearly stated as 2
2897
    gpl         => 'open_source', # we don't know which GPL; punt
2898
    lgpl        => 'open_source', # we don't know which LGPL; punt
2899
    mozilla     => 'open_source', # we don't know which MPL; punt
2900
    perl        => 'perl_5',      # clearly Perl 5
2901
    restrictive => 'restricted',
2902
  );
2903
  
2904
  sub _license_2 {
2905
    my ($element) = @_;
2906
    return [ 'unknown' ] unless defined $element;
2907
    $element = [ $element ] unless ref $element eq 'ARRAY';
2908
    my @new_list;
2909
    for my $lic ( @$element ) {
2910
      next unless defined $lic;
2911
      if ( my $new = $license_map_2{lc $lic} ) {
2912
        push @new_list, $new;
2913
      }
2914
    }
2915
    return @new_list ? \@new_list : [ 'unknown' ];
2916
  }
2917
  
2918
  my %license_downgrade_map = qw(
2919
    agpl_3            open_source
2920
    apache_1_1        apache
2921
    apache_2_0        apache
2922
    artistic_1        artistic
2923
    artistic_2        artistic_2
2924
    bsd               bsd
2925
    freebsd           open_source
2926
    gfdl_1_2          open_source
2927
    gfdl_1_3          open_source
2928
    gpl_1             gpl
2929
    gpl_2             gpl
2930
    gpl_3             gpl
2931
    lgpl_2_1          lgpl
2932
    lgpl_3_0          lgpl
2933
    mit               mit
2934
    mozilla_1_0       mozilla
2935
    mozilla_1_1       mozilla
2936
    openssl           open_source
2937
    perl_5            perl
2938
    qpl_1_0           open_source
2939
    ssleay            open_source
2940
    sun               open_source
2941
    zlib              open_source
2942
    open_source       open_source
2943
    restricted        restrictive
2944
    unrestricted      unrestricted
2945
    unknown           unknown
2946
  );
2947
  
2948
  sub _downgrade_license {
2949
    my ($element) = @_;
2950
    if ( ! defined $element ) {
2951
      return "unknown";
2952
    }
2953
    elsif( ref $element eq 'ARRAY' ) {
2954
      if ( @$element == 1 ) {
2955
        return $license_downgrade_map{$element->[0]} || "unknown";
2956
      }
2957
    }
2958
    elsif ( ! ref $element ) {
2959
      return $license_downgrade_map{$element} || "unknown";
2960
    }
2961
    return "unknown";
2962
  }
2963
  
2964
  my $no_index_spec_1_2 = {
2965
    'file' => \&_listify,
2966
    'dir' => \&_listify,
2967
    'package' => \&_listify,
2968
    'namespace' => \&_listify,
2969
  };
2970
  
2971
  my $no_index_spec_1_3 = {
2972
    'file' => \&_listify,
2973
    'directory' => \&_listify,
2974
    'package' => \&_listify,
2975
    'namespace' => \&_listify,
2976
  };
2977
  
2978
  my $no_index_spec_2 = {
2979
    'file' => \&_listify,
2980
    'directory' => \&_listify,
2981
    'package' => \&_listify,
2982
    'namespace' => \&_listify,
2983
    ':custom'  => \&_prefix_custom,
2984
  };
2985
  
2986
  sub _no_index_1_2 {
2987
    my (undef, undef, $meta) = @_;
2988
    my $no_index = $meta->{no_index} || $meta->{private};
2989
    return unless $no_index;
2990
  
2991
    # cleanup wrong format
2992
    if ( ! ref $no_index ) {
2993
      my $item = $no_index;
2994
      $no_index = { dir => [ $item ], file => [ $item ] };
2995
    }
2996
    elsif ( ref $no_index eq 'ARRAY' ) {
2997
      my $list = $no_index;
2998
      $no_index = { dir => [ @$list ], file => [ @$list ] };
2999
    }
3000
  
3001
    # common mistake: files -> file
3002
    if ( exists $no_index->{files} ) {
3003
      $no_index->{file} = delete $no_index->{file};
3004
    }
3005
    # common mistake: modules -> module
3006
    if ( exists $no_index->{modules} ) {
3007
      $no_index->{module} = delete $no_index->{module};
3008
    }
3009
    return _convert($no_index, $no_index_spec_1_2);
3010
  }
3011
  
3012
  sub _no_index_directory {
3013
    my ($element, $key, $meta, $version) = @_;
3014
    return unless $element;
3015
  
3016
    # cleanup wrong format
3017
    if ( ! ref $element ) {
3018
      my $item = $element;
3019
      $element = { directory => [ $item ], file => [ $item ] };
3020
    }
3021
    elsif ( ref $element eq 'ARRAY' ) {
3022
      my $list = $element;
3023
      $element = { directory => [ @$list ], file => [ @$list ] };
3024
    }
3025
  
3026
    if ( exists $element->{dir} ) {
3027
      $element->{directory} = delete $element->{dir};
3028
    }
3029
    # common mistake: files -> file
3030
    if ( exists $element->{files} ) {
3031
      $element->{file} = delete $element->{file};
3032
    }
3033
    # common mistake: modules -> module
3034
    if ( exists $element->{modules} ) {
3035
      $element->{module} = delete $element->{module};
3036
    }
3037
    my $spec = $version == 2 ? $no_index_spec_2 : $no_index_spec_1_3;
3038
    return _convert($element, $spec);
3039
  }
3040
  
3041
  sub _is_module_name {
3042
    my $mod = shift;
3043
    return unless defined $mod && length $mod;
3044
    return $mod =~ m{^[A-Za-z][A-Za-z0-9_]*(?:::[A-Za-z0-9_]+)*$};
3045
  }
3046
  
3047
  sub _clean_version {
3048
    my ($element, $key, $meta, $to_version) = @_;
3049
    return 0 if ! defined $element;
3050
  
3051
    $element =~ s{^\s*}{};
3052
    $element =~ s{\s*$}{};
3053
    $element =~ s{^\.}{0.};
3054
  
3055
    return 0 if ! length $element;
3056
    return 0 if ( $element eq 'undef' || $element eq '<undef>' );
3057
  
3058
    if ( my $v = eval { version->new($element) } ) {
3059
      return $v->is_qv ? $v->normal : $element;
3060
    }
3061
    else {
3062
      return 0;
3063
    }
3064
  }
3065
  
3066
  sub _version_map {
3067
    my ($element) = @_;
3068
    return undef unless defined $element;
3069
    if ( ref $element eq 'HASH' ) {
3070
      my $new_map = {};
3071
      for my $k ( keys %$element ) {
3072
        next unless _is_module_name($k);
3073
        my $value = $element->{$k};
3074
        if ( ! ( defined $value && length $value ) ) {
3075
          $new_map->{$k} = 0;
3076
        }
3077
        elsif ( $value eq 'undef' || $value eq '<undef>' ) {
3078
          $new_map->{$k} = 0;
3079
        }
3080
        elsif ( _is_module_name( $value ) ) { # some weird, old META have this
3081
          $new_map->{$k} = 0;
3082
          $new_map->{$value} = 0;
3083
        }
3084
        else {
3085
          $new_map->{$k} = _clean_version($value);
3086
        }
3087
      }
3088
      return $new_map;
3089
    }
3090
    elsif ( ref $element eq 'ARRAY' ) {
3091
      my $hashref = { map { $_ => 0 } @$element };
3092
      return _version_map($hashref); # cleanup any weird stuff
3093
    }
3094
    elsif ( ref $element eq '' && length $element ) {
3095
      return { $element => 0 }
3096
    }
3097
    return;
3098
  }
3099
  
3100
  sub _prereqs_from_1 {
3101
    my (undef, undef, $meta) = @_;
3102
    my $prereqs = {};
3103
    for my $phase ( qw/build configure/ ) {
3104
      my $key = "${phase}_requires";
3105
      $prereqs->{$phase}{requires} = _version_map($meta->{$key})
3106
        if $meta->{$key};
3107
    }
3108
    for my $rel ( qw/requires recommends conflicts/ ) {
3109
      $prereqs->{runtime}{$rel} = _version_map($meta->{$rel})
3110
        if $meta->{$rel};
3111
    }
3112
    return $prereqs;
3113
  }
3114
  
3115
  my $prereqs_spec = {
3116
    configure => \&_prereqs_rel,
3117
    build     => \&_prereqs_rel,
3118
    test      => \&_prereqs_rel,
3119
    runtime   => \&_prereqs_rel,
3120
    develop   => \&_prereqs_rel,
3121
    ':custom'  => \&_prefix_custom,
3122
  };
3123
  
3124
  my $relation_spec = {
3125
    requires   => \&_version_map,
3126
    recommends => \&_version_map,
3127
    suggests   => \&_version_map,
3128
    conflicts  => \&_version_map,
3129
    ':custom'  => \&_prefix_custom,
3130
  };
3131
  
3132
  sub _cleanup_prereqs {
3133
    my ($prereqs, $key, $meta, $to_version) = @_;
3134
    return unless $prereqs && ref $prereqs eq 'HASH';
3135
    return _convert( $prereqs, $prereqs_spec, $to_version );
3136
  }
3137
  
3138
  sub _prereqs_rel {
3139
    my ($relation, $key, $meta, $to_version) = @_;
3140
    return unless $relation && ref $relation eq 'HASH';
3141
    return _convert( $relation, $relation_spec, $to_version );
3142
  }
3143
  
3144
  
3145
  BEGIN {
3146
    my @old_prereqs = qw(
3147
      requires
3148
      configure_requires
3149
      recommends
3150
      conflicts
3151
    );
3152
  
3153
    for ( @old_prereqs ) {
3154
      my $sub = "_get_$_";
3155
      my ($phase,$type) = split qr/_/, $_;
3156
      if ( ! defined $type ) {
3157
        $type = $phase;
3158
        $phase = 'runtime';
3159
      }
3160
      no strict 'refs';
3161
      *{$sub} = sub { _extract_prereqs($_[2]->{prereqs},$phase,$type) };
3162
    }
3163
  }
3164
  
3165
  sub _get_build_requires {
3166
    my ($data, $key, $meta) = @_;
3167
  
3168
    my $test_h  = _extract_prereqs($_[2]->{prereqs}, qw(test  requires)) || {};
3169
    my $build_h = _extract_prereqs($_[2]->{prereqs}, qw(build requires)) || {};
3170
  
3171
    require Version::Requirements;
3172
    my $test_req  = Version::Requirements->from_string_hash($test_h);
3173
    my $build_req = Version::Requirements->from_string_hash($build_h);
3174
  
3175
    $test_req->add_requirements($build_req)->as_string_hash;
3176
  }
3177
  
3178
  sub _extract_prereqs {
3179
    my ($prereqs, $phase, $type) = @_;
3180
    return unless ref $prereqs eq 'HASH';
3181
    return $prereqs->{$phase}{$type};
3182
  }
3183
  
3184
  sub _downgrade_optional_features {
3185
    my (undef, undef, $meta) = @_;
3186
    return undef unless exists $meta->{optional_features};
3187
    my $origin = $meta->{optional_features};
3188
    my $features = {};
3189
    for my $name ( keys %$origin ) {
3190
      $features->{$name} = {
3191
        description => $origin->{$name}{description},
3192
        requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','requires'),
3193
        configure_requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','configure_requires'),
3194
        build_requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','build_requires'),
3195
        recommends => _extract_prereqs($origin->{$name}{prereqs},'runtime','recommends'),
3196
        conflicts => _extract_prereqs($origin->{$name}{prereqs},'runtime','conflicts'),
3197
      };
3198
      for my $k (keys %{$features->{$name}} ) {
3199
        delete $features->{$name}{$k} unless defined $features->{$name}{$k};
3200
      }
3201
    }
3202
    return $features;
3203
  }
3204
  
3205
  sub _upgrade_optional_features {
3206
    my (undef, undef, $meta) = @_;
3207
    return undef unless exists $meta->{optional_features};
3208
    my $origin = $meta->{optional_features};
3209
    my $features = {};
3210
    for my $name ( keys %$origin ) {
3211
      $features->{$name} = {
3212
        description => $origin->{$name}{description},
3213
        prereqs => _prereqs_from_1(undef, undef, $origin->{$name}),
3214
      };
3215
      delete $features->{$name}{prereqs}{configure};
3216
    }
3217
    return $features;
3218
  }
3219
  
3220
  my $optional_features_2_spec = {
3221
    description => \&_keep,
3222
    prereqs => \&_cleanup_prereqs,
3223
    ':custom'  => \&_prefix_custom,
3224
  };
3225
  
3226
  sub _feature_2 {
3227
    my ($element, $key, $meta, $to_version) = @_;
3228
    return unless $element && ref $element eq 'HASH';
3229
    _convert( $element, $optional_features_2_spec, $to_version );
3230
  }
3231
  
3232
  sub _cleanup_optional_features_2 {
3233
    my ($element, $key, $meta, $to_version) = @_;
3234
    return unless $element && ref $element eq 'HASH';
3235
    my $new_data = {};
3236
    for my $k ( keys %$element ) {
3237
      $new_data->{$k} = _feature_2( $element->{$k}, $k, $meta, $to_version );
3238
    }
3239
    return unless keys %$new_data;
3240
    return $new_data;
3241
  }
3242
  
3243
  sub _optional_features_1_4 {
3244
    my ($element) = @_;
3245
    return unless $element;
3246
    $element = _optional_features_as_map($element);
3247
    for my $name ( keys %$element ) {
3248
      for my $drop ( qw/requires_packages requires_os excluded_os/ ) {
3249
        delete $element->{$name}{$drop};
3250
      }
3251
    }
3252
    return $element;
3253
  }
3254
  
3255
  sub _optional_features_as_map {
3256
    my ($element) = @_;
3257
    return unless $element;
3258
    if ( ref $element eq 'ARRAY' ) {
3259
      my %map;
3260
      for my $feature ( @$element ) {
3261
        my (@parts) = %$feature;
3262
        $map{$parts[0]} = $parts[1];
3263
      }
3264
      $element = \%map;
3265
    }
3266
    return $element;
3267
  }
3268
  
3269
  sub _is_urlish { defined $_[0] && $_[0] =~ m{\A[-+.a-z0-9]+:.+}i }
3270
  
3271
  sub _url_or_drop {
3272
    my ($element) = @_;
3273
    return $element if _is_urlish($element);
3274
    return;
3275
  }
3276
  
3277
  sub _url_list {
3278
    my ($element) = @_;
3279
    return unless $element;
3280
    $element = _listify( $element );
3281
    $element = [ grep { _is_urlish($_) } @$element ];
3282
    return unless @$element;
3283
    return $element;
3284
  }
3285
  
3286
  sub _author_list {
3287
    my ($element) = @_;
3288
    return [ 'unknown' ] unless $element;
3289
    $element = _listify( $element );
3290
    $element = [ map { defined $_ && length $_ ? $_ : 'unknown' } @$element ];
3291
    return [ 'unknown' ] unless @$element;
3292
    return $element;
3293
  }
3294
  
3295
  my $resource2_upgrade = {
3296
    license    => sub { return _is_urlish($_[0]) ? _listify( $_[0] ) : undef },
3297
    homepage   => \&_url_or_drop,
3298
    bugtracker => sub {
3299
      my ($item) = @_;
3300
      return unless $item;
3301
      if ( $item =~ m{^mailto:(.*)$} ) { return { mailto => $1 } }
3302
      elsif( _is_urlish($item) ) { return { web => $item } }
3303
      else { return undef }
3304
    },
3305
    repository => sub { return _is_urlish($_[0]) ? { url => $_[0] } : undef },
3306
    ':custom'  => \&_prefix_custom,
3307
  };
3308
  
3309
  sub _upgrade_resources_2 {
3310
    my (undef, undef, $meta, $version) = @_;
3311
    return undef unless exists $meta->{resources};
3312
    return _convert($meta->{resources}, $resource2_upgrade);
3313
  }
3314
  
3315
  my $bugtracker2_spec = {
3316
    web => \&_url_or_drop,
3317
    mailto => \&_keep,
3318
    ':custom'  => \&_prefix_custom,
3319
  };
3320
  
3321
  sub _repo_type {
3322
    my ($element, $key, $meta, $to_version) = @_;
3323
    return $element if defined $element;
3324
    return unless exists $meta->{url};
3325
    my $repo_url = $meta->{url};
3326
    for my $type ( qw/git svn/ ) {
3327
      return $type if $repo_url =~ m{\A$type};
3328
    }
3329
    return;
3330
  }
3331
  
3332
  my $repository2_spec = {
3333
    web => \&_url_or_drop,
3334
    url => \&_url_or_drop,
3335
    type => \&_repo_type,
3336
    ':custom'  => \&_prefix_custom,
3337
  };
3338
  
3339
  my $resources2_cleanup = {
3340
    license    => \&_url_list,
3341
    homepage   => \&_url_or_drop,
3342
    bugtracker => sub { ref $_[0] ? _convert( $_[0], $bugtracker2_spec ) : undef },
3343
    repository => sub { my $data = shift; ref $data ? _convert( $data, $repository2_spec ) : undef },
3344
    ':custom'  => \&_prefix_custom,
3345
  };
3346
  
3347
  sub _cleanup_resources_2 {
3348
    my ($resources, $key, $meta, $to_version) = @_;
3349
    return undef unless $resources && ref $resources eq 'HASH';
3350
    return _convert($resources, $resources2_cleanup, $to_version);
3351
  }
3352
  
3353
  my $resource1_spec = {
3354
    license    => \&_url_or_drop,
3355
    homepage   => \&_url_or_drop,
3356
    bugtracker => \&_url_or_drop,
3357
    repository => \&_url_or_drop,
3358
    ':custom'  => \&_keep,
3359
  };
3360
  
3361
  sub _resources_1_3 {
3362
    my (undef, undef, $meta, $version) = @_;
3363
    return undef unless exists $meta->{resources};
3364
    return _convert($meta->{resources}, $resource1_spec);
3365
  }
3366
  
3367
  *_resources_1_4 = *_resources_1_3;
3368
  
3369
  sub _resources_1_2 {
3370
    my (undef, undef, $meta) = @_;
3371
    my $resources = $meta->{resources} || {};
3372
    if ( $meta->{license_url} && ! $resources->{license} ) {
3373
      $resources->{license} = $meta->license_url
3374
        if _is_urlish($meta->{license_url});
3375
    }
3376
    return undef unless keys %$resources;
3377
    return _convert($resources, $resource1_spec);
3378
  }
3379
  
3380
  my $resource_downgrade_spec = {
3381
    license    => sub { return ref $_[0] ? $_[0]->[0] : $_[0] },
3382
    homepage   => \&_url_or_drop,
3383
    bugtracker => sub { return $_[0]->{web} },
3384
    repository => sub { return $_[0]->{url} || $_[0]->{web} },
3385
    ':custom'  => \&_ucfirst_custom,
3386
  };
3387
  
3388
  sub _downgrade_resources {
3389
    my (undef, undef, $meta, $version) = @_;
3390
    return undef unless exists $meta->{resources};
3391
    return _convert($meta->{resources}, $resource_downgrade_spec);
3392
  }
3393
  
3394
  sub _release_status {
3395
    my ($element, undef, $meta) = @_;
3396
    return $element if $element && $element =~ m{\A(?:stable|testing|unstable)\z};
3397
    return _release_status_from_version(undef, undef, $meta);
3398
  }
3399
  
3400
  sub _release_status_from_version {
3401
    my (undef, undef, $meta) = @_;
3402
    my $version = $meta->{version} || '';
3403
    return ( $version =~ /_/ ) ? 'testing' : 'stable';
3404
  }
3405
  
3406
  my $provides_spec = {
3407
    file => \&_keep,
3408
    version => \&_clean_version,
3409
  };
3410
  
3411
  my $provides_spec_2 = {
3412
    file => \&_keep,
3413
    version => \&_clean_version,
3414
    ':custom'  => \&_prefix_custom,
3415
  };
3416
  
3417
  sub _provides {
3418
    my ($element, $key, $meta, $to_version) = @_;
3419
    return unless defined $element && ref $element eq 'HASH';
3420
    my $spec = $to_version == 2 ? $provides_spec_2 : $provides_spec;
3421
    my $new_data = {};
3422
    for my $k ( keys %$element ) {
3423
      $new_data->{$k} = _convert($element->{$k}, $spec, $to_version);
3424
    }
3425
    return $new_data;
3426
  }
3427
  
3428
  sub _convert {
3429
    my ($data, $spec, $to_version) = @_;
3430
  
3431
    my $new_data = {};
3432
    for my $key ( keys %$spec ) {
3433
      next if $key eq ':custom' || $key eq ':drop';
3434
      next unless my $fcn = $spec->{$key};
3435
      die "spec for '$key' is not a coderef"
3436
        unless ref $fcn && ref $fcn eq 'CODE';
3437
      my $new_value = $fcn->($data->{$key}, $key, $data, $to_version);
3438
      $new_data->{$key} = $new_value if defined $new_value;
3439
    }
3440
  
3441
    my $drop_list   = $spec->{':drop'};
3442
    my $customizer  = $spec->{':custom'} || \&_keep;
3443
  
3444
    for my $key ( keys %$data ) {
3445
      next if $drop_list && grep { $key eq $_ } @$drop_list;
3446
      next if exists $spec->{$key}; # we handled it
3447
      $new_data->{ $customizer->($key) } = $data->{$key};
3448
    }
3449
  
3450
    return $new_data;
3451
  }
3452
  
3453
  #--------------------------------------------------------------------------#
3454
  # define converters for each conversion
3455
  #--------------------------------------------------------------------------#
3456
  
3457
  # each converts from prior version
3458
  # special ":custom" field is used for keys not recognized in spec
3459
  my %up_convert = (
3460
    '2-from-1.4' => {
3461
      # PRIOR MANDATORY
3462
      'abstract'            => \&_keep_or_unknown,
3463
      'author'              => \&_author_list,
3464
      'generated_by'        => \&_generated_by,
3465
      'license'             => \&_license_2,
3466
      'meta-spec'           => \&_change_meta_spec,
3467
      'name'                => \&_keep,
3468
      'version'             => \&_keep,
3469
      # CHANGED TO MANDATORY
3470
      'dynamic_config'      => \&_keep_or_one,
3471
      # ADDED MANDATORY
3472
      'release_status'      => \&_release_status_from_version,
3473
      # PRIOR OPTIONAL
3474
      'keywords'            => \&_keep,
3475
      'no_index'            => \&_no_index_directory,
3476
      'optional_features'   => \&_upgrade_optional_features,
3477
      'provides'            => \&_provides,
3478
      'resources'           => \&_upgrade_resources_2,
3479
      # ADDED OPTIONAL
3480
      'description'         => \&_keep,
3481
      'prereqs'             => \&_prereqs_from_1,
3482
  
3483
      # drop these deprecated fields, but only after we convert
3484
      ':drop' => [ qw(
3485
          build_requires
3486
          configure_requires
3487
          conflicts
3488
          distribution_type
3489
          license_url
3490
          private
3491
          recommends
3492
          requires
3493
      ) ],
3494
  
3495
      # other random keys need x_ prefixing
3496
      ':custom'              => \&_prefix_custom,
3497
    },
3498
    '1.4-from-1.3' => {
3499
      # PRIOR MANDATORY
3500
      'abstract'            => \&_keep_or_unknown,
3501
      'author'              => \&_author_list,
3502
      'generated_by'        => \&_generated_by,
3503
      'license'             => \&_license_1,
3504
      'meta-spec'           => \&_change_meta_spec,
3505
      'name'                => \&_keep,
3506
      'version'             => \&_keep,
3507
      # PRIOR OPTIONAL
3508
      'build_requires'      => \&_version_map,
3509
      'conflicts'           => \&_version_map,
3510
      'distribution_type'   => \&_keep,
3511
      'dynamic_config'      => \&_keep_or_one,
3512
      'keywords'            => \&_keep,
3513
      'no_index'            => \&_no_index_directory,
3514
      'optional_features'   => \&_optional_features_1_4,
3515
      'provides'            => \&_provides,
3516
      'recommends'          => \&_version_map,
3517
      'requires'            => \&_version_map,
3518
      'resources'           => \&_resources_1_4,
3519
      # ADDED OPTIONAL
3520
      'configure_requires'  => \&_keep,
3521
  
3522
      # drop these deprecated fields, but only after we convert
3523
      ':drop' => [ qw(
3524
        license_url
3525
        private
3526
      )],
3527
  
3528
      # other random keys are OK if already valid
3529
      ':custom'              => \&_keep
3530
    },
3531
    '1.3-from-1.2' => {
3532
      # PRIOR MANDATORY
3533
      'abstract'            => \&_keep_or_unknown,
3534
      'author'              => \&_author_list,
3535
      'generated_by'        => \&_generated_by,
3536
      'license'             => \&_license_1,
3537
      'meta-spec'           => \&_change_meta_spec,
3538
      'name'                => \&_keep,
3539
      'version'             => \&_keep,
3540
      # PRIOR OPTIONAL
3541
      'build_requires'      => \&_version_map,
3542
      'conflicts'           => \&_version_map,
3543
      'distribution_type'   => \&_keep,
3544
      'dynamic_config'      => \&_keep_or_one,
3545
      'keywords'            => \&_keep,
3546
      'no_index'            => \&_no_index_directory,
3547
      'optional_features'   => \&_optional_features_as_map,
3548
      'provides'            => \&_provides,
3549
      'recommends'          => \&_version_map,
3550
      'requires'            => \&_version_map,
3551
      'resources'           => \&_resources_1_3,
3552
  
3553
      # drop these deprecated fields, but only after we convert
3554
      ':drop' => [ qw(
3555
        license_url
3556
        private
3557
      )],
3558
  
3559
      # other random keys are OK if already valid
3560
      ':custom'              => \&_keep
3561
    },
3562
    '1.2-from-1.1' => {
3563
      # PRIOR MANDATORY
3564
      'version'             => \&_keep,
3565
      # CHANGED TO MANDATORY
3566
      'license'             => \&_license_1,
3567
      'name'                => \&_keep,
3568
      'generated_by'        => \&_generated_by,
3569
      # ADDED MANDATORY
3570
      'abstract'            => \&_keep_or_unknown,
3571
      'author'              => \&_author_list,
3572
      'meta-spec'           => \&_change_meta_spec,
3573
      # PRIOR OPTIONAL
3574
      'build_requires'      => \&_version_map,
3575
      'conflicts'           => \&_version_map,
3576
      'distribution_type'   => \&_keep,
3577
      'dynamic_config'      => \&_keep_or_one,
3578
      'recommends'          => \&_version_map,
3579
      'requires'            => \&_version_map,
3580
      # ADDED OPTIONAL
3581
      'keywords'            => \&_keep,
3582
      'no_index'            => \&_no_index_1_2,
3583
      'optional_features'   => \&_optional_features_as_map,
3584
      'provides'            => \&_provides,
3585
      'resources'           => \&_resources_1_2,
3586
  
3587
      # drop these deprecated fields, but only after we convert
3588
      ':drop' => [ qw(
3589
        license_url
3590
        private
3591
      )],
3592
  
3593
      # other random keys are OK if already valid
3594
      ':custom'              => \&_keep
3595
    },
3596
    '1.1-from-1.0' => {
3597
      # CHANGED TO MANDATORY
3598
      'version'             => \&_keep,
3599
      # IMPLIED MANDATORY
3600
      'name'                => \&_keep,
3601
      # PRIOR OPTIONAL
3602
      'build_requires'      => \&_version_map,
3603
      'conflicts'           => \&_version_map,
3604
      'distribution_type'   => \&_keep,
3605
      'dynamic_config'      => \&_keep_or_one,
3606
      'generated_by'        => \&_generated_by,
3607
      'license'             => \&_license_1,
3608
      'recommends'          => \&_version_map,
3609
      'requires'            => \&_version_map,
3610
      # ADDED OPTIONAL
3611
      'license_url'         => \&_url_or_drop,
3612
      'private'             => \&_keep,
3613
  
3614
      # other random keys are OK if already valid
3615
      ':custom'              => \&_keep
3616
    },
3617
  );
3618
  
3619
  my %down_convert = (
3620
    '1.4-from-2' => {
3621
      # MANDATORY
3622
      'abstract'            => \&_keep_or_unknown,
3623
      'author'              => \&_author_list,
3624
      'generated_by'        => \&_generated_by,
3625
      'license'             => \&_downgrade_license,
3626
      'meta-spec'           => \&_change_meta_spec,
3627
      'name'                => \&_keep,
3628
      'version'             => \&_keep,
3629
      # OPTIONAL
3630
      'build_requires'      => \&_get_build_requires,
3631
      'configure_requires'  => \&_get_configure_requires,
3632
      'conflicts'           => \&_get_conflicts,
3633
      'distribution_type'   => \&_keep,
3634
      'dynamic_config'      => \&_keep_or_one,
3635
      'keywords'            => \&_keep,
3636
      'no_index'            => \&_no_index_directory,
3637
      'optional_features'   => \&_downgrade_optional_features,
3638
      'provides'            => \&_provides,
3639
      'recommends'          => \&_get_recommends,
3640
      'requires'            => \&_get_requires,
3641
      'resources'           => \&_downgrade_resources,
3642
  
3643
      # drop these unsupported fields (after conversion)
3644
      ':drop' => [ qw(
3645
        description
3646
        prereqs
3647
        release_status
3648
      )],
3649
  
3650
      # custom keys will be left unchanged
3651
      ':custom'              => \&_keep
3652
    },
3653
    '1.3-from-1.4' => {
3654
      # MANDATORY
3655
      'abstract'            => \&_keep_or_unknown,
3656
      'author'              => \&_author_list,
3657
      'generated_by'        => \&_generated_by,
3658
      'license'             => \&_license_1,
3659
      'meta-spec'           => \&_change_meta_spec,
3660
      'name'                => \&_keep,
3661
      'version'             => \&_keep,
3662
      # OPTIONAL
3663
      'build_requires'      => \&_version_map,
3664
      'conflicts'           => \&_version_map,
3665
      'distribution_type'   => \&_keep,
3666
      'dynamic_config'      => \&_keep_or_one,
3667
      'keywords'            => \&_keep,
3668
      'no_index'            => \&_no_index_directory,
3669
      'optional_features'   => \&_optional_features_as_map,
3670
      'provides'            => \&_provides,
3671
      'recommends'          => \&_version_map,
3672
      'requires'            => \&_version_map,
3673
      'resources'           => \&_resources_1_3,
3674
  
3675
      # drop these unsupported fields, but only after we convert
3676
      ':drop' => [ qw(
3677
        configure_requires
3678
      )],
3679
  
3680
      # other random keys are OK if already valid
3681
      ':custom'              => \&_keep,
3682
    },
3683
    '1.2-from-1.3' => {
3684
      # MANDATORY
3685
      'abstract'            => \&_keep_or_unknown,
3686
      'author'              => \&_author_list,
3687
      'generated_by'        => \&_generated_by,
3688
      'license'             => \&_license_1,
3689
      'meta-spec'           => \&_change_meta_spec,
3690
      'name'                => \&_keep,
3691
      'version'             => \&_keep,
3692
      # OPTIONAL
3693
      'build_requires'      => \&_version_map,
3694
      'conflicts'           => \&_version_map,
3695
      'distribution_type'   => \&_keep,
3696
      'dynamic_config'      => \&_keep_or_one,
3697
      'keywords'            => \&_keep,
3698
      'no_index'            => \&_no_index_1_2,
3699
      'optional_features'   => \&_optional_features_as_map,
3700
      'provides'            => \&_provides,
3701
      'recommends'          => \&_version_map,
3702
      'requires'            => \&_version_map,
3703
      'resources'           => \&_resources_1_3,
3704
  
3705
      # other random keys are OK if already valid
3706
      ':custom'              => \&_keep,
3707
    },
3708
    '1.1-from-1.2' => {
3709
      # MANDATORY
3710
      'version'             => \&_keep,
3711
      # IMPLIED MANDATORY
3712
      'name'                => \&_keep,
3713
      'meta-spec'           => \&_change_meta_spec,
3714
      # OPTIONAL
3715
      'build_requires'      => \&_version_map,
3716
      'conflicts'           => \&_version_map,
3717
      'distribution_type'   => \&_keep,
3718
      'dynamic_config'      => \&_keep_or_one,
3719
      'generated_by'        => \&_generated_by,
3720
      'license'             => \&_license_1,
3721
      'private'             => \&_keep,
3722
      'recommends'          => \&_version_map,
3723
      'requires'            => \&_version_map,
3724
  
3725
      # drop unsupported fields
3726
      ':drop' => [ qw(
3727
        abstract
3728
        author
3729
        provides
3730
        no_index
3731
        keywords
3732
        resources
3733
      )],
3734
  
3735
      # other random keys are OK if already valid
3736
      ':custom'              => \&_keep,
3737
    },
3738
    '1.0-from-1.1' => {
3739
      # IMPLIED MANDATORY
3740
      'name'                => \&_keep,
3741
      'meta-spec'           => \&_change_meta_spec,
3742
      'version'             => \&_keep,
3743
      # PRIOR OPTIONAL
3744
      'build_requires'      => \&_version_map,
3745
      'conflicts'           => \&_version_map,
3746
      'distribution_type'   => \&_keep,
3747
      'dynamic_config'      => \&_keep_or_one,
3748
      'generated_by'        => \&_generated_by,
3749
      'license'             => \&_license_1,
3750
      'recommends'          => \&_version_map,
3751
      'requires'            => \&_version_map,
3752
  
3753
      # other random keys are OK if already valid
3754
      ':custom'              => \&_keep,
3755
    },
3756
  );
3757
  
3758
  my %cleanup = (
3759
    '2' => {
3760
      # PRIOR MANDATORY
3761
      'abstract'            => \&_keep_or_unknown,
3762
      'author'              => \&_author_list,
3763
      'generated_by'        => \&_generated_by,
3764
      'license'             => \&_license_2,
3765
      'meta-spec'           => \&_change_meta_spec,
3766
      'name'                => \&_keep,
3767
      'version'             => \&_keep,
3768
      # CHANGED TO MANDATORY
3769
      'dynamic_config'      => \&_keep_or_one,
3770
      # ADDED MANDATORY
3771
      'release_status'      => \&_release_status,
3772
      # PRIOR OPTIONAL
3773
      'keywords'            => \&_keep,
3774
      'no_index'            => \&_no_index_directory,
3775
      'optional_features'   => \&_cleanup_optional_features_2,
3776
      'provides'            => \&_provides,
3777
      'resources'           => \&_cleanup_resources_2,
3778
      # ADDED OPTIONAL
3779
      'description'         => \&_keep,
3780
      'prereqs'             => \&_cleanup_prereqs,
3781
  
3782
      # drop these deprecated fields, but only after we convert
3783
      ':drop' => [ qw(
3784
          build_requires
3785
          configure_requires
3786
          conflicts
3787
          distribution_type
3788
          license_url
3789
          private
3790
          recommends
3791
          requires
3792
      ) ],
3793
  
3794
      # other random keys need x_ prefixing
3795
      ':custom'              => \&_prefix_custom,
3796
    },
3797
    '1.4' => {
3798
      # PRIOR MANDATORY
3799
      'abstract'            => \&_keep_or_unknown,
3800
      'author'              => \&_author_list,
3801
      'generated_by'        => \&_generated_by,
3802
      'license'             => \&_license_1,
3803
      'meta-spec'           => \&_change_meta_spec,
3804
      'name'                => \&_keep,
3805
      'version'             => \&_keep,
3806
      # PRIOR OPTIONAL
3807
      'build_requires'      => \&_version_map,
3808
      'conflicts'           => \&_version_map,
3809
      'distribution_type'   => \&_keep,
3810
      'dynamic_config'      => \&_keep_or_one,
3811
      'keywords'            => \&_keep,
3812
      'no_index'            => \&_no_index_directory,
3813
      'optional_features'   => \&_optional_features_1_4,
3814
      'provides'            => \&_provides,
3815
      'recommends'          => \&_version_map,
3816
      'requires'            => \&_version_map,
3817
      'resources'           => \&_resources_1_4,
3818
      # ADDED OPTIONAL
3819
      'configure_requires'  => \&_keep,
3820
  
3821
      # other random keys are OK if already valid
3822
      ':custom'             => \&_keep
3823
    },
3824
    '1.3' => {
3825
      # PRIOR MANDATORY
3826
      'abstract'            => \&_keep_or_unknown,
3827
      'author'              => \&_author_list,
3828
      'generated_by'        => \&_generated_by,
3829
      'license'             => \&_license_1,
3830
      'meta-spec'           => \&_change_meta_spec,
3831
      'name'                => \&_keep,
3832
      'version'             => \&_keep,
3833
      # PRIOR OPTIONAL
3834
      'build_requires'      => \&_version_map,
3835
      'conflicts'           => \&_version_map,
3836
      'distribution_type'   => \&_keep,
3837
      'dynamic_config'      => \&_keep_or_one,
3838
      'keywords'            => \&_keep,
3839
      'no_index'            => \&_no_index_directory,
3840
      'optional_features'   => \&_optional_features_as_map,
3841
      'provides'            => \&_provides,
3842
      'recommends'          => \&_version_map,
3843
      'requires'            => \&_version_map,
3844
      'resources'           => \&_resources_1_3,
3845
  
3846
      # other random keys are OK if already valid
3847
      ':custom'             => \&_keep
3848
    },
3849
    '1.2' => {
3850
      # PRIOR MANDATORY
3851
      'version'             => \&_keep,
3852
      # CHANGED TO MANDATORY
3853
      'license'             => \&_license_1,
3854
      'name'                => \&_keep,
3855
      'generated_by'        => \&_generated_by,
3856
      # ADDED MANDATORY
3857
      'abstract'            => \&_keep_or_unknown,
3858
      'author'              => \&_author_list,
3859
      'meta-spec'           => \&_change_meta_spec,
3860
      # PRIOR OPTIONAL
3861
      'build_requires'      => \&_version_map,
3862
      'conflicts'           => \&_version_map,
3863
      'distribution_type'   => \&_keep,
3864
      'dynamic_config'      => \&_keep_or_one,
3865
      'recommends'          => \&_version_map,
3866
      'requires'            => \&_version_map,
3867
      # ADDED OPTIONAL
3868
      'keywords'            => \&_keep,
3869
      'no_index'            => \&_no_index_1_2,
3870
      'optional_features'   => \&_optional_features_as_map,
3871
      'provides'            => \&_provides,
3872
      'resources'           => \&_resources_1_2,
3873
  
3874
      # other random keys are OK if already valid
3875
      ':custom'             => \&_keep
3876
    },
3877
    '1.1' => {
3878
      # CHANGED TO MANDATORY
3879
      'version'             => \&_keep,
3880
      # IMPLIED MANDATORY
3881
      'name'                => \&_keep,
3882
      'meta-spec'           => \&_change_meta_spec,
3883
      # PRIOR OPTIONAL
3884
      'build_requires'      => \&_version_map,
3885
      'conflicts'           => \&_version_map,
3886
      'distribution_type'   => \&_keep,
3887
      'dynamic_config'      => \&_keep_or_one,
3888
      'generated_by'        => \&_generated_by,
3889
      'license'             => \&_license_1,
3890
      'recommends'          => \&_version_map,
3891
      'requires'            => \&_version_map,
3892
      # ADDED OPTIONAL
3893
      'license_url'         => \&_url_or_drop,
3894
      'private'             => \&_keep,
3895
  
3896
      # other random keys are OK if already valid
3897
      ':custom'             => \&_keep
3898
    },
3899
    '1.0' => {
3900
      # IMPLIED MANDATORY
3901
      'name'                => \&_keep,
3902
      'meta-spec'           => \&_change_meta_spec,
3903
      'version'             => \&_keep,
3904
      # IMPLIED OPTIONAL
3905
      'build_requires'      => \&_version_map,
3906
      'conflicts'           => \&_version_map,
3907
      'distribution_type'   => \&_keep,
3908
      'dynamic_config'      => \&_keep_or_one,
3909
      'generated_by'        => \&_generated_by,
3910
      'license'             => \&_license_1,
3911
      'recommends'          => \&_version_map,
3912
      'requires'            => \&_version_map,
3913
  
3914
      # other random keys are OK if already valid
3915
      ':custom'             => \&_keep,
3916
    },
3917
  );
3918
  
3919
  #--------------------------------------------------------------------------#
3920
  # Code
3921
  #--------------------------------------------------------------------------#
3922
  
3923
  
3924
  sub new {
3925
    my ($class,$data) = @_;
3926
  
3927
    # create an attributes hash
3928
    my $self = {
3929
      'data'    => $data,
3930
      'spec'    => $data->{'meta-spec'}{'version'} || "1.0",
3931
    };
3932
  
3933
    # create the object
3934
    return bless $self, $class;
3935
  }
3936
  
3937
  
3938
  sub convert {
3939
    my ($self, %args) = @_;
3940
    my $args = { %args };
3941
  
3942
    my $new_version = $args->{version} || $HIGHEST;
3943
  
3944
    my ($old_version) = $self->{spec};
3945
    my $converted = _dclone($self->{data});
3946
  
3947
    if ( $old_version == $new_version ) {
3948
      $converted = _convert( $converted, $cleanup{$old_version}, $old_version );
3949
      my $cmv = CPAN::Meta::Validator->new( $converted );
3950
      unless ( $cmv->is_valid ) {
3951
        my $errs = join("\n", $cmv->errors);
3952
        die "Failed to clean-up $old_version metadata. Errors:\n$errs\n";
3953
      }
3954
      return $converted;
3955
    }
3956
    elsif ( $old_version > $new_version )  {
3957
      my @vers = sort { $b <=> $a } keys %known_specs;
3958
      for my $i ( 0 .. $#vers-1 ) {
3959
        next if $vers[$i] > $old_version;
3960
        last if $vers[$i+1] < $new_version;
3961
        my $spec_string = "$vers[$i+1]-from-$vers[$i]";
3962
        $converted = _convert( $converted, $down_convert{$spec_string}, $vers[$i+1] );
3963
        my $cmv = CPAN::Meta::Validator->new( $converted );
3964
        unless ( $cmv->is_valid ) {
3965
          my $errs = join("\n", $cmv->errors);
3966
          die "Failed to downconvert metadata to $vers[$i+1]. Errors:\n$errs\n";
3967
        }
3968
      }
3969
      return $converted;
3970
    }
3971
    else {
3972
      my @vers = sort { $a <=> $b } keys %known_specs;
3973
      for my $i ( 0 .. $#vers-1 ) {
3974
        next if $vers[$i] < $old_version;
3975
        last if $vers[$i+1] > $new_version;
3976
        my $spec_string = "$vers[$i+1]-from-$vers[$i]";
3977
        $converted = _convert( $converted, $up_convert{$spec_string}, $vers[$i+1] );
3978
        my $cmv = CPAN::Meta::Validator->new( $converted );
3979
        unless ( $cmv->is_valid ) {
3980
          my $errs = join("\n", $cmv->errors);
3981
          die "Failed to upconvert metadata to $vers[$i+1]. Errors:\n$errs\n";
3982
        }
3983
      }
3984
      return $converted;
3985
    }
3986
  }
3987
  
3988
  1;
3989
  
3990
  
3991
  
3992
  
3993
  __END__
3994
  
3995
  
3996
CPAN_META_CONVERTER
3997

            
3998
$fatpacked{"CPAN/Meta/Feature.pm"} = <<'CPAN_META_FEATURE';
3999
  use 5.006;
4000
  use strict;
4001
  use warnings;
4002
  package CPAN::Meta::Feature;
4003
  BEGIN {
4004
    $CPAN::Meta::Feature::VERSION = '2.110930';
4005
  }
4006
  # ABSTRACT: an optional feature provided by a CPAN distribution
4007
  
4008
  use CPAN::Meta::Prereqs;
4009
  
4010
  
4011
  sub new {
4012
    my ($class, $identifier, $spec) = @_;
4013
  
4014
    my %guts = (
4015
      identifier  => $identifier,
4016
      description => $spec->{description},
4017
      prereqs     => CPAN::Meta::Prereqs->new($spec->{prereqs}),
4018
    );
4019
  
4020
    bless \%guts => $class;
4021
  }
4022
  
4023
  
4024
  sub identifier  { $_[0]{identifier}  }
4025
  
4026
  
4027
  sub description { $_[0]{description} }
4028
  
4029
  
4030
  sub prereqs     { $_[0]{prereqs} }
4031
  
4032
  1;
4033
  
4034
  
4035
  
4036
  
4037
  __END__
4038
  
4039
  
4040
  
4041
CPAN_META_FEATURE
4042

            
4043
$fatpacked{"CPAN/Meta/History.pm"} = <<'CPAN_META_HISTORY';
4044
  # vi:tw=72
4045
  use 5.006;
4046
  use strict;
4047
  use warnings;
4048
  package CPAN::Meta::History;
4049
  BEGIN {
4050
    $CPAN::Meta::History::VERSION = '2.110930';
4051
  }
4052
  # ABSTRACT: history of CPAN Meta Spec changes
4053
  1;
4054
  
4055
  
4056
  
4057
  __END__
4058
  =pod
4059
  
4060
CPAN_META_HISTORY
4061

            
4062
$fatpacked{"CPAN/Meta/Prereqs.pm"} = <<'CPAN_META_PREREQS';
4063
  use 5.006;
4064
  use strict;
4065
  use warnings;
4066
  package CPAN::Meta::Prereqs;
4067
  BEGIN {
4068
    $CPAN::Meta::Prereqs::VERSION = '2.110930';
4069
  }
4070
  # ABSTRACT: a set of distribution prerequisites by phase and type
4071
  
4072
  
4073
  use Carp qw(confess);
4074
  use Scalar::Util qw(blessed);
4075
  use Version::Requirements 0.101020; # finalize
4076
  
4077
  
4078
  sub __legal_phases { qw(configure build test runtime develop)   }
4079
  sub __legal_types  { qw(requires recommends suggests conflicts) }
4080
  
4081
  # expect a prereq spec from META.json -- rjbs, 2010-04-11
4082
  sub new {
4083
    my ($class, $prereq_spec) = @_;
4084
    $prereq_spec ||= {};
4085
  
4086
    my %is_legal_phase = map {; $_ => 1 } $class->__legal_phases;
4087
    my %is_legal_type  = map {; $_ => 1 } $class->__legal_types;
4088
  
4089
    my %guts;
4090
    PHASE: for my $phase (keys %$prereq_spec) {
4091
      next PHASE unless $phase =~ /\Ax_/i or $is_legal_phase{$phase};
4092
  
4093
      my $phase_spec = $prereq_spec->{ $phase };
4094
      next PHASE unless keys %$phase_spec;
4095
  
4096
      TYPE: for my $type (keys %$phase_spec) {
4097
        next TYPE unless $type =~ /\Ax_/i or $is_legal_type{$type};
4098
  
4099
        my $spec = $phase_spec->{ $type };
4100
  
4101
        next TYPE unless keys %$spec;
4102
  
4103
        $guts{prereqs}{$phase}{$type} = Version::Requirements->from_string_hash(
4104
          $spec
4105
        );
4106
      }
4107
    }
4108
  
4109
    return bless \%guts => $class;
4110
  }
4111
  
4112
  
4113
  sub requirements_for {
4114
    my ($self, $phase, $type) = @_;
4115
  
4116
    confess "requirements_for called without phase" unless defined $phase;
4117
    confess "requirements_for called without type"  unless defined $type;
4118
  
4119
    unless ($phase =~ /\Ax_/i or grep { $phase eq $_ } $self->__legal_phases) {
4120
      confess "requested requirements for unknown phase: $phase";
4121
    }
4122
  
4123
    unless ($type =~ /\Ax_/i or grep { $type eq $_ } $self->__legal_types) {
4124
      confess "requested requirements for unknown type: $type";
4125
    }
4126
  
4127
    my $req = ($self->{prereqs}{$phase}{$type} ||= Version::Requirements->new);
4128
  
4129
    $req->finalize if $self->is_finalized;
4130
  
4131
    return $req;
4132
  }
4133
  
4134
  
4135
  sub with_merged_prereqs {
4136
    my ($self, $other) = @_;
4137
  
4138
    my @other = blessed($other) ? $other : @$other;
4139
  
4140
    my @prereq_objs = ($self, @other);
4141
  
4142
    my %new_arg;
4143
  
4144
    for my $phase ($self->__legal_phases) {
4145
      for my $type ($self->__legal_types) {
4146
        my $req = Version::Requirements->new;
4147
  
4148
        for my $prereq (@prereq_objs) {
4149
          my $this_req = $prereq->requirements_for($phase, $type);
4150
          next unless $this_req->required_modules;
4151
  
4152
          $req->add_requirements($this_req);
4153
        }
4154
  
4155
        next unless $req->required_modules;
4156
  
4157
        $new_arg{ $phase }{ $type } = $req->as_string_hash;
4158
      }
4159
    }
4160
  
4161
    return (ref $self)->new(\%new_arg);
4162
  }
4163
  
4164
  
4165
  sub as_string_hash {
4166
    my ($self) = @_;
4167
  
4168
    my %hash;
4169
  
4170
    for my $phase ($self->__legal_phases) {
4171
      for my $type ($self->__legal_types) {
4172
        my $req = $self->requirements_for($phase, $type);
4173
        next unless $req->required_modules;
4174
  
4175
        $hash{ $phase }{ $type } = $req->as_string_hash;
4176
      }
4177
    }
4178
  
4179
    return \%hash;
4180
  }
4181
  
4182
  
4183
  sub is_finalized { $_[0]{finalized} }
4184
  
4185
  
4186
  sub finalize {
4187
    my ($self) = @_;
4188
  
4189
    $self->{finalized} = 1;
4190
  
4191
    for my $phase (keys %{ $self->{prereqs} }) {
4192
      $_->finalize for values %{ $self->{prereqs}{$phase} };
4193
    }
4194
  }
4195
  
4196
  
4197
  sub clone {
4198
    my ($self) = @_;
4199
  
4200
    my $clone = (ref $self)->new( $self->as_string_hash );
4201
  }
4202
  
4203
  1;
4204
  
4205
  
4206
  
4207
  
4208
  __END__
4209
  
4210
  
4211
  
4212
CPAN_META_PREREQS
4213

            
4214
$fatpacked{"CPAN/Meta/Spec.pm"} = <<'CPAN_META_SPEC';
4215
  # vi:tw=72
4216
  use 5.006;
4217
  use strict;
4218
  use warnings;
4219
  package CPAN::Meta::Spec;
4220
  BEGIN {
4221
    $CPAN::Meta::Spec::VERSION = '2.110930';
4222
  }
4223
  # ABSTRACT: specification for CPAN distribution metadata
4224
  1;
4225
  
4226
  
4227
  
4228
  __END__
4229
  =pod
4230
  
4231
CPAN_META_SPEC
4232

            
4233
$fatpacked{"CPAN/Meta/Validator.pm"} = <<'CPAN_META_VALIDATOR';
4234
  use 5.006;
4235
  use strict;
4236
  use warnings;
4237
  package CPAN::Meta::Validator;
4238
  BEGIN {
4239
    $CPAN::Meta::Validator::VERSION = '2.110930';
4240
  }
4241
  # ABSTRACT: validate CPAN distribution metadata structures
4242
  
4243
  
4244
  #--------------------------------------------------------------------------#
4245
  # This code copied and adapted from Test::CPAN::Meta
4246
  # by Barbie, <barbie@cpan.org> for Miss Barbell Productions,
4247
  # L<http://www.missbarbell.co.uk>
4248
  #--------------------------------------------------------------------------#
4249
  
4250
  #--------------------------------------------------------------------------#
4251
  # Specification Definitions
4252
  #--------------------------------------------------------------------------#
4253
  
4254
  my %known_specs = (
4255
      '1.4' => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
4256
      '1.3' => 'http://module-build.sourceforge.net/META-spec-v1.3.html',
4257
      '1.2' => 'http://module-build.sourceforge.net/META-spec-v1.2.html',
4258
      '1.1' => 'http://module-build.sourceforge.net/META-spec-v1.1.html',
4259
      '1.0' => 'http://module-build.sourceforge.net/META-spec-v1.0.html'
4260
  );
4261
  my %known_urls = map {$known_specs{$_} => $_} keys %known_specs;
4262
  
4263
  my $module_map1 = { 'map' => { ':key' => { name => \&module, value => \&exversion } } };
4264
  
4265
  my $module_map2 = { 'map' => { ':key' => { name => \&module, value => \&version   } } };
4266
  
4267
  my $no_index_2 = {
4268
      'map'       => { file       => { list => { value => \&string } },
4269
                       directory  => { list => { value => \&string } },
4270
                       'package'  => { list => { value => \&string } },
4271
                       namespace  => { list => { value => \&string } },
4272
                      ':key'      => { name => \&custom_2, value => \&anything },
4273
      }
4274
  };
4275
  
4276
  my $no_index_1_3 = {
4277
      'map'       => { file       => { list => { value => \&string } },
4278
                       directory  => { list => { value => \&string } },
4279
                       'package'  => { list => { value => \&string } },
4280
                       namespace  => { list => { value => \&string } },
4281
                       ':key'     => { name => \&string, value => \&anything },
4282
      }
4283
  };
4284
  
4285
  my $no_index_1_2 = {
4286
      'map'       => { file       => { list => { value => \&string } },
4287
                       dir        => { list => { value => \&string } },
4288
                       'package'  => { list => { value => \&string } },
4289
                       namespace  => { list => { value => \&string } },
4290
                       ':key'     => { name => \&string, value => \&anything },
4291
      }
4292
  };
4293
  
4294
  my $no_index_1_1 = {
4295
      'map'       => { ':key'     => { name => \&string, list => { value => \&string } },
4296
      }
4297
  };
4298
  
4299
  my $prereq_map = {
4300
    map => {
4301
      ':key' => {
4302
        name => \&phase,
4303
        'map' => {
4304
          ':key'  => {
4305
            name => \&relation,
4306
            %$module_map1,
4307
          },
4308
        },
4309
      }
4310
    },
4311
  };
4312
  
4313
  my %definitions = (
4314
    '2' => {
4315
      # REQUIRED
4316
      'abstract'            => { mandatory => 1, value => \&string  },
4317
      'author'              => { mandatory => 1, lazylist => { value => \&string } },
4318
      'dynamic_config'      => { mandatory => 1, value => \&boolean },
4319
      'generated_by'        => { mandatory => 1, value => \&string  },
4320
      'license'             => { mandatory => 1, lazylist => { value => \&license } },
4321
      'meta-spec' => {
4322
        mandatory => 1,
4323
        'map' => {
4324
          version => { mandatory => 1, value => \&version},
4325
          url     => { value => \&url },
4326
          ':key' => { name => \&custom_2, value => \&anything },
4327
        }
4328
      },
4329
      'name'                => { mandatory => 1, value => \&string  },
4330
      'release_status'      => { mandatory => 1, value => \&release_status },
4331
      'version'             => { mandatory => 1, value => \&version },
4332
  
4333
      # OPTIONAL
4334
      'description' => { value => \&string },
4335
      'keywords'    => { lazylist => { value => \&string } },
4336
      'no_index'    => $no_index_2,
4337
      'optional_features'   => {
4338
        'map'       => {
4339
          ':key'  => {
4340
            name => \&string,
4341
            'map'   => {
4342
              description        => { value => \&string },
4343
              prereqs => $prereq_map,
4344
              ':key' => { name => \&custom_2, value => \&anything },
4345
            }
4346
          }
4347
        }
4348
      },
4349
      'prereqs' => $prereq_map,
4350
      'provides'    => {
4351
        'map'       => {
4352
          ':key' => {
4353
            name  => \&module,
4354
            'map' => {
4355
              file    => { mandatory => 1, value => \&file },
4356
              version => { value => \&version },
4357
              ':key' => { name => \&custom_2, value => \&anything },
4358
            }
4359
          }
4360
        }
4361
      },
4362
      'resources'   => {
4363
        'map'       => {
4364
          license    => { lazylist => { value => \&url } },
4365
          homepage   => { value => \&url },
4366
          bugtracker => {
4367
            'map' => {
4368
              web => { value => \&url },
4369
              mailto => { value => \&string},
4370
              ':key' => { name => \&custom_2, value => \&anything },
4371
            }
4372
          },
4373
          repository => {
4374
            'map' => {
4375
              web => { value => \&url },
4376
              url => { value => \&url },
4377
              type => { value => \&string },
4378
              ':key' => { name => \&custom_2, value => \&anything },
4379
            }
4380
          },
4381
          ':key'     => { value => \&string, name => \&custom_2 },
4382
        }
4383
      },
4384
  
4385
      # CUSTOM -- additional user defined key/value pairs
4386
      # note we can only validate the key name, as the structure is user defined
4387
      ':key'        => { name => \&custom_2, value => \&anything },
4388
    },
4389
  
4390
  '1.4' => {
4391
    'meta-spec'           => {
4392
      mandatory => 1,
4393
      'map' => {
4394
        version => { mandatory => 1, value => \&version},
4395
        url     => { mandatory => 1, value => \&urlspec },
4396
        ':key'  => { name => \&string, value => \&anything },
4397
      },
4398
    },
4399
  
4400
    'name'                => { mandatory => 1, value => \&string  },
4401
    'version'             => { mandatory => 1, value => \&version },
4402
    'abstract'            => { mandatory => 1, value => \&string  },
4403
    'author'              => { mandatory => 1, list  => { value => \&string } },
4404
    'license'             => { mandatory => 1, value => \&license },
4405
    'generated_by'        => { mandatory => 1, value => \&string  },
4406
  
4407
    'distribution_type'   => { value => \&string  },
4408
    'dynamic_config'      => { value => \&boolean },
4409
  
4410
    'requires'            => $module_map1,
4411
    'recommends'          => $module_map1,
4412
    'build_requires'      => $module_map1,
4413
    'configure_requires'  => $module_map1,
4414
    'conflicts'           => $module_map2,
4415
  
4416
    'optional_features'   => {
4417
      'map'       => {
4418
          ':key'  => { name => \&string,
4419
              'map'   => { description        => { value => \&string },
4420
                           requires           => $module_map1,
4421
                           recommends         => $module_map1,
4422
                           build_requires     => $module_map1,
4423
                           conflicts          => $module_map2,
4424
                           ':key'  => { name => \&string, value => \&anything },
4425
              }
4426
          }
4427
       }
4428
    },
4429
  
4430
    'provides'    => {
4431
      'map'       => {
4432
        ':key' => { name  => \&module,
4433
          'map' => {
4434
            file    => { mandatory => 1, value => \&file },
4435
            version => { value => \&version },
4436
            ':key'  => { name => \&string, value => \&anything },
4437
          }
4438
        }
4439
      }
4440
    },
4441
  
4442
    'no_index'    => $no_index_1_3,
4443
    'private'     => $no_index_1_3,
4444
  
4445
    'keywords'    => { list => { value => \&string } },
4446
  
4447
    'resources'   => {
4448
      'map'       => { license    => { value => \&url },
4449
                       homepage   => { value => \&url },
4450
                       bugtracker => { value => \&url },
4451
                       repository => { value => \&url },
4452
                       ':key'     => { value => \&string, name => \&custom_1 },
4453
      }
4454
    },
4455
  
4456
    # additional user defined key/value pairs
4457
    # note we can only validate the key name, as the structure is user defined
4458
    ':key'        => { name => \&string, value => \&anything },
4459
  },
4460
  
4461
  '1.3' => {
4462
    'meta-spec'           => {
4463
      mandatory => 1,
4464
      'map' => {
4465
        version => { mandatory => 1, value => \&version},
4466
        url     => { mandatory => 1, value => \&urlspec },
4467
        ':key'  => { name => \&string, value => \&anything },
4468
      },
4469
    },
4470
  
4471
    'name'                => { mandatory => 1, value => \&string  },
4472
    'version'             => { mandatory => 1, value => \&version },
4473
    'abstract'            => { mandatory => 1, value => \&string  },
4474
    'author'              => { mandatory => 1, list  => { value => \&string } },
4475
    'license'             => { mandatory => 1, value => \&license },
4476
    'generated_by'        => { mandatory => 1, value => \&string  },
4477
  
4478
    'distribution_type'   => { value => \&string  },
4479
    'dynamic_config'      => { value => \&boolean },
4480
  
4481
    'requires'            => $module_map1,
4482
    'recommends'          => $module_map1,
4483
    'build_requires'      => $module_map1,
4484
    'conflicts'           => $module_map2,
4485
  
4486
    'optional_features'   => {
4487
      'map'       => {
4488
          ':key'  => { name => \&string,
4489
              'map'   => { description        => { value => \&string },
4490
                           requires           => $module_map1,
4491
                           recommends         => $module_map1,
4492
                           build_requires     => $module_map1,
4493
                           conflicts          => $module_map2,
4494
                           ':key'  => { name => \&string, value => \&anything },
4495
              }
4496
          }
4497
       }
4498
    },
4499
  
4500
    'provides'    => {
4501
      'map'       => {
4502
        ':key' => { name  => \&module,
4503
          'map' => {
4504
            file    => { mandatory => 1, value => \&file },
4505
            version => { value => \&version },
4506
            ':key'  => { name => \&string, value => \&anything },
4507
          }
4508
        }
4509
      }
4510
    },
4511
  
4512
  
4513
    'no_index'    => $no_index_1_3,
4514
    'private'     => $no_index_1_3,
4515
  
4516
    'keywords'    => { list => { value => \&string } },
4517
  
4518
    'resources'   => {
4519
      'map'       => { license    => { value => \&url },
4520
                       homepage   => { value => \&url },
4521
                       bugtracker => { value => \&url },
4522
                       repository => { value => \&url },
4523
                       ':key'     => { value => \&string, name => \&custom_1 },
4524
      }
4525
    },
4526
  
4527
    # additional user defined key/value pairs
4528
    # note we can only validate the key name, as the structure is user defined
4529
    ':key'        => { name => \&string, value => \&anything },
4530
  },
4531
  
4532
  # v1.2 is misleading, it seems to assume that a number of fields where created
4533
  # within v1.1, when they were created within v1.2. This may have been an
4534
  # original mistake, and that a v1.1 was retro fitted into the timeline, when
4535
  # v1.2 was originally slated as v1.1. But I could be wrong ;)
4536
  '1.2' => {
4537
    'meta-spec'           => {
4538
      mandatory => 1,
4539
      'map' => {
4540
        version => { mandatory => 1, value => \&version},
4541
        url     => { mandatory => 1, value => \&urlspec },
4542
        ':key'  => { name => \&string, value => \&anything },
4543
      },
4544
    },
4545
  
4546
  
4547
    'name'                => { mandatory => 1, value => \&string  },
4548
    'version'             => { mandatory => 1, value => \&version },
4549
    'license'             => { mandatory => 1, value => \&license },
4550
    'generated_by'        => { mandatory => 1, value => \&string  },
4551
    'author'              => { mandatory => 1, list => { value => \&string } },
4552
    'abstract'            => { mandatory => 1, value => \&string  },
4553
  
4554
    'distribution_type'   => { value => \&string  },
4555
    'dynamic_config'      => { value => \&boolean },
4556
  
4557
    'keywords'            => { list => { value => \&string } },
4558
  
4559
    'private'             => $no_index_1_2,
4560
    '$no_index'           => $no_index_1_2,
4561
  
4562
    'requires'            => $module_map1,
4563
    'recommends'          => $module_map1,
4564
    'build_requires'      => $module_map1,
4565
    'conflicts'           => $module_map2,
4566
  
4567
    'optional_features'   => {
4568
      'map'       => {
4569
          ':key'  => { name => \&string,
4570
              'map'   => { description        => { value => \&string },
4571
                           requires           => $module_map1,
4572
                           recommends         => $module_map1,
4573
                           build_requires     => $module_map1,
4574
                           conflicts          => $module_map2,
4575
                           ':key'  => { name => \&string, value => \&anything },
4576
              }
4577
          }
4578
       }
4579
    },
4580
  
4581
    'provides'    => {
4582
      'map'       => {
4583
        ':key' => { name  => \&module,
4584
          'map' => {
4585
            file    => { mandatory => 1, value => \&file },
4586
            version => { value => \&version },
4587
            ':key'  => { name => \&string, value => \&anything },
4588
          }
4589
        }
4590
      }
4591
    },
4592
  
4593
    'resources'   => {
4594
      'map'       => { license    => { value => \&url },
4595
                       homepage   => { value => \&url },
4596
                       bugtracker => { value => \&url },
4597
                       repository => { value => \&url },
4598
                       ':key'     => { value => \&string, name => \&custom_1 },
4599
      }
4600
    },
4601
  
4602
    # additional user defined key/value pairs
4603
    # note we can only validate the key name, as the structure is user defined
4604
    ':key'        => { name => \&string, value => \&anything },
4605
  },
4606
  
4607
  # note that the 1.1 spec only specifies 'version' as mandatory
4608
  '1.1' => {
4609
    'name'                => { value => \&string  },
4610
    'version'             => { mandatory => 1, value => \&version },
4611
    'license'             => { value => \&license },
4612
    'generated_by'        => { value => \&string  },
4613
  
4614
    'license_uri'         => { value => \&url },
4615
    'distribution_type'   => { value => \&string  },
4616
    'dynamic_config'      => { value => \&boolean },
4617
  
4618
    'private'             => $no_index_1_1,
4619
  
4620
    'requires'            => $module_map1,
4621
    'recommends'          => $module_map1,
4622
    'build_requires'      => $module_map1,
4623
    'conflicts'           => $module_map2,
4624
  
4625
    # additional user defined key/value pairs
4626
    # note we can only validate the key name, as the structure is user defined
4627
    ':key'        => { name => \&string, value => \&anything },
4628
  },
4629
  
4630
  # note that the 1.0 spec doesn't specify optional or mandatory fields
4631
  # but we will treat version as mandatory since otherwise META 1.0 is
4632
  # completely arbitrary and pointless
4633
  '1.0' => {
4634
    'name'                => { value => \&string  },
4635
    'version'             => { mandatory => 1, value => \&version },
4636
    'license'             => { value => \&license },
4637
    'generated_by'        => { value => \&string  },
4638
  
4639
    'license_uri'         => { value => \&url },
4640
    'distribution_type'   => { value => \&string  },
4641
    'dynamic_config'      => { value => \&boolean },
4642
  
4643
    'requires'            => $module_map1,
4644
    'recommends'          => $module_map1,
4645
    'build_requires'      => $module_map1,
4646
    'conflicts'           => $module_map2,
4647
  
4648
    # additional user defined key/value pairs
4649
    # note we can only validate the key name, as the structure is user defined
4650
    ':key'        => { name => \&string, value => \&anything },
4651
  },
4652
  );
4653
  
4654
  #--------------------------------------------------------------------------#
4655
  # Code
4656
  #--------------------------------------------------------------------------#
4657
  
4658
  
4659
  sub new {
4660
    my ($class,$data) = @_;
4661
  
4662
    # create an attributes hash
4663
    my $self = {
4664
      'data'    => $data,
4665
      'spec'    => $data->{'meta-spec'}{'version'} || "1.0",
4666
      'errors'  => undef,
4667
    };
4668
  
4669
    # create the object
4670
    return bless $self, $class;
4671
  }
4672
  
4673
  
4674
  sub is_valid {
4675
      my $self = shift;
4676
      my $data = $self->{data};
4677
      my $spec_version = $self->{spec};
4678
      $self->check_map($definitions{$spec_version},$data);
4679
      return ! $self->errors;
4680
  }
4681
  
4682
  
4683
  sub errors {
4684
      my $self = shift;
4685
      return ()   unless(defined $self->{errors});
4686
      return @{$self->{errors}};
4687
  }
4688
  
4689
  
4690
  my $spec_error = "Missing validation action in specification. "
4691
    . "Must be one of 'map', 'list', 'lazylist', or 'value'";
4692
  
4693
  sub check_map {
4694
      my ($self,$spec,$data) = @_;
4695
  
4696
      if(ref($spec) ne 'HASH') {
4697
          $self->_error( "Unknown META specification, cannot validate." );
4698
          return;
4699
      }
4700
  
4701
      if(ref($data) ne 'HASH') {
4702
          $self->_error( "Expected a map structure from string or file." );
4703
          return;
4704
      }
4705
  
4706
      for my $key (keys %$spec) {
4707
          next    unless($spec->{$key}->{mandatory});
4708
          next    if(defined $data->{$key});
4709
          push @{$self->{stack}}, $key;
4710
          $self->_error( "Missing mandatory field, '$key'" );
4711
          pop @{$self->{stack}};
4712
      }
4713
  
4714
      for my $key (keys %$data) {
4715
          push @{$self->{stack}}, $key;
4716
          if($spec->{$key}) {
4717
              if($spec->{$key}{value}) {
4718
                  $spec->{$key}{value}->($self,$key,$data->{$key});
4719
              } elsif($spec->{$key}{'map'}) {
4720
                  $self->check_map($spec->{$key}{'map'},$data->{$key});
4721
              } elsif($spec->{$key}{'list'}) {
4722
                  $self->check_list($spec->{$key}{'list'},$data->{$key});
4723
              } elsif($spec->{$key}{'lazylist'}) {
4724
                  $self->check_lazylist($spec->{$key}{'lazylist'},$data->{$key});
4725
              } else {
4726
                  $self->_error( "$spec_error for '$key'" );
4727
              }
4728
  
4729
          } elsif ($spec->{':key'}) {
4730
              $spec->{':key'}{name}->($self,$key,$key);
4731
              if($spec->{':key'}{value}) {
4732
                  $spec->{':key'}{value}->($self,$key,$data->{$key});
4733
              } elsif($spec->{':key'}{'map'}) {
4734
                  $self->check_map($spec->{':key'}{'map'},$data->{$key});
4735
              } elsif($spec->{':key'}{'list'}) {
4736
                  $self->check_list($spec->{':key'}{'list'},$data->{$key});
4737
              } elsif($spec->{':key'}{'lazylist'}) {
4738
                  $self->check_lazylist($spec->{':key'}{'lazylist'},$data->{$key});
4739
              } else {
4740
                  $self->_error( "$spec_error for ':key'" );
4741
              }
4742
  
4743
  
4744
          } else {
4745
              $self->_error( "Unknown key, '$key', found in map structure" );
4746
          }
4747
          pop @{$self->{stack}};
4748
      }
4749
  }
4750
  
4751
  # if it's a string, make it into a list and check the list
4752
  sub check_lazylist {
4753
      my ($self,$spec,$data) = @_;
4754
  
4755
      if ( defined $data && ! ref($data) ) {
4756
        $data = [ $data ];
4757
      }
4758
  
4759
      $self->check_list($spec,$data);
4760
  }
4761
  
4762
  sub check_list {
4763
      my ($self,$spec,$data) = @_;
4764
  
4765
      if(ref($data) ne 'ARRAY') {
4766
          $self->_error( "Expected a list structure" );
4767
          return;
4768
      }
4769
  
4770
      if(defined $spec->{mandatory}) {
4771
          if(!defined $data->[0]) {
4772
              $self->_error( "Missing entries from mandatory list" );
4773
          }
4774
      }
4775
  
4776
      for my $value (@$data) {
4777
          push @{$self->{stack}}, $value || "<undef>";
4778
          if(defined $spec->{value}) {
4779
              $spec->{value}->($self,'list',$value);
4780
          } elsif(defined $spec->{'map'}) {
4781
              $self->check_map($spec->{'map'},$value);
4782
          } elsif(defined $spec->{'list'}) {
4783
              $self->check_list($spec->{'list'},$value);
4784
          } elsif(defined $spec->{'lazylist'}) {
4785
              $self->check_lazylist($spec->{'lazylist'},$value);
4786
          } elsif ($spec->{':key'}) {
4787
              $self->check_map($spec,$value);
4788
          } else {
4789
            $self->_error( "$spec_error associated with '$self->{stack}[-2]'" );
4790
          }
4791
          pop @{$self->{stack}};
4792
      }
4793
  }
4794
  
4795
  
4796
  sub header {
4797
      my ($self,$key,$value) = @_;
4798
      if(defined $value) {
4799
          return 1    if($value && $value =~ /^--- #YAML:1.0/);
4800
      }
4801
      $self->_error( "file does not have a valid YAML header." );
4802
      return 0;
4803
  }
4804
  
4805
  sub release_status {
4806
    my ($self,$key,$value) = @_;
4807
    if(defined $value) {
4808
      my $version = $self->{data}{version} || '';
4809
      if ( $version =~ /_/ ) {
4810
        return 1 if ( $value =~ /\A(?:testing|unstable)\z/ );
4811
        $self->_error( "'$value' for '$key' is invalid for version '$version'" );
4812
      }
4813
      else {
4814
        return 1 if ( $value =~ /\A(?:stable|testing|unstable)\z/ );
4815
        $self->_error( "'$value' for '$key' is invalid" );
4816
      }
4817
    }
4818
    else {
4819
      $self->_error( "'$key' is not defined" );
4820
    }
4821
    return 0;
4822
  }
4823
  
4824
  # _uri_split taken from URI::Split by Gisle Aas, Copyright 2003
4825
  sub _uri_split {
4826
       return $_[0] =~ m,(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?,;
4827
  }
4828
  
4829
  sub url {
4830
      my ($self,$key,$value) = @_;
4831
      if(defined $value) {
4832
        my ($scheme, $auth, $path, $query, $frag) = _uri_split($value);
4833
        unless ( defined $scheme && length $scheme ) {
4834
          $self->_error( "'$value' for '$key' does not have a URL scheme" );
4835
          return 0;
4836
        }
4837
        unless ( defined $auth && length $auth ) {
4838
          $self->_error( "'$value' for '$key' does not have a URL authority" );
4839
          return 0;
4840
        }
4841
        return 1;
4842
      }
4843
      $value ||= '';
4844
      $self->_error( "'$value' for '$key' is not a valid URL." );
4845
      return 0;
4846
  }
4847
  
4848
  sub urlspec {
4849
      my ($self,$key,$value) = @_;
4850
      if(defined $value) {
4851
          return 1    if($value && $known_specs{$self->{spec}} eq $value);
4852
          if($value && $known_urls{$value}) {
4853
              $self->_error( 'META specification URL does not match version' );
4854
              return 0;
4855
          }
4856
      }
4857
      $self->_error( 'Unknown META specification' );
4858
      return 0;
4859
  }
4860
  
4861
  sub anything { return 1 }
4862
  
4863
  sub string {
4864
      my ($self,$key,$value) = @_;
4865
      if(defined $value) {
4866
          return 1    if($value || $value =~ /^0$/);
4867
      }
4868
      $self->_error( "value is an undefined string" );
4869
      return 0;
4870
  }
4871
  
4872
  sub string_or_undef {
4873
      my ($self,$key,$value) = @_;
4874
      return 1    unless(defined $value);
4875
      return 1    if($value || $value =~ /^0$/);
4876
      $self->_error( "No string defined for '$key'" );
4877
      return 0;
4878
  }
4879
  
4880
  sub file {
4881
      my ($self,$key,$value) = @_;
4882
      return 1    if(defined $value);
4883
      $self->_error( "No file defined for '$key'" );
4884
      return 0;
4885
  }
4886
  
4887
  sub exversion {
4888
      my ($self,$key,$value) = @_;
4889
      if(defined $value && ($value || $value =~ /0/)) {
4890
          my $pass = 1;
4891
          for(split(",",$value)) { $self->version($key,$_) or ($pass = 0); }
4892
          return $pass;
4893
      }
4894
      $value = '<undef>'  unless(defined $value);
4895
      $self->_error( "'$value' for '$key' is not a valid version." );
4896
      return 0;
4897
  }
4898
  
4899
  sub version {
4900
      my ($self,$key,$value) = @_;
4901
      if(defined $value) {
4902
          return 0    unless($value || $value =~ /0/);
4903
          return 1    if($value =~ /^\s*((<|<=|>=|>|!=|==)\s*)?v?\d+((\.\d+((_|\.)\d+)?)?)/);
4904
      } else {
4905
          $value = '<undef>';
4906
      }
4907
      $self->_error( "'$value' for '$key' is not a valid version." );
4908
      return 0;
4909
  }
4910
  
4911
  sub boolean {
4912
      my ($self,$key,$value) = @_;
4913
      if(defined $value) {
4914
          return 1    if($value =~ /^(0|1|true|false)$/);
4915
      } else {
4916
          $value = '<undef>';
4917
      }
4918
      $self->_error( "'$value' for '$key' is not a boolean value." );
4919
      return 0;
4920
  }
4921
  
4922
  my %v1_licenses = (
4923
      'perl'         => 'http://dev.perl.org/licenses/',
4924
      'gpl'          => 'http://www.opensource.org/licenses/gpl-license.php',
4925
      'apache'       => 'http://apache.org/licenses/LICENSE-2.0',
4926
      'artistic'     => 'http://opensource.org/licenses/artistic-license.php',
4927
      'artistic_2'   => 'http://opensource.org/licenses/artistic-license-2.0.php',
4928
      'lgpl'         => 'http://www.opensource.org/licenses/lgpl-license.phpt',
4929
      'bsd'          => 'http://www.opensource.org/licenses/bsd-license.php',
4930
      'gpl'          => 'http://www.opensource.org/licenses/gpl-license.php',
4931
      'mit'          => 'http://opensource.org/licenses/mit-license.php',
4932
      'mozilla'      => 'http://opensource.org/licenses/mozilla1.1.php',
4933
      'open_source'  => undef,
4934
      'unrestricted' => undef,
4935
      'restrictive'  => undef,
4936
      'unknown'      => undef,
4937
  );
4938
  
4939
  my %v2_licenses = map { $_ => 1 } qw(
4940
    agpl_3
4941
    apache_1_1
4942
    apache_2_0
4943
    artistic_1
4944
    artistic_2
4945
    bsd
4946
    freebsd
4947
    gfdl_1_2
4948
    gfdl_1_3
4949
    gpl_1
4950
    gpl_2
4951
    gpl_3
4952
    lgpl_2_1
4953
    lgpl_3_0
4954
    mit
4955
    mozilla_1_0
4956
    mozilla_1_1
4957
    openssl
4958
    perl_5
4959
    qpl_1_0
4960
    ssleay
4961
    sun
4962
    zlib
4963
    open_source
4964
    restricted
4965
    unrestricted
4966
    unknown
4967
  );
4968
  
4969
  sub license {
4970
      my ($self,$key,$value) = @_;
4971
      my $licenses = $self->{spec} < 2 ? \%v1_licenses : \%v2_licenses;
4972
      if(defined $value) {
4973
          return 1    if($value && exists $licenses->{$value});
4974
      } else {
4975
          $value = '<undef>';
4976
      }
4977
      $self->_error( "License '$value' is invalid" );
4978
      return 0;
4979
  }
4980
  
4981
  sub custom_1 {
4982
      my ($self,$key) = @_;
4983
      if(defined $key) {
4984
          # a valid user defined key should be alphabetic
4985
          # and contain at least one capital case letter.
4986
          return 1    if($key && $key =~ /^[_a-z]+$/i && $key =~ /[A-Z]/);
4987
      } else {
4988
          $key = '<undef>';
4989
      }
4990
      $self->_error( "Custom resource '$key' must be in CamelCase." );
4991
      return 0;
4992
  }
4993
  
4994
  sub custom_2 {
4995
      my ($self,$key) = @_;
4996
      if(defined $key) {
4997
          return 1    if($key && $key =~ /^x_/i);  # user defined
4998
      } else {
4999
          $key = '<undef>';
5000
      }
5001
      $self->_error( "Custom key '$key' must begin with 'x_' or 'X_'." );
5002
      return 0;
5003
  }
5004
  
5005
  sub identifier {
5006
      my ($self,$key) = @_;
5007
      if(defined $key) {
5008
          return 1    if($key && $key =~ /^([a-z][_a-z]+)$/i);    # spec 2.0 defined
5009
      } else {
5010
          $key = '<undef>';
5011
      }
5012
      $self->_error( "Key '$key' is not a legal identifier." );
5013
      return 0;
5014
  }
5015
  
5016
  sub module {
5017
      my ($self,$key) = @_;
5018
      if(defined $key) {
5019
          return 1    if($key && $key =~ /^[A-Za-z0-9_]+(::[A-Za-z0-9_]+)*$/);
5020
      } else {
5021
          $key = '<undef>';
5022
      }
5023
      $self->_error( "Key '$key' is not a legal module name." );
5024
      return 0;
5025
  }
5026
  
5027
  my @valid_phases = qw/ configure build test runtime develop /;
5028
  sub phase {
5029
      my ($self,$key) = @_;
5030
      if(defined $key) {
5031
          return 1 if( length $key && grep { $key eq $_ } @valid_phases );
5032
          return 1 if $key =~ /x_/i;
5033
      } else {
5034
          $key = '<undef>';
5035
      }
5036
      $self->_error( "Key '$key' is not a legal phase." );
5037
      return 0;
5038
  }
5039
  
5040
  my @valid_relations = qw/ requires recommends suggests conflicts /;
5041
  sub relation {
5042
      my ($self,$key) = @_;
5043
      if(defined $key) {
5044
          return 1 if( length $key && grep { $key eq $_ } @valid_relations );
5045
          return 1 if $key =~ /x_/i;
5046
      } else {
5047
          $key = '<undef>';
5048
      }
5049
      $self->_error( "Key '$key' is not a legal prereq relationship." );
5050
      return 0;
5051
  }
5052
  
5053
  sub _error {
5054
      my $self = shift;
5055
      my $mess = shift;
5056
  
5057
      $mess .= ' ('.join(' -> ',@{$self->{stack}}).')'  if($self->{stack});
5058
      $mess .= " [Validation: $self->{spec}]";
5059
  
5060
      push @{$self->{errors}}, $mess;
5061
  }
5062
  
5063
  1;
5064
  
5065
  
5066
  
5067
  
5068
  __END__
5069
  
5070
  
5071
  
5072
CPAN_META_VALIDATOR
5073

            
5074
$fatpacked{"CPAN/Meta/YAML.pm"} = <<'CPAN_META_YAML';
5075
  package CPAN::Meta::YAML;
5076
  BEGIN {
5077
    $CPAN::Meta::YAML::VERSION = '0.003';
5078
  }
5079
  
5080
  use strict;
5081
  
5082
  # UTF Support?
5083
  sub HAVE_UTF8 () { $] >= 5.007003 }
5084
  BEGIN {
5085
  	if ( HAVE_UTF8 ) {
5086
  		# The string eval helps hide this from Test::MinimumVersion
5087
  		eval "require utf8;";
5088
  		die "Failed to load UTF-8 support" if $@;
5089
  	}
5090
  
5091
  	# Class structure
5092
  	require 5.004;
5093
  	require Exporter;
5094
  	require Carp;
5095
  	@CPAN::Meta::YAML::ISA       = qw{ Exporter  };
5096
  	@CPAN::Meta::YAML::EXPORT    = qw{ Load Dump };
5097
  	@CPAN::Meta::YAML::EXPORT_OK = qw{ LoadFile DumpFile freeze thaw };
5098
  
5099
  	# Error storage
5100
  	$CPAN::Meta::YAML::errstr    = '';
5101
  }
5102
  
5103
  # The character class of all characters we need to escape
5104
  # NOTE: Inlined, since it's only used once
5105
  # my $RE_ESCAPE = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f\"\n]';
5106
  
5107
  # Printed form of the unprintable characters in the lowest range
5108
  # of ASCII characters, listed by ASCII ordinal position.
5109
  my @UNPRINTABLE = qw(
5110
  	z    x01  x02  x03  x04  x05  x06  a
5111
  	x08  t    n    v    f    r    x0e  x0f
5112
  	x10  x11  x12  x13  x14  x15  x16  x17
5113
  	x18  x19  x1a  e    x1c  x1d  x1e  x1f
5114
  );
5115
  
5116
  # Printable characters for escapes
5117
  my %UNESCAPES = (
5118
  	z => "\x00", a => "\x07", t    => "\x09",
5119
  	n => "\x0a", v => "\x0b", f    => "\x0c",
5120
  	r => "\x0d", e => "\x1b", '\\' => '\\',
5121
  );
5122
  
5123
  # Special magic boolean words
5124
  my %QUOTE = map { $_ => 1 } qw{
5125
  	null Null NULL
5126
  	y Y yes Yes YES n N no No NO
5127
  	true True TRUE false False FALSE
5128
  	on On ON off Off OFF
5129
  };
5130
  
5131
  
5132
  
5133
  
5134
  
5135
  #####################################################################
5136
  # Implementation
5137
  
5138
  # Create an empty CPAN::Meta::YAML object
5139
  sub new {
5140
  	my $class = shift;
5141
  	bless [ @_ ], $class;
5142
  }
5143
  
5144
  # Create an object from a file
5145
  sub read {
5146
  	my $class = ref $_[0] ? ref shift : shift;
5147
  
5148
  	# Check the file
5149
  	my $file = shift or return $class->_error( 'You did not specify a file name' );
5150
  	return $class->_error( "File '$file' does not exist" )              unless -e $file;
5151
  	return $class->_error( "'$file' is a directory, not a file" )       unless -f _;
5152
  	return $class->_error( "Insufficient permissions to read '$file'" ) unless -r _;
5153
  
5154
  	# Slurp in the file
5155
  	local $/ = undef;
5156
  	local *CFG;
5157
  	unless ( open(CFG, $file) ) {
5158
  		return $class->_error("Failed to open file '$file': $!");
5159
  	}
5160
  	my $contents = <CFG>;
5161
  	unless ( close(CFG) ) {
5162
  		return $class->_error("Failed to close file '$file': $!");
5163
  	}
5164
  
5165
  	$class->read_string( $contents );
5166
  }
5167
  
5168
  # Create an object from a string
5169
  sub read_string {
5170
  	my $class  = ref $_[0] ? ref shift : shift;
5171
  	my $self   = bless [], $class;
5172
  	my $string = $_[0];
5173
  	eval {
5174
  		unless ( defined $string ) {
5175
  			die \"Did not provide a string to load";
5176
  		}
5177
  
5178
  		# Byte order marks
5179
  		# NOTE: Keeping this here to educate maintainers
5180
  		# my %BOM = (
5181
  		#     "\357\273\277" => 'UTF-8',
5182
  		#     "\376\377"     => 'UTF-16BE',
5183
  		#     "\377\376"     => 'UTF-16LE',
5184
  		#     "\377\376\0\0" => 'UTF-32LE'
5185
  		#     "\0\0\376\377" => 'UTF-32BE',
5186
  		# );
5187
  		if ( $string =~ /^(?:\376\377|\377\376|\377\376\0\0|\0\0\376\377)/ ) {
5188
  			die \"Stream has a non UTF-8 BOM";
5189
  		} else {
5190
  			# Strip UTF-8 bom if found, we'll just ignore it
5191
  			$string =~ s/^\357\273\277//;
5192
  		}
5193
  
5194
  		# Try to decode as utf8
5195
  		utf8::decode($string) if HAVE_UTF8;
5196
  
5197
  		# Check for some special cases
5198
  		return $self unless length $string;
5199
  		unless ( $string =~ /[\012\015]+\z/ ) {
5200
  			die \"Stream does not end with newline character";
5201
  		}
5202
  
5203
  		# Split the file into lines
5204
  		my @lines = grep { ! /^\s*(?:\#.*)?\z/ }
5205
  			    split /(?:\015{1,2}\012|\015|\012)/, $string;
5206
  
5207
  		# Strip the initial YAML header
5208
  		@lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines;
5209
  
5210
  		# A nibbling parser
5211
  		while ( @lines ) {
5212
  			# Do we have a document header?
5213
  			if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) {
5214
  				# Handle scalar documents
5215
  				shift @lines;
5216
  				if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) {
5217
  					push @$self, $self->_read_scalar( "$1", [ undef ], \@lines );
5218
  					next;
5219
  				}
5220
  			}
5221
  
5222
  			if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) {
5223
  				# A naked document
5224
  				push @$self, undef;
5225
  				while ( @lines and $lines[0] !~ /^---/ ) {
5226
  					shift @lines;
5227
  				}
5228
  
5229
  			} elsif ( $lines[0] =~ /^\s*\-/ ) {
5230
  				# An array at the root
5231
  				my $document = [ ];
5232
  				push @$self, $document;
5233
  				$self->_read_array( $document, [ 0 ], \@lines );
5234
  
5235
  			} elsif ( $lines[0] =~ /^(\s*)\S/ ) {
5236
  				# A hash at the root
5237
  				my $document = { };
5238
  				push @$self, $document;
5239
  				$self->_read_hash( $document, [ length($1) ], \@lines );
5240
  
5241
  			} else {
5242
  				die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'";
5243
  			}
5244
  		}
5245
  	};
5246
  	if ( ref $@ eq 'SCALAR' ) {
5247
  		return $self->_error(${$@});
5248
  	} elsif ( $@ ) {
5249
  		require Carp;
5250
  		Carp::croak($@);
5251
  	}
5252
  
5253
  	return $self;
5254
  }
5255
  
5256
  # Deparse a scalar string to the actual scalar
5257
  sub _read_scalar {
5258
  	my ($self, $string, $indent, $lines) = @_;
5259
  
5260
  	# Trim trailing whitespace
5261
  	$string =~ s/\s*\z//;
5262
  
5263
  	# Explitic null/undef
5264
  	return undef if $string eq '~';
5265
  
5266
  	# Single quote
5267
  	if ( $string =~ /^\'(.*?)\'(?:\s+\#.*)?\z/ ) {
5268
  		return '' unless defined $1;
5269
  		$string = $1;
5270
  		$string =~ s/\'\'/\'/g;
5271
  		return $string;
5272
  	}
5273
  
5274
  	# Double quote.
5275
  	# The commented out form is simpler, but overloaded the Perl regex
5276
  	# engine due to recursion and backtracking problems on strings
5277
  	# larger than 32,000ish characters. Keep it for reference purposes.
5278
  	# if ( $string =~ /^\"((?:\\.|[^\"])*)\"\z/ ) {
5279
  	if ( $string =~ /^\"([^\\"]*(?:\\.[^\\"]*)*)\"(?:\s+\#.*)?\z/ ) {
5280
  		# Reusing the variable is a little ugly,
5281
  		# but avoids a new variable and a string copy.
5282
  		$string = $1;
5283
  		$string =~ s/\\"/"/g;
5284
  		$string =~ s/\\([never\\fartz]|x([0-9a-fA-F]{2}))/(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}/gex;
5285
  		return $string;
5286
  	}
5287
  
5288
  	# Special cases
5289
  	if ( $string =~ /^[\'\"!&]/ ) {
5290
  		die \"CPAN::Meta::YAML does not support a feature in line '$string'";
5291
  	}
5292
  	return {} if $string =~ /^{}(?:\s+\#.*)?\z/;
5293
  	return [] if $string =~ /^\[\](?:\s+\#.*)?\z/;
5294
  
5295
  	# Regular unquoted string
5296
  	if ( $string !~ /^[>|]/ ) {
5297
  		if (
5298
  			$string =~ /^(?:-(?:\s|$)|[\@\%\`])/
5299
  			or
5300
  			$string =~ /:(?:\s|$)/
5301
  		) {
5302
  			die \"CPAN::Meta::YAML found illegal characters in plain scalar: '$string'";
5303
  		}
5304
  		$string =~ s/\s+#.*\z//;
5305
  		return $string;
5306
  	}
5307
  
5308
  	# Error
5309
  	die \"CPAN::Meta::YAML failed to find multi-line scalar content" unless @$lines;
5310
  
5311
  	# Check the indent depth
5312
  	$lines->[0]   =~ /^(\s*)/;
5313
  	$indent->[-1] = length("$1");
5314
  	if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) {
5315
  		die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
5316
  	}
5317
  
5318
  	# Pull the lines
5319
  	my @multiline = ();
5320
  	while ( @$lines ) {
5321
  		$lines->[0] =~ /^(\s*)/;
5322
  		last unless length($1) >= $indent->[-1];
5323
  		push @multiline, substr(shift(@$lines), length($1));
5324
  	}
5325
  
5326
  	my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n";
5327
  	my $t = (substr($string, 1, 1) eq '-') ? ''  : "\n";
5328
  	return join( $j, @multiline ) . $t;
5329
  }
5330
  
5331
  # Parse an array
5332
  sub _read_array {
5333
  	my ($self, $array, $indent, $lines) = @_;
5334
  
5335
  	while ( @$lines ) {
5336
  		# Check for a new document
5337
  		if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
5338
  			while ( @$lines and $lines->[0] !~ /^---/ ) {
5339
  				shift @$lines;
5340
  			}
5341
  			return 1;
5342
  		}
5343
  
5344
  		# Check the indent level
5345
  		$lines->[0] =~ /^(\s*)/;
5346
  		if ( length($1) < $indent->[-1] ) {
5347
  			return 1;
5348
  		} elsif ( length($1) > $indent->[-1] ) {
5349
  			die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
5350
  		}
5351
  
5352
  		if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) {
5353
  			# Inline nested hash
5354
  			my $indent2 = length("$1");
5355
  			$lines->[0] =~ s/-/ /;
5356
  			push @$array, { };
5357
  			$self->_read_hash( $array->[-1], [ @$indent, $indent2 ], $lines );
5358
  
5359
  		} elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) {
5360
  			# Array entry with a value
5361
  			shift @$lines;
5362
  			push @$array, $self->_read_scalar( "$2", [ @$indent, undef ], $lines );
5363
  
5364
  		} elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) {
5365
  			shift @$lines;
5366
  			unless ( @$lines ) {
5367
  				push @$array, undef;
5368
  				return 1;
5369
  			}
5370
  			if ( $lines->[0] =~ /^(\s*)\-/ ) {
5371
  				my $indent2 = length("$1");
5372
  				if ( $indent->[-1] == $indent2 ) {
5373
  					# Null array entry
5374
  					push @$array, undef;
5375
  				} else {
5376
  					# Naked indenter
5377
  					push @$array, [ ];
5378
  					$self->_read_array( $array->[-1], [ @$indent, $indent2 ], $lines );
5379
  				}
5380
  
5381
  			} elsif ( $lines->[0] =~ /^(\s*)\S/ ) {
5382
  				push @$array, { };
5383
  				$self->_read_hash( $array->[-1], [ @$indent, length("$1") ], $lines );
5384
  
5385
  			} else {
5386
  				die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
5387
  			}
5388
  
5389
  		} elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) {
5390
  			# This is probably a structure like the following...
5391
  			# ---
5392
  			# foo:
5393
  			# - list
5394
  			# bar: value
5395
  			#
5396
  			# ... so lets return and let the hash parser handle it
5397
  			return 1;
5398
  
5399
  		} else {
5400
  			die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
5401
  		}
5402
  	}
5403
  
5404
  	return 1;
5405
  }
5406
  
5407
  # Parse an array
5408
  sub _read_hash {
5409
  	my ($self, $hash, $indent, $lines) = @_;
5410
  
5411
  	while ( @$lines ) {
5412
  		# Check for a new document
5413
  		if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
5414
  			while ( @$lines and $lines->[0] !~ /^---/ ) {
5415
  				shift @$lines;
5416
  			}
5417
  			return 1;
5418
  		}
5419
  
5420
  		# Check the indent level
5421
  		$lines->[0] =~ /^(\s*)/;
5422
  		if ( length($1) < $indent->[-1] ) {
5423
  			return 1;
5424
  		} elsif ( length($1) > $indent->[-1] ) {
5425
  			die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
5426
  		}
5427
  
5428
  		# Get the key
5429
  		unless ( $lines->[0] =~ s/^\s*([^\'\" ][^\n]*?)\s*:(\s+(?:\#.*)?|$)// ) {
5430
  			if ( $lines->[0] =~ /^\s*[?\'\"]/ ) {
5431
  				die \"CPAN::Meta::YAML does not support a feature in line '$lines->[0]'";
5432
  			}
5433
  			die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
5434
  		}
5435
  		my $key = $1;
5436
  
5437
  		# Do we have a value?
5438
  		if ( length $lines->[0] ) {
5439
  			# Yes
5440
  			$hash->{$key} = $self->_read_scalar( shift(@$lines), [ @$indent, undef ], $lines );
5441
  		} else {
5442
  			# An indent
5443
  			shift @$lines;
5444
  			unless ( @$lines ) {
5445
  				$hash->{$key} = undef;
5446
  				return 1;
5447
  			}
5448
  			if ( $lines->[0] =~ /^(\s*)-/ ) {
5449
  				$hash->{$key} = [];
5450
  				$self->_read_array( $hash->{$key}, [ @$indent, length($1) ], $lines );
5451
  			} elsif ( $lines->[0] =~ /^(\s*)./ ) {
5452
  				my $indent2 = length("$1");
5453
  				if ( $indent->[-1] >= $indent2 ) {
5454
  					# Null hash entry
5455
  					$hash->{$key} = undef;
5456
  				} else {
5457
  					$hash->{$key} = {};
5458
  					$self->_read_hash( $hash->{$key}, [ @$indent, length($1) ], $lines );
5459
  				}
5460
  			}
5461
  		}
5462
  	}
5463
  
5464
  	return 1;
5465
  }
5466
  
5467
  # Save an object to a file
5468
  sub write {
5469
  	my $self = shift;
5470
  	my $file = shift or return $self->_error('No file name provided');
5471
  
5472
  	# Write it to the file
5473
  	open( CFG, '>' . $file ) or return $self->_error(
5474
  		"Failed to open file '$file' for writing: $!"
5475
  		);
5476
  	print CFG $self->write_string;
5477
  	close CFG;
5478
  
5479
  	return 1;
5480
  }
5481
  
5482
  # Save an object to a string
5483
  sub write_string {
5484
  	my $self = shift;
5485
  	return '' unless @$self;
5486
  
5487
  	# Iterate over the documents
5488
  	my $indent = 0;
5489
  	my @lines  = ();
5490
  	foreach my $cursor ( @$self ) {
5491
  		push @lines, '---';
5492
  
5493
  		# An empty document
5494
  		if ( ! defined $cursor ) {
5495
  			# Do nothing
5496
  
5497
  		# A scalar document
5498
  		} elsif ( ! ref $cursor ) {
5499
  			$lines[-1] .= ' ' . $self->_write_scalar( $cursor, $indent );
5500
  
5501
  		# A list at the root
5502
  		} elsif ( ref $cursor eq 'ARRAY' ) {
5503
  			unless ( @$cursor ) {
5504
  				$lines[-1] .= ' []';
5505
  				next;
5506
  			}
5507
  			push @lines, $self->_write_array( $cursor, $indent, {} );
5508
  
5509
  		# A hash at the root
5510
  		} elsif ( ref $cursor eq 'HASH' ) {
5511
  			unless ( %$cursor ) {
5512
  				$lines[-1] .= ' {}';
5513
  				next;
5514
  			}
5515
  			push @lines, $self->_write_hash( $cursor, $indent, {} );
5516
  
5517
  		} else {
5518
  			Carp::croak("Cannot serialize " . ref($cursor));
5519
  		}
5520
  	}
5521
  
5522
  	join '', map { "$_\n" } @lines;
5523
  }
5524
  
5525
  sub _write_scalar {
5526
  	my $string = $_[1];
5527
  	return '~'  unless defined $string;
5528
  	return "''" unless length  $string;
5529
  	if ( $string =~ /[\x00-\x08\x0b-\x0d\x0e-\x1f\"\'\n]/ ) {
5530
  		$string =~ s/\\/\\\\/g;
5531
  		$string =~ s/"/\\"/g;
5532
  		$string =~ s/\n/\\n/g;
5533
  		$string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g;
5534
  		return qq|"$string"|;
5535
  	}
5536
  	if ( $string =~ /(?:^\W|\s)/ or $QUOTE{$string} ) {
5537
  		return "'$string'";
5538
  	}
5539
  	return $string;
5540
  }
5541
  
5542
  sub _write_array {
5543
  	my ($self, $array, $indent, $seen) = @_;
5544
  	if ( $seen->{refaddr($array)}++ ) {
5545
  		die "CPAN::Meta::YAML does not support circular references";
5546
  	}
5547
  	my @lines  = ();
5548
  	foreach my $el ( @$array ) {
5549
  		my $line = ('  ' x $indent) . '-';
5550
  		my $type = ref $el;
5551
  		if ( ! $type ) {
5552
  			$line .= ' ' . $self->_write_scalar( $el, $indent + 1 );
5553
  			push @lines, $line;
5554
  
5555
  		} elsif ( $type eq 'ARRAY' ) {
5556
  			if ( @$el ) {
5557
  				push @lines, $line;
5558
  				push @lines, $self->_write_array( $el, $indent + 1, $seen );
5559
  			} else {
5560
  				$line .= ' []';
5561
  				push @lines, $line;
5562
  			}
5563
  
5564
  		} elsif ( $type eq 'HASH' ) {
5565
  			if ( keys %$el ) {
5566
  				push @lines, $line;
5567
  				push @lines, $self->_write_hash( $el, $indent + 1, $seen );
5568
  			} else {
5569
  				$line .= ' {}';
5570
  				push @lines, $line;
5571
  			}
5572
  
5573
  		} else {
5574
  			die "CPAN::Meta::YAML does not support $type references";
5575
  		}
5576
  	}
5577
  
5578
  	@lines;
5579
  }
5580
  
5581
  sub _write_hash {
5582
  	my ($self, $hash, $indent, $seen) = @_;
5583
  	if ( $seen->{refaddr($hash)}++ ) {
5584
  		die "CPAN::Meta::YAML does not support circular references";
5585
  	}
5586
  	my @lines  = ();
5587
  	foreach my $name ( sort keys %$hash ) {
5588
  		my $el   = $hash->{$name};
5589
  		my $line = ('  ' x $indent) . "$name:";
5590
  		my $type = ref $el;
5591
  		if ( ! $type ) {
5592
  			$line .= ' ' . $self->_write_scalar( $el, $indent + 1 );
5593
  			push @lines, $line;
5594
  
5595
  		} elsif ( $type eq 'ARRAY' ) {
5596
  			if ( @$el ) {
5597
  				push @lines, $line;
5598
  				push @lines, $self->_write_array( $el, $indent + 1, $seen );
5599
  			} else {
5600
  				$line .= ' []';
5601
  				push @lines, $line;
5602
  			}
5603
  
5604
  		} elsif ( $type eq 'HASH' ) {
5605
  			if ( keys %$el ) {
5606
  				push @lines, $line;
5607
  				push @lines, $self->_write_hash( $el, $indent + 1, $seen );
5608
  			} else {
5609
  				$line .= ' {}';
5610
  				push @lines, $line;
5611
  			}
5612
  
5613
  		} else {
5614
  			die "CPAN::Meta::YAML does not support $type references";
5615
  		}
5616
  	}
5617
  
5618
  	@lines;
5619
  }
5620
  
5621
  # Set error
5622
  sub _error {
5623
  	$CPAN::Meta::YAML::errstr = $_[1];
5624
  	undef;
5625
  }
5626
  
5627
  # Retrieve error
5628
  sub errstr {
5629
  	$CPAN::Meta::YAML::errstr;
5630
  }
5631
  
5632
  
5633
  
5634
  
5635
  
5636
  #####################################################################
5637
  # YAML Compatibility
5638
  
5639
  sub Dump {
5640
  	CPAN::Meta::YAML->new(@_)->write_string;
5641
  }
5642
  
5643
  sub Load {
5644
  	my $self = CPAN::Meta::YAML->read_string(@_);
5645
  	unless ( $self ) {
5646
  		Carp::croak("Failed to load YAML document from string");
5647
  	}
5648
  	if ( wantarray ) {
5649
  		return @$self;
5650
  	} else {
5651
  		# To match YAML.pm, return the last document
5652
  		return $self->[-1];
5653
  	}
5654
  }
5655
  
5656
  BEGIN {
5657
  	*freeze = *Dump;
5658
  	*thaw   = *Load;
5659
  }
5660
  
5661
  sub DumpFile {
5662
  	my $file = shift;
5663
  	CPAN::Meta::YAML->new(@_)->write($file);
5664
  }
5665
  
5666
  sub LoadFile {
5667
  	my $self = CPAN::Meta::YAML->read($_[0]);
5668
  	unless ( $self ) {
5669
  		Carp::croak("Failed to load YAML document from '" . ($_[0] || '') . "'");
5670
  	}
5671
  	if ( wantarray ) {
5672
  		return @$self;
5673
  	} else {
5674
  		# Return only the last document to match YAML.pm, 
5675
  		return $self->[-1];
5676
  	}
5677
  }
5678
  
5679
  
5680
  
5681
  
5682
  
5683
  #####################################################################
5684
  # Use Scalar::Util if possible, otherwise emulate it
5685
  
5686
  BEGIN {
5687
  	eval {
5688
  		require Scalar::Util;
5689
  		*refaddr = *Scalar::Util::refaddr;
5690
  	};
5691
  	eval <<'END_PERL' if $@;
5692
  # Failed to load Scalar::Util	
5693
  sub refaddr {
5694
  	my $pkg = ref($_[0]) or return undef;
5695
  	if ( !! UNIVERSAL::can($_[0], 'can') ) {
5696
  		bless $_[0], 'Scalar::Util::Fake';
5697
  	} else {
5698
  		$pkg = undef;
5699
  	}
5700
  	"$_[0]" =~ /0x(\w+)/;
5701
  	my $i = do { local $^W; hex $1 };
5702
  	bless $_[0], $pkg if defined $pkg;
5703
  	$i;
5704
  }
5705
  END_PERL
5706
  
5707
  }
5708
  
5709
  1;
5710
  
5711
  
5712
  
5713
  
5714
  __END__
5715
  
5716
  
5717
  # ABSTRACT: Read and write a subset of YAML for CPAN Meta files
5718
  
5719
  
5720
CPAN_META_YAML
5721

            
5722
$fatpacked{"HTTP/Tiny.pm"} = <<'HTTP_TINY';
5723
  # vim: ts=4 sts=4 sw=4 et:
5724
  #
5725
  # This file is part of HTTP-Tiny
5726
  #
5727
  # This software is copyright (c) 2011 by Christian Hansen.
5728
  #
5729
  # This is free software; you can redistribute it and/or modify it under
5730
  # the same terms as the Perl 5 programming language system itself.
5731
  #
5732
  package HTTP::Tiny;
5733
  BEGIN {
5734
    $HTTP::Tiny::VERSION = '0.009';
5735
  }
5736
  use strict;
5737
  use warnings;
5738
  # ABSTRACT: A small, simple, correct HTTP/1.1 client
5739
  
5740
  use Carp ();
5741
  
5742
  
5743
  my @attributes;
5744
  BEGIN {
5745
      @attributes = qw(agent default_headers max_redirect max_size proxy timeout);
5746
      no strict 'refs';
5747
      for my $accessor ( @attributes ) {
5748
          *{$accessor} = sub {
5749
              @_ > 1 ? $_[0]->{$accessor} = $_[1] : $_[0]->{$accessor};
5750
          };
5751
      }
5752
  }
5753
  
5754
  sub new {
5755
      my($class, %args) = @_;
5756
      (my $agent = $class) =~ s{::}{-}g;
5757
      my $self = {
5758
          agent        => $agent . "/" . ($class->VERSION || 0),
5759
          max_redirect => 5,
5760
          timeout      => 60,
5761
      };
5762
      for my $key ( @attributes ) {
5763
          $self->{$key} = $args{$key} if exists $args{$key}
5764
      }
5765
      return bless $self, $class;
5766
  }
5767
  
5768
  
5769
  sub get {
5770
      my ($self, $url, $args) = @_;
5771
      @_ == 2 || (@_ == 3 && ref $args eq 'HASH')
5772
        or Carp::croak(q/Usage: $http->get(URL, [HASHREF])/);
5773
      return $self->request('GET', $url, $args || {});
5774
  }
5775
  
5776
  
5777
  sub mirror {
5778
      my ($self, $url, $file, $args) = @_;
5779
      @_ == 3 || (@_ == 4 && ref $args eq 'HASH')
5780
        or Carp::croak(q/Usage: $http->mirror(URL, FILE, [HASHREF])/);
5781
      if ( -e $file and my $mtime = (stat($file))[9] ) {
5782
          $args->{headers}{'if-modified-since'} ||= $self->_http_date($mtime);
5783
      }
5784
      my $tempfile = $file . int(rand(2**31));
5785
      open my $fh, ">", $tempfile
5786
          or Carp::croak(qq/Error: Could not open temporary file $tempfile for downloading: $!/);
5787
      $args->{data_callback} = sub { print {$fh} $_[0] };
5788
      my $response = $self->request('GET', $url, $args);
5789
      close $fh
5790
          or Carp::croak(qq/Error: Could not close temporary file $tempfile: $!/);
5791
      if ( $response->{success} ) {
5792
          rename $tempfile, $file
5793
              or Carp::croak "Error replacing $file with $tempfile: $!\n";
5794
          my $lm = $response->{headers}{'last-modified'};
5795
          if ( $lm and my $mtime = $self->_parse_http_date($lm) ) {
5796
              utime $mtime, $mtime, $file;
5797
          }
5798
      }
5799
      $response->{success} ||= $response->{status} eq '304';
5800
      unlink $tempfile;
5801
      return $response;
5802
  }
5803
  
5804
  
5805
  my %idempotent = map { $_ => 1 } qw/GET HEAD PUT DELETE OPTIONS TRACE/;
5806
  
5807
  sub request {
5808
      my ($self, $method, $url, $args) = @_;
5809
      @_ == 3 || (@_ == 4 && ref $args eq 'HASH')
5810
        or Carp::croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/);
5811
      $args ||= {}; # we keep some state in this during _request
5812
  
5813
      # RFC 2616 Section 8.1.4 mandates a single retry on broken socket
5814
      my $response;
5815
      for ( 0 .. 1 ) {
5816
          $response = eval { $self->_request($method, $url, $args) };
5817
          last unless $@ && $idempotent{$method}
5818
              && $@ =~ m{^(?:Socket closed|Unexpected end)};
5819
      }
5820
  
5821
      if (my $e = "$@") {
5822
          $response = {
5823
              success => q{},
5824
              status  => 599,
5825
              reason  => 'Internal Exception',
5826
              content => $e,
5827
              headers => {
5828
                  'content-type'   => 'text/plain',
5829
                  'content-length' => length $e,
5830
              }
5831
          };
5832
      }
5833
      return $response;
5834
  }
5835
  
5836
  my %DefaultPort = (
5837
      http => 80,
5838
      https => 443,
5839
  );
5840
  
5841
  sub _request {
5842
      my ($self, $method, $url, $args) = @_;
5843
  
5844
      my ($scheme, $host, $port, $path_query) = $self->_split_url($url);
5845
  
5846
      my $request = {
5847
          method    => $method,
5848
          scheme    => $scheme,
5849
          host_port => ($port == $DefaultPort{$scheme} ? $host : "$host:$port"),
5850
          uri       => $path_query,
5851
          headers   => {},
5852
      };
5853
  
5854
      my $handle  = HTTP::Tiny::Handle->new(timeout => $self->{timeout});
5855
  
5856
      if ($self->{proxy}) {
5857
          $request->{uri} = "$scheme://$request->{host_port}$path_query";
5858
          croak(qq/HTTPS via proxy is not supported/)
5859
              if $request->{scheme} eq 'https';
5860
          $handle->connect(($self->_split_url($self->{proxy}))[0..2]);
5861
      }
5862
      else {
5863
          $handle->connect($scheme, $host, $port);
5864
      }
5865
  
5866
      $self->_prepare_headers_and_cb($request, $args);
5867
      $handle->write_request($request);
5868
  
5869
      my $response;
5870
      do { $response = $handle->read_response_header }
5871
          until (substr($response->{status},0,1) ne '1');
5872
  
5873
      if ( my @redir_args = $self->_maybe_redirect($request, $response, $args) ) {
5874
          $handle->close;
5875
          return $self->_request(@redir_args, $args);
5876
      }
5877
  
5878
      if ($method eq 'HEAD' || $response->{status} =~ /^[23]04/) {
5879
          # response has no message body
5880
      }
5881
      else {
5882
          my $data_cb = $self->_prepare_data_cb($response, $args);
5883
          $handle->read_body($data_cb, $response);
5884
      }
5885
  
5886
      $handle->close;
5887
      $response->{success} = substr($response->{status},0,1) eq '2';
5888
      return $response;
5889
  }
5890
  
5891
  sub _prepare_headers_and_cb {
5892
      my ($self, $request, $args) = @_;
5893
  
5894
      for ($self->{default_headers}, $args->{headers}) {
5895
          next unless defined;
5896
          while (my ($k, $v) = each %$_) {
5897
              $request->{headers}{lc $k} = $v;
5898
          }
5899
      }
5900
      $request->{headers}{'host'}         = $request->{host_port};
5901
      $request->{headers}{'connection'}   = "close";
5902
      $request->{headers}{'user-agent'} ||= $self->{agent};
5903
  
5904
      if (defined $args->{content}) {
5905
          $request->{headers}{'content-type'} ||= "application/octet-stream";
5906
          if (ref $args->{content} eq 'CODE') {
5907
              $request->{headers}{'transfer-encoding'} = 'chunked'
5908
                unless $request->{headers}{'content-length'}
5909
                    || $request->{headers}{'transfer-encoding'};
5910
              $request->{cb} = $args->{content};
5911
          }
5912
          else {
5913
              my $content = $args->{content};
5914
              if ( $] ge '5.008' ) {
5915
                  utf8::downgrade($content, 1)
5916
                      or Carp::croak(q/Wide character in request message body/);
5917
              }
5918
              $request->{headers}{'content-length'} = length $content
5919
                unless $request->{headers}{'content-length'}
5920
                    || $request->{headers}{'transfer-encoding'};
5921
              $request->{cb} = sub { substr $content, 0, length $content, '' };
5922
          }
5923
          $request->{trailer_cb} = $args->{trailer_callback}
5924
              if ref $args->{trailer_callback} eq 'CODE';
5925
      }
5926
      return;
5927
  }
5928
  
5929
  sub _prepare_data_cb {
5930
      my ($self, $response, $args) = @_;
5931
      my $data_cb = $args->{data_callback};
5932
      $response->{content} = '';
5933
  
5934
      if (!$data_cb || $response->{status} !~ /^2/) {
5935
          if (defined $self->{max_size}) {
5936
              $data_cb = sub {
5937
                  $_[1]->{content} .= $_[0];
5938
                  die(qq/Size of response body exceeds the maximum allowed of $self->{max_size}\n/)
5939
                    if length $_[1]->{content} > $self->{max_size};
5940
              };
5941
          }
5942
          else {
5943
              $data_cb = sub { $_[1]->{content} .= $_[0] };
5944
          }
5945
      }
5946
      return $data_cb;
5947
  }
5948
  
5949
  sub _maybe_redirect {
5950
      my ($self, $request, $response, $args) = @_;
5951
      my $headers = $response->{headers};
5952
      my ($status, $method) = ($response->{status}, $request->{method});
5953
      if (($status eq '303' or ($status =~ /^30[127]/ && $method =~ /^GET|HEAD$/))
5954
          and $headers->{location}
5955
          and ++$args->{redirects} <= $self->{max_redirect}
5956
      ) {
5957
          my $location = ($headers->{location} =~ /^\//)
5958
              ? "$request->{scheme}://$request->{host_port}$headers->{location}"
5959
              : $headers->{location} ;
5960
          return (($status eq '303' ? 'GET' : $method), $location);
5961
      }
5962
      return;
5963
  }
5964
  
5965
  sub _split_url {
5966
      my $url = pop;
5967
  
5968
      # URI regex adapted from the URI module
5969
      my ($scheme, $authority, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)>
5970
        or Carp::croak(qq/Cannot parse URL: '$url'/);
5971
  
5972
      $scheme     = lc $scheme;
5973
      $path_query = "/$path_query" unless $path_query =~ m<\A/>;
5974
  
5975
      my $host = (length($authority)) ? lc $authority : 'localhost';
5976
         $host =~ s/\A[^@]*@//;   # userinfo
5977
      my $port = do {
5978
         $host =~ s/:([0-9]*)\z// && length $1
5979
           ? $1
5980
           : ($scheme eq 'http' ? 80 : $scheme eq 'https' ? 443 : undef);
5981
      };
5982
  
5983
      return ($scheme, $host, $port, $path_query);
5984
  }
5985
  
5986
  # Date conversions adapted from HTTP::Date
5987
  my $DoW = "Sun|Mon|Tue|Wed|Thu|Fri|Sat";
5988
  my $MoY = "Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec";
5989
  sub _http_date {
5990
      my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($_[1]);
5991
      return sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT",
5992
          substr($DoW,$wday*4,3),
5993
          $mday, substr($MoY,$mon*4,3), $year+1900,
5994
          $hour, $min, $sec
5995
      );
5996
  }
5997
  
5998
  sub _parse_http_date {
5999
      my ($self, $str) = @_;
6000
      require Time::Local;
6001
      my @tl_parts;
6002
      if ($str =~ /^[SMTWF][a-z]+, +(\d{1,2}) ($MoY) +(\d\d\d\d) +(\d\d):(\d\d):(\d\d) +GMT$/) {
6003
          @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3);
6004
      }
6005
      elsif ($str =~ /^[SMTWF][a-z]+, +(\d\d)-($MoY)-(\d{2,4}) +(\d\d):(\d\d):(\d\d) +GMT$/ ) {
6006
          @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3);
6007
      }
6008
      elsif ($str =~ /^[SMTWF][a-z]+ +($MoY) +(\d{1,2}) +(\d\d):(\d\d):(\d\d) +(?:[^0-9]+ +)?(\d\d\d\d)$/ ) {
6009
          @tl_parts = ($5, $4, $3, $2, (index($MoY,$1)/4), $6);
6010
      }
6011
      return eval {
6012
          my $t = @tl_parts ? Time::Local::timegm(@tl_parts) : -1;
6013
          $t < 0 ? undef : $t;
6014
      };
6015
  }
6016
  
6017
  package
6018
      HTTP::Tiny::Handle; # hide from PAUSE/indexers
6019
  use strict;
6020
  use warnings;
6021
  
6022
  use Carp       qw[croak];
6023
  use Errno      qw[EINTR EPIPE];
6024
  use IO::Socket qw[SOCK_STREAM];
6025
  
6026
  sub BUFSIZE () { 32768 }
6027
  
6028
  my $Printable = sub {
6029
      local $_ = shift;
6030
      s/\r/\\r/g;
6031
      s/\n/\\n/g;
6032
      s/\t/\\t/g;
6033
      s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;
6034
      $_;
6035
  };
6036
  
6037
  my $Token = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
6038
  
6039
  sub new {
6040
      my ($class, %args) = @_;
6041
      return bless {
6042
          rbuf             => '',
6043
          timeout          => 60,
6044
          max_line_size    => 16384,
6045
          max_header_lines => 64,
6046
          %args
6047
      }, $class;
6048
  }
6049
  
6050
  my $ssl_verify_args = {
6051
      check_cn => "when_only",
6052
      wildcards_in_alt => "anywhere",
6053
      wildcards_in_cn => "anywhere"
6054
  };
6055
  
6056
  sub connect {
6057
      @_ == 4 || croak(q/Usage: $handle->connect(scheme, host, port)/);
6058
      my ($self, $scheme, $host, $port) = @_;
6059
  
6060
      if ( $scheme eq 'https' ) {
6061
          eval "require IO::Socket::SSL"
6062
              unless exists $INC{'IO/Socket/SSL.pm'};
6063
          croak(qq/IO::Socket::SSL must be installed for https support\n/)
6064
              unless $INC{'IO/Socket/SSL.pm'};
6065
      }
6066
      elsif ( $scheme ne 'http' ) {
6067
        croak(qq/Unsupported URL scheme '$scheme'/);
6068
      }
6069
  
6070
      $self->{fh} = 'IO::Socket::INET'->new(
6071
          PeerHost  => $host,
6072
          PeerPort  => $port,
6073
          Proto     => 'tcp',
6074
          Type      => SOCK_STREAM,
6075
          Timeout   => $self->{timeout}
6076
      ) or croak(qq/Could not connect to '$host:$port': $@/);
6077
  
6078
      binmode($self->{fh})
6079
        or croak(qq/Could not binmode() socket: '$!'/);
6080
  
6081
      if ( $scheme eq 'https') {
6082
          IO::Socket::SSL->start_SSL($self->{fh});
6083
          ref($self->{fh}) eq 'IO::Socket::SSL'
6084
              or die(qq/SSL connection failed for $host\n/);
6085
          $self->{fh}->verify_hostname( $host, $ssl_verify_args )
6086
              or die(qq/SSL certificate not valid for $host\n/);
6087
      }
6088
  
6089
      $self->{host} = $host;
6090
      $self->{port} = $port;
6091
  
6092
      return $self;
6093
  }
6094
  
6095
  sub close {
6096
      @_ == 1 || croak(q/Usage: $handle->close()/);
6097
      my ($self) = @_;
6098
      CORE::close($self->{fh})
6099
        or croak(qq/Could not close socket: '$!'/);
6100
  }
6101
  
6102
  sub write {
6103
      @_ == 2 || croak(q/Usage: $handle->write(buf)/);
6104
      my ($self, $buf) = @_;
6105
  
6106
      if ( $] ge '5.008' ) {
6107
          utf8::downgrade($buf, 1)
6108
              or croak(q/Wide character in write()/);
6109
      }
6110
  
6111
      my $len = length $buf;
6112
      my $off = 0;
6113
  
6114
      local $SIG{PIPE} = 'IGNORE';
6115
  
6116
      while () {
6117
          $self->can_write
6118
            or croak(q/Timed out while waiting for socket to become ready for writing/);
6119
          my $r = syswrite($self->{fh}, $buf, $len, $off);
6120
          if (defined $r) {
6121
              $len -= $r;
6122
              $off += $r;
6123
              last unless $len > 0;
6124
          }
6125
          elsif ($! == EPIPE) {
6126
              croak(qq/Socket closed by remote server: $!/);
6127
          }
6128
          elsif ($! != EINTR) {
6129
              croak(qq/Could not write to socket: '$!'/);
6130
          }
6131
      }
6132
      return $off;
6133
  }
6134
  
6135
  sub read {
6136
      @_ == 2 || @_ == 3 || croak(q/Usage: $handle->read(len [, allow_partial])/);
6137
      my ($self, $len, $allow_partial) = @_;
6138
  
6139
      my $buf  = '';
6140
      my $got = length $self->{rbuf};
6141
  
6142
      if ($got) {
6143
          my $take = ($got < $len) ? $got : $len;
6144
          $buf  = substr($self->{rbuf}, 0, $take, '');
6145
          $len -= $take;
6146
      }
6147
  
6148
      while ($len > 0) {
6149
          $self->can_read
6150
            or croak(q/Timed out while waiting for socket to become ready for reading/);
6151
          my $r = sysread($self->{fh}, $buf, $len, length $buf);
6152
          if (defined $r) {
6153
              last unless $r;
6154
              $len -= $r;
6155
          }
6156
          elsif ($! != EINTR) {
6157
              croak(qq/Could not read from socket: '$!'/);
6158
          }
6159
      }
6160
      if ($len && !$allow_partial) {
6161
          croak(q/Unexpected end of stream/);
6162
      }
6163
      return $buf;
6164
  }
6165
  
6166
  sub readline {
6167
      @_ == 1 || croak(q/Usage: $handle->readline()/);
6168
      my ($self) = @_;
6169
  
6170
      while () {
6171
          if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) {
6172
              return $1;
6173
          }
6174
          if (length $self->{rbuf} >= $self->{max_line_size}) {
6175
              croak(qq/Line size exceeds the maximum allowed size of $self->{max_line_size}/);
6176
          }
6177
          $self->can_read
6178
            or croak(q/Timed out while waiting for socket to become ready for reading/);
6179
          my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf});
6180
          if (defined $r) {
6181
              last unless $r;
6182
          }
6183
          elsif ($! != EINTR) {
6184
              croak(qq/Could not read from socket: '$!'/);
6185
          }
6186
      }
6187
      croak(q/Unexpected end of stream while looking for line/);
6188
  }
6189
  
6190
  sub read_header_lines {
6191
      @_ == 1 || @_ == 2 || croak(q/Usage: $handle->read_header_lines([headers])/);
6192
      my ($self, $headers) = @_;
6193
      $headers ||= {};
6194
      my $lines   = 0;
6195
      my $val;
6196
  
6197
      while () {
6198
           my $line = $self->readline;
6199
  
6200
           if (++$lines >= $self->{max_header_lines}) {
6201
               croak(qq/Header lines exceeds maximum number allowed of $self->{max_header_lines}/);
6202
           }
6203
           elsif ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) {
6204
               my ($field_name) = lc $1;
6205
               if (exists $headers->{$field_name}) {
6206
                   for ($headers->{$field_name}) {
6207
                       $_ = [$_] unless ref $_ eq "ARRAY";
6208
                       push @$_, $2;
6209
                       $val = \$_->[-1];
6210
                   }
6211
               }
6212
               else {
6213
                   $val = \($headers->{$field_name} = $2);
6214
               }
6215
           }
6216
           elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) {
6217
               $val
6218
                 or croak(q/Unexpected header continuation line/);
6219
               next unless length $1;
6220
               $$val .= ' ' if length $$val;
6221
               $$val .= $1;
6222
           }
6223
           elsif ($line =~ /\A \x0D?\x0A \z/x) {
6224
              last;
6225
           }
6226
           else {
6227
              croak(q/Malformed header line: / . $Printable->($line));
6228
           }
6229
      }
6230
      return $headers;
6231
  }
6232
  
6233
  sub write_request {
6234
      @_ == 2 || croak(q/Usage: $handle->write_request(request)/);
6235
      my($self, $request) = @_;
6236
      $self->write_request_header(@{$request}{qw/method uri headers/});
6237
      $self->write_body($request) if $request->{cb};
6238
      return;
6239
  }
6240
  
6241
  my %HeaderCase = (
6242
      'content-md5'      => 'Content-MD5',
6243
      'etag'             => 'ETag',
6244
      'te'               => 'TE',
6245
      'www-authenticate' => 'WWW-Authenticate',
6246
      'x-xss-protection' => 'X-XSS-Protection',
6247
  );
6248
  
6249
  sub write_header_lines {
6250
      (@_ == 2 && ref $_[1] eq 'HASH') || croak(q/Usage: $handle->write_header_lines(headers)/);
6251
      my($self, $headers) = @_;
6252
  
6253
      my $buf = '';
6254
      while (my ($k, $v) = each %$headers) {
6255
          my $field_name = lc $k;
6256
          if (exists $HeaderCase{$field_name}) {
6257
              $field_name = $HeaderCase{$field_name};
6258
          }
6259
          else {
6260
              $field_name =~ /\A $Token+ \z/xo
6261
                or croak(q/Invalid HTTP header field name: / . $Printable->($field_name));
6262
              $field_name =~ s/\b(\w)/\u$1/g;
6263
              $HeaderCase{lc $field_name} = $field_name;
6264
          }
6265
          for (ref $v eq 'ARRAY' ? @$v : $v) {
6266
              /[^\x0D\x0A]/
6267
                or croak(qq/Invalid HTTP header field value ($field_name): / . $Printable->($_));
6268
              $buf .= "$field_name: $_\x0D\x0A";
6269
          }
6270
      }
6271
      $buf .= "\x0D\x0A";
6272
      return $self->write($buf);
6273
  }
6274
  
6275
  sub read_body {
6276
      @_ == 3 || croak(q/Usage: $handle->read_body(callback, response)/);
6277
      my ($self, $cb, $response) = @_;
6278
      my $te = $response->{headers}{'transfer-encoding'} || '';
6279
      if ( grep { /chunked/i } ( ref $te eq 'ARRAY' ? @$te : $te ) ) {
6280
          $self->read_chunked_body($cb, $response);
6281
      }
6282
      else {
6283
          $self->read_content_body($cb, $response);
6284
      }
6285
      return;
6286
  }
6287
  
6288
  sub write_body {
6289
      @_ == 2 || croak(q/Usage: $handle->write_body(request)/);
6290
      my ($self, $request) = @_;
6291
      if ($request->{headers}{'content-length'}) {
6292
          return $self->write_content_body($request);
6293
      }
6294
      else {
6295
          return $self->write_chunked_body($request);
6296
      }
6297
  }
6298
  
6299
  sub read_content_body {
6300
      @_ == 3 || @_ == 4 || croak(q/Usage: $handle->read_content_body(callback, response, [read_length])/);
6301
      my ($self, $cb, $response, $content_length) = @_;
6302
      $content_length ||= $response->{headers}{'content-length'};
6303
  
6304
      if ( $content_length ) {
6305
          my $len = $content_length;
6306
          while ($len > 0) {
6307
              my $read = ($len > BUFSIZE) ? BUFSIZE : $len;
6308
              $cb->($self->read($read, 0), $response);
6309
              $len -= $read;
6310
          }
6311
      }
6312
      else {
6313
          my $chunk;
6314
          $cb->($chunk, $response) while length( $chunk = $self->read(BUFSIZE, 1) );
6315
      }
6316
  
6317
      return;
6318
  }
6319
  
6320
  sub write_content_body {
6321
      @_ == 2 || croak(q/Usage: $handle->write_content_body(request)/);
6322
      my ($self, $request) = @_;
6323
  
6324
      my ($len, $content_length) = (0, $request->{headers}{'content-length'});
6325
      while () {
6326
          my $data = $request->{cb}->();
6327
  
6328
          defined $data && length $data
6329
            or last;
6330
  
6331
          if ( $] ge '5.008' ) {
6332
              utf8::downgrade($data, 1)
6333
                  or croak(q/Wide character in write_content()/);
6334
          }
6335
  
6336
          $len += $self->write($data);
6337
      }
6338
  
6339
      $len == $content_length
6340
        or croak(qq/Content-Length missmatch (got: $len expected: $content_length)/);
6341
  
6342
      return $len;
6343
  }
6344
  
6345
  sub read_chunked_body {
6346
      @_ == 3 || croak(q/Usage: $handle->read_chunked_body(callback, $response)/);
6347
      my ($self, $cb, $response) = @_;
6348
  
6349
      while () {
6350
          my $head = $self->readline;
6351
  
6352
          $head =~ /\A ([A-Fa-f0-9]+)/x
6353
            or croak(q/Malformed chunk head: / . $Printable->($head));
6354
  
6355
          my $len = hex($1)
6356
            or last;
6357
  
6358
          $self->read_content_body($cb, $response, $len);
6359
  
6360
          $self->read(2) eq "\x0D\x0A"
6361
            or croak(q/Malformed chunk: missing CRLF after chunk data/);
6362
      }
6363
      $self->read_header_lines($response->{headers});
6364
      return;
6365
  }
6366
  
6367
  sub write_chunked_body {
6368
      @_ == 2 || croak(q/Usage: $handle->write_chunked_body(request)/);
6369
      my ($self, $request) = @_;
6370
  
6371
      my $len = 0;
6372
      while () {
6373
          my $data = $request->{cb}->();
6374
  
6375
          defined $data && length $data
6376
            or last;
6377
  
6378
          if ( $] ge '5.008' ) {
6379
              utf8::downgrade($data, 1)
6380
                  or croak(q/Wide character in write_chunked_body()/);
6381
          }
6382
  
6383
          $len += length $data;
6384
  
6385
          my $chunk  = sprintf '%X', length $data;
6386
             $chunk .= "\x0D\x0A";
6387
             $chunk .= $data;
6388
             $chunk .= "\x0D\x0A";
6389
  
6390
          $self->write($chunk);
6391
      }
6392
      $self->write("0\x0D\x0A");
6393
      $self->write_header_lines($request->{trailer_cb}->())
6394
          if ref $request->{trailer_cb} eq 'CODE';
6395
      return $len;
6396
  }
6397
  
6398
  sub read_response_header {
6399
      @_ == 1 || croak(q/Usage: $handle->read_response_header()/);
6400
      my ($self) = @_;
6401
  
6402
      my $line = $self->readline;
6403
  
6404
      $line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x
6405
        or croak(q/Malformed Status-Line: / . $Printable->($line));
6406
  
6407
      my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
6408
  
6409
      croak (qq/Unsupported HTTP protocol: $protocol/)
6410
          unless $version =~ /0*1\.0*[01]/;
6411
  
6412
      return {
6413
          status   => $status,
6414
          reason   => $reason,
6415
          headers  => $self->read_header_lines,
6416
          protocol => $protocol,
6417
      };
6418
  }
6419
  
6420
  sub write_request_header {
6421
      @_ == 4 || croak(q/Usage: $handle->write_request_header(method, request_uri, headers)/);
6422
      my ($self, $method, $request_uri, $headers) = @_;
6423
  
6424
      return $self->write("$method $request_uri HTTP/1.1\x0D\x0A")
6425
           + $self->write_header_lines($headers);
6426
  }
6427
  
6428
  sub _do_timeout {
6429
      my ($self, $type, $timeout) = @_;
6430
      $timeout = $self->{timeout}
6431
          unless defined $timeout && $timeout >= 0;
6432
  
6433
      my $fd = fileno $self->{fh};
6434
      defined $fd && $fd >= 0
6435
        or croak(q/select(2): 'Bad file descriptor'/);
6436
  
6437
      my $initial = time;
6438
      my $pending = $timeout;
6439
      my $nfound;
6440
  
6441
      vec(my $fdset = '', $fd, 1) = 1;
6442
  
6443
      while () {
6444
          $nfound = ($type eq 'read')
6445
              ? select($fdset, undef, undef, $pending)
6446
              : select(undef, $fdset, undef, $pending) ;
6447
          if ($nfound == -1) {
6448
              $! == EINTR
6449
                or croak(qq/select(2): '$!'/);
6450
              redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0;
6451
              $nfound = 0;
6452
          }
6453
          last;
6454
      }
6455
      $! = 0;
6456
      return $nfound;
6457
  }
6458
  
6459
  sub can_read {
6460
      @_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_read([timeout])/);
6461
      my $self = shift;
6462
      return $self->_do_timeout('read', @_)
6463
  }
6464
  
6465
  sub can_write {
6466
      @_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_write([timeout])/);
6467
      my $self = shift;
6468
      return $self->_do_timeout('write', @_)
6469
  }
6470
  
6471
  1;
6472
  
6473
  
6474
  
6475
  __END__
6476
  =pod
6477
  
6478
HTTP_TINY
6479

            
6480
$fatpacked{"JSON/PP.pm"} = <<'JSON_PP';
6481
  package JSON::PP;
6482
  
6483
  # JSON-2.0
6484
  
6485
  use 5.005;
6486
  use strict;
6487
  use base qw(Exporter);
6488
  use overload ();
6489
  
6490
  use Carp ();
6491
  use B ();
6492
  #use Devel::Peek;
6493
  
6494
  $JSON::PP::VERSION = '2.27200';
6495
  
6496
  @JSON::PP::EXPORT = qw(encode_json decode_json from_json to_json);
6497
  
6498
  # instead of hash-access, i tried index-access for speed.
6499
  # but this method is not faster than what i expected. so it will be changed.
6500
  
6501
  use constant P_ASCII                => 0;
6502
  use constant P_LATIN1               => 1;
6503
  use constant P_UTF8                 => 2;
6504
  use constant P_INDENT               => 3;
6505
  use constant P_CANONICAL            => 4;
6506
  use constant P_SPACE_BEFORE         => 5;
6507
  use constant P_SPACE_AFTER          => 6;
6508
  use constant P_ALLOW_NONREF         => 7;
6509
  use constant P_SHRINK               => 8;
6510
  use constant P_ALLOW_BLESSED        => 9;
6511
  use constant P_CONVERT_BLESSED      => 10;
6512
  use constant P_RELAXED              => 11;
6513
  
6514
  use constant P_LOOSE                => 12;
6515
  use constant P_ALLOW_BIGNUM         => 13;
6516
  use constant P_ALLOW_BAREKEY        => 14;
6517
  use constant P_ALLOW_SINGLEQUOTE    => 15;
6518
  use constant P_ESCAPE_SLASH         => 16;
6519
  use constant P_AS_NONBLESSED        => 17;
6520
  
6521
  use constant P_ALLOW_UNKNOWN        => 18;
6522
  
6523
  use constant OLD_PERL => $] < 5.008 ? 1 : 0;
6524
  
6525
  BEGIN {
6526
      my @xs_compati_bit_properties = qw(
6527
              latin1 ascii utf8 indent canonical space_before space_after allow_nonref shrink
6528
              allow_blessed convert_blessed relaxed allow_unknown
6529
      );
6530
      my @pp_bit_properties = qw(
6531
              allow_singlequote allow_bignum loose
6532
              allow_barekey escape_slash as_nonblessed
6533
      );
6534
  
6535
      # Perl version check, Unicode handling is enable?
6536
      # Helper module sets @JSON::PP::_properties.
6537
      if ($] < 5.008 ) {
6538
          my $helper = $] >= 5.006 ? 'JSON::PP::Compat5006' : 'JSON::PP::Compat5005';
6539
          eval qq| require $helper |;
6540
          if ($@) { Carp::croak $@; }
6541
      }
6542
  
6543
      for my $name (@xs_compati_bit_properties, @pp_bit_properties) {
6544
          my $flag_name = 'P_' . uc($name);
6545
  
6546
          eval qq/
6547
              sub $name {
6548
                  my \$enable = defined \$_[1] ? \$_[1] : 1;
6549
  
6550
                  if (\$enable) {
6551
                      \$_[0]->{PROPS}->[$flag_name] = 1;
6552
                  }
6553
                  else {
6554
                      \$_[0]->{PROPS}->[$flag_name] = 0;
6555
                  }
6556
  
6557
                  \$_[0];
6558
              }
6559
  
6560
              sub get_$name {
6561
                  \$_[0]->{PROPS}->[$flag_name] ? 1 : '';
6562
              }
6563
          /;
6564
      }
6565
  
6566
  }
6567
  
6568
  
6569
  
6570
  # Functions
6571
  
6572
  my %encode_allow_method
6573
       = map {($_ => 1)} qw/utf8 pretty allow_nonref latin1 self_encode escape_slash
6574
                            allow_blessed convert_blessed indent indent_length allow_bignum
6575
                            as_nonblessed
6576
                          /;
6577
  my %decode_allow_method
6578
       = map {($_ => 1)} qw/utf8 allow_nonref loose allow_singlequote allow_bignum
6579
                            allow_barekey max_size relaxed/;
6580
  
6581
  
6582
  my $JSON; # cache
6583
  
6584
  sub encode_json ($) { # encode
6585
      ($JSON ||= __PACKAGE__->new->utf8)->encode(@_);
6586
  }
6587
  
6588
  
6589
  sub decode_json { # decode
6590
      ($JSON ||= __PACKAGE__->new->utf8)->decode(@_);
6591
  }
6592
  
6593
  # Obsoleted
6594
  
6595
  sub to_json($) {
6596
     Carp::croak ("JSON::PP::to_json has been renamed to encode_json.");
6597
  }
6598
  
6599
  
6600
  sub from_json($) {
6601
     Carp::croak ("JSON::PP::from_json has been renamed to decode_json.");
6602
  }
6603
  
6604
  
6605
  # Methods
6606
  
6607
  sub new {
6608
      my $class = shift;
6609
      my $self  = {
6610
          max_depth   => 512,
6611
          max_size    => 0,
6612
          indent      => 0,
6613
          FLAGS       => 0,
6614
          fallback      => sub { encode_error('Invalid value. JSON can only reference.') },
6615
          indent_length => 3,
6616
      };
6617
  
6618
      bless $self, $class;
6619
  }
6620
  
6621
  
6622
  sub encode {
6623
      return $_[0]->PP_encode_json($_[1]);
6624
  }
6625
  
6626
  
6627
  sub decode {
6628
      return $_[0]->PP_decode_json($_[1], 0x00000000);
6629
  }
6630
  
6631
  
6632
  sub decode_prefix {
6633
      return $_[0]->PP_decode_json($_[1], 0x00000001);
6634
  }
6635
  
6636
  
6637
  # accessor
6638
  
6639
  
6640
  # pretty printing
6641
  
6642
  sub pretty {
6643
      my ($self, $v) = @_;
6644
      my $enable = defined $v ? $v : 1;
6645
  
6646
      if ($enable) { # indent_length(3) for JSON::XS compatibility
6647
          $self->indent(1)->indent_length(3)->space_before(1)->space_after(1);
6648
      }
6649
      else {
6650
          $self->indent(0)->space_before(0)->space_after(0);
6651
      }
6652
  
6653
      $self;
6654
  }
6655
  
6656
  # etc
6657
  
6658
  sub max_depth {
6659
      my $max  = defined $_[1] ? $_[1] : 0x80000000;
6660
      $_[0]->{max_depth} = $max;
6661
      $_[0];
6662
  }
6663
  
6664
  
6665
  sub get_max_depth { $_[0]->{max_depth}; }
6666
  
6667
  
6668
  sub max_size {
6669
      my $max  = defined $_[1] ? $_[1] : 0;
6670
      $_[0]->{max_size} = $max;
6671
      $_[0];
6672
  }
6673
  
6674
  
6675
  sub get_max_size { $_[0]->{max_size}; }
6676
  
6677
  
6678
  sub filter_json_object {
6679
      $_[0]->{cb_object} = defined $_[1] ? $_[1] : 0;
6680
      $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
6681
      $_[0];
6682
  }
6683
  
6684
  sub filter_json_single_key_object {
6685
      if (@_ > 1) {
6686
          $_[0]->{cb_sk_object}->{$_[1]} = $_[2];
6687
      }
6688
      $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
6689
      $_[0];
6690
  }
6691
  
6692
  sub indent_length {
6693
      if (!defined $_[1] or $_[1] > 15 or $_[1] < 0) {
6694
          Carp::carp "The acceptable range of indent_length() is 0 to 15.";
6695
      }
6696
      else {
6697
          $_[0]->{indent_length} = $_[1];
6698
      }
6699
      $_[0];
6700
  }
6701
  
6702
  sub get_indent_length {
6703
      $_[0]->{indent_length};
6704
  }
6705
  
6706
  sub sort_by {
6707
      $_[0]->{sort_by} = defined $_[1] ? $_[1] : 1;
6708
      $_[0];
6709
  }
6710
  
6711
  sub allow_bigint {
6712
      Carp::carp("allow_bigint() is obsoleted. use allow_bignum() insted.");
6713
  }
6714
  
6715
  ###############################
6716
  
6717
  ###
6718
  ### Perl => JSON
6719
  ###
6720
  
6721
  
6722
  { # Convert
6723
  
6724
      my $max_depth;
6725
      my $indent;
6726
      my $ascii;
6727
      my $latin1;
6728
      my $utf8;
6729
      my $space_before;
6730
      my $space_after;
6731
      my $canonical;
6732
      my $allow_blessed;
6733
      my $convert_blessed;
6734
  
6735
      my $indent_length;
6736
      my $escape_slash;
6737
      my $bignum;
6738
      my $as_nonblessed;
6739
  
6740
      my $depth;
6741
      my $indent_count;
6742
      my $keysort;
6743
  
6744
  
6745
      sub PP_encode_json {
6746
          my $self = shift;
6747
          my $obj  = shift;
6748
  
6749
          $indent_count = 0;
6750
          $depth        = 0;
6751
  
6752
          my $idx = $self->{PROPS};
6753
  
6754
          ($ascii, $latin1, $utf8, $indent, $canonical, $space_before, $space_after, $allow_blessed,
6755
              $convert_blessed, $escape_slash, $bignum, $as_nonblessed)
6756
           = @{$idx}[P_ASCII .. P_SPACE_AFTER, P_ALLOW_BLESSED, P_CONVERT_BLESSED,
6757
                      P_ESCAPE_SLASH, P_ALLOW_BIGNUM, P_AS_NONBLESSED];
6758
  
6759
          ($max_depth, $indent_length) = @{$self}{qw/max_depth indent_length/};
6760
  
6761
          $keysort = $canonical ? sub { $a cmp $b } : undef;
6762
  
6763
          if ($self->{sort_by}) {
6764
              $keysort = ref($self->{sort_by}) eq 'CODE' ? $self->{sort_by}
6765
                       : $self->{sort_by} =~ /\D+/       ? $self->{sort_by}
6766
                       : sub { $a cmp $b };
6767
          }
6768
  
6769
          encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)")
6770
               if(!ref $obj and !$idx->[ P_ALLOW_NONREF ]);
6771
  
6772
          my $str  = $self->object_to_json($obj);
6773
  
6774
          $str .= "\n" if ( $indent ); # JSON::XS 2.26 compatible
6775
  
6776
          unless ($ascii or $latin1 or $utf8) {
6777
              utf8::upgrade($str);
6778
          }
6779
  
6780
          if ($idx->[ P_SHRINK ]) {
6781
              utf8::downgrade($str, 1);
6782
          }
6783
  
6784
          return $str;
6785
      }
6786
  
6787
  
6788
      sub object_to_json {
6789
          my ($self, $obj) = @_;
6790
          my $type = ref($obj);
6791
  
6792
          if($type eq 'HASH'){
6793
              return $self->hash_to_json($obj);
6794
          }
6795
          elsif($type eq 'ARRAY'){
6796
              return $self->array_to_json($obj);
6797
          }
6798
          elsif ($type) { # blessed object?
6799
              if (blessed($obj)) {
6800
  
6801
                  return $self->value_to_json($obj) if ( $obj->isa('JSON::PP::Boolean') );
6802
  
6803
                  if ( $convert_blessed and $obj->can('TO_JSON') ) {
6804
                      my $result = $obj->TO_JSON();
6805
                      if ( defined $result and ref( $result ) ) {
6806
                          if ( refaddr( $obj ) eq refaddr( $result ) ) {
6807
                              encode_error( sprintf(
6808
                                  "%s::TO_JSON method returned same object as was passed instead of a new one",
6809
                                  ref $obj
6810
                              ) );
6811
                          }
6812
                      }
6813
  
6814
                      return $self->object_to_json( $result );
6815
                  }
6816
  
6817
                  return "$obj" if ( $bignum and _is_bignum($obj) );
6818
                  return $self->blessed_to_json($obj) if ($allow_blessed and $as_nonblessed); # will be removed.
6819
  
6820
                  encode_error( sprintf("encountered object '%s', but neither allow_blessed "
6821
                      . "nor convert_blessed settings are enabled", $obj)
6822
                  ) unless ($allow_blessed);
6823
  
6824
                  return 'null';
6825
              }
6826
              else {
6827
                  return $self->value_to_json($obj);
6828
              }
6829
          }
6830
          else{
6831
              return $self->value_to_json($obj);
6832
          }
6833
      }
6834
  
6835
  
6836
      sub hash_to_json {
6837
          my ($self, $obj) = @_;
6838
          my @res;
6839
  
6840
          encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")
6841
                                           if (++$depth > $max_depth);
6842
  
6843
          my ($pre, $post) = $indent ? $self->_up_indent() : ('', '');
6844
          my $del = ($space_before ? ' ' : '') . ':' . ($space_after ? ' ' : '');
6845
  
6846
          for my $k ( _sort( $obj ) ) {
6847
              if ( OLD_PERL ) { utf8::decode($k) } # key for Perl 5.6 / be optimized
6848
              push @res, string_to_json( $self, $k )
6849
                            .  $del
6850
                            . ( $self->object_to_json( $obj->{$k} ) || $self->value_to_json( $obj->{$k} ) );
6851
          }
6852
  
6853
          --$depth;
6854
          $self->_down_indent() if ($indent);
6855
  
6856
          return   '{' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' )  . '}';
6857
      }
6858
  
6859
  
6860
      sub array_to_json {
6861
          my ($self, $obj) = @_;
6862
          my @res;
6863
  
6864
          encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")
6865
                                           if (++$depth > $max_depth);
6866
  
6867
          my ($pre, $post) = $indent ? $self->_up_indent() : ('', '');
6868
  
6869
          for my $v (@$obj){
6870
              push @res, $self->object_to_json($v) || $self->value_to_json($v);
6871
          }
6872
  
6873
          --$depth;
6874
          $self->_down_indent() if ($indent);
6875
  
6876
          return '[' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . ']';
6877
      }
6878
  
6879
  
6880
      sub value_to_json {
6881
          my ($self, $value) = @_;
6882
  
6883
          return 'null' if(!defined $value);
6884
  
6885
          my $b_obj = B::svref_2object(\$value);  # for round trip problem
6886
          my $flags = $b_obj->FLAGS;
6887
  
6888
          return $value # as is 
6889
              if $flags & ( B::SVp_IOK | B::SVp_NOK ) and !( $flags & B::SVp_POK ); # SvTYPE is IV or NV?
6890
  
6891
          my $type = ref($value);
6892
  
6893
          if(!$type){
6894
              return string_to_json($self, $value);
6895
          }
6896
          elsif( blessed($value) and  $value->isa('JSON::PP::Boolean') ){
6897
              return $$value == 1 ? 'true' : 'false';
6898
          }
6899
          elsif ($type) {
6900
              if ((overload::StrVal($value) =~ /=(\w+)/)[0]) {
6901
                  return $self->value_to_json("$value");
6902
              }
6903
  
6904
              if ($type eq 'SCALAR' and defined $$value) {
6905
                  return   $$value eq '1' ? 'true'
6906
                         : $$value eq '0' ? 'false'
6907
                         : $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ? 'null'
6908
                         : encode_error("cannot encode reference to scalar");
6909
              }
6910
  
6911
               if ( $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ) {
6912
                   return 'null';
6913
               }
6914
               else {
6915
                   if ( $type eq 'SCALAR' or $type eq 'REF' ) {
6916
                      encode_error("cannot encode reference to scalar");
6917
                   }
6918
                   else {
6919
                      encode_error("encountered $value, but JSON can only represent references to arrays or hashes");
6920
                   }
6921
               }
6922
  
6923
          }
6924
          else {
6925
              return $self->{fallback}->($value)
6926
                   if ($self->{fallback} and ref($self->{fallback}) eq 'CODE');
6927
              return 'null';
6928
          }
6929
  
6930
      }
6931
  
6932
  
6933
      my %esc = (
6934
          "\n" => '\n',
6935
          "\r" => '\r',
6936
          "\t" => '\t',
6937
          "\f" => '\f',
6938
          "\b" => '\b',
6939
          "\"" => '\"',
6940
          "\\" => '\\\\',
6941
          "\'" => '\\\'',
6942
      );
6943
  
6944
  
6945
      sub string_to_json {
6946
          my ($self, $arg) = @_;
6947
  
6948
          $arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g;
6949
          $arg =~ s/\//\\\//g if ($escape_slash);
6950
          $arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg;
6951
  
6952
          if ($ascii) {
6953
              $arg = JSON_PP_encode_ascii($arg);
6954
          }
6955
  
6956
          if ($latin1) {
6957
              $arg = JSON_PP_encode_latin1($arg);
6958
          }
6959
  
6960
          if ($utf8) {
6961
              utf8::encode($arg);
6962
          }
6963
  
6964
          return '"' . $arg . '"';
6965
      }
6966
  
6967
  
6968
      sub blessed_to_json {
6969
          my $reftype = reftype($_[1]) || '';
6970
          if ($reftype eq 'HASH') {
6971
              return $_[0]->hash_to_json($_[1]);
6972
          }
6973
          elsif ($reftype eq 'ARRAY') {
6974
              return $_[0]->array_to_json($_[1]);
6975
          }
6976
          else {
6977
              return 'null';
6978
          }
6979
      }
6980
  
6981
  
6982
      sub encode_error {
6983
          my $error  = shift;
6984
          Carp::croak "$error";
6985
      }
6986
  
6987
  
6988
      sub _sort {
6989
          defined $keysort ? (sort $keysort (keys %{$_[0]})) : keys %{$_[0]};
6990
      }
6991
  
6992
  
6993
      sub _up_indent {
6994
          my $self  = shift;
6995
          my $space = ' ' x $indent_length;
6996
  
6997
          my ($pre,$post) = ('','');
6998
  
6999
          $post = "\n" . $space x $indent_count;
7000
  
7001
          $indent_count++;
7002
  
7003
          $pre = "\n" . $space x $indent_count;
7004
  
7005
          return ($pre,$post);
7006
      }
7007
  
7008
  
7009
      sub _down_indent { $indent_count--; }
7010
  
7011
  
7012
      sub PP_encode_box {
7013
          {
7014
              depth        => $depth,
7015
              indent_count => $indent_count,
7016
          };
7017
      }
7018
  
7019
  } # Convert
7020
  
7021
  
7022
  sub _encode_ascii {
7023
      join('',
7024
          map {
7025
              $_ <= 127 ?
7026
                  chr($_) :
7027
              $_ <= 65535 ?
7028
                  sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
7029
          } unpack('U*', $_[0])
7030
      );
7031
  }
7032
  
7033
  
7034
  sub _encode_latin1 {
7035
      join('',
7036
          map {
7037
              $_ <= 255 ?
7038
                  chr($_) :
7039
              $_ <= 65535 ?
7040
                  sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
7041
          } unpack('U*', $_[0])
7042
      );
7043
  }
7044
  
7045
  
7046
  sub _encode_surrogates { # from perlunicode
7047
      my $uni = $_[0] - 0x10000;
7048
      return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00);
7049
  }
7050
  
7051
  
7052
  sub _is_bignum {
7053
      $_[0]->isa('Math::BigInt') or $_[0]->isa('Math::BigFloat');
7054
  }
7055
  
7056
  
7057
  
7058
  #
7059
  # JSON => Perl
7060
  #
7061
  
7062
  my $max_intsize;
7063
  
7064
  BEGIN {
7065
      my $checkint = 1111;
7066
      for my $d (5..64) {
7067
          $checkint .= 1;
7068
          my $int   = eval qq| $checkint |;
7069
          if ($int =~ /[eE]/) {
7070
              $max_intsize = $d - 1;
7071
              last;
7072
          }
7073
      }
7074
  }
7075
  
7076
  { # PARSE 
7077
  
7078
      my %escapes = ( #  by Jeremy Muhlich <jmuhlich [at] bitflood.org>
7079
          b    => "\x8",
7080
          t    => "\x9",
7081
          n    => "\xA",
7082
          f    => "\xC",
7083
          r    => "\xD",
7084
          '\\' => '\\',
7085
          '"'  => '"',
7086
          '/'  => '/',
7087
      );
7088
  
7089
      my $text; # json data
7090
      my $at;   # offset
7091
      my $ch;   # 1chracter
7092
      my $len;  # text length (changed according to UTF8 or NON UTF8)
7093
      # INTERNAL
7094
      my $depth;          # nest counter
7095
      my $encoding;       # json text encoding
7096
      my $is_valid_utf8;  # temp variable
7097
      my $utf8_len;       # utf8 byte length
7098
      # FLAGS
7099
      my $utf8;           # must be utf8
7100
      my $max_depth;      # max nest nubmer of objects and arrays
7101
      my $max_size;
7102
      my $relaxed;
7103
      my $cb_object;
7104
      my $cb_sk_object;
7105
  
7106
      my $F_HOOK;
7107
  
7108
      my $allow_bigint;   # using Math::BigInt
7109
      my $singlequote;    # loosely quoting
7110
      my $loose;          # 
7111
      my $allow_barekey;  # bareKey
7112
  
7113
      # $opt flag
7114
      # 0x00000001 .... decode_prefix
7115
      # 0x10000000 .... incr_parse
7116
  
7117
      sub PP_decode_json {
7118
          my ($self, $opt); # $opt is an effective flag during this decode_json.
7119
  
7120
          ($self, $text, $opt) = @_;
7121
  
7122
          ($at, $ch, $depth) = (0, '', 0);
7123
  
7124
          if ( !defined $text or ref $text ) {
7125
              decode_error("malformed JSON string, neither array, object, number, string or atom");
7126
          }
7127
  
7128
          my $idx = $self->{PROPS};
7129
  
7130
          ($utf8, $relaxed, $loose, $allow_bigint, $allow_barekey, $singlequote)
7131
              = @{$idx}[P_UTF8, P_RELAXED, P_LOOSE .. P_ALLOW_SINGLEQUOTE];
7132
  
7133
          if ( $utf8 ) {
7134
              utf8::downgrade( $text, 1 ) or Carp::croak("Wide character in subroutine entry");
7135
          }
7136
          else {
7137
              utf8::upgrade( $text );
7138
          }
7139
  
7140
          $len = length $text;
7141
  
7142
          ($max_depth, $max_size, $cb_object, $cb_sk_object, $F_HOOK)
7143
               = @{$self}{qw/max_depth  max_size cb_object cb_sk_object F_HOOK/};
7144
  
7145
          if ($max_size > 1) {
7146
              use bytes;
7147
              my $bytes = length $text;
7148
              decode_error(
7149
                  sprintf("attempted decode of JSON text of %s bytes size, but max_size is set to %s"
7150
                      , $bytes, $max_size), 1
7151
              ) if ($bytes > $max_size);
7152
          }
7153
  
7154
          # Currently no effect
7155
          # should use regexp
7156
          my @octets = unpack('C4', $text);
7157
          $encoding =   ( $octets[0] and  $octets[1]) ? 'UTF-8'
7158
                      : (!$octets[0] and  $octets[1]) ? 'UTF-16BE'
7159
                      : (!$octets[0] and !$octets[1]) ? 'UTF-32BE'
7160
                      : ( $octets[2]                ) ? 'UTF-16LE'
7161
                      : (!$octets[2]                ) ? 'UTF-32LE'
7162
                      : 'unknown';
7163
  
7164
          white(); # remove head white space
7165
  
7166
          my $valid_start = defined $ch; # Is there a first character for JSON structure?
7167
  
7168
          my $result = value();
7169
  
7170
          return undef if ( !$result && ( $opt & 0x10000000 ) ); # for incr_parse
7171
  
7172
          decode_error("malformed JSON string, neither array, object, number, string or atom") unless $valid_start;
7173
  
7174
          if ( !$idx->[ P_ALLOW_NONREF ] and !ref $result ) {
7175
                  decode_error(
7176
                  'JSON text must be an object or array (but found number, string, true, false or null,'
7177
                         . ' use allow_nonref to allow this)', 1);
7178
          }
7179
  
7180
          Carp::croak('something wrong.') if $len < $at; # we won't arrive here.
7181
  
7182
          my $consumed = defined $ch ? $at - 1 : $at; # consumed JSON text length
7183
  
7184
          white(); # remove tail white space
7185
  
7186
          if ( $ch ) {
7187
              return ( $result, $consumed ) if ($opt & 0x00000001); # all right if decode_prefix
7188
              decode_error("garbage after JSON object");
7189
          }
7190
  
7191
          ( $opt & 0x00000001 ) ? ( $result, $consumed ) : $result;
7192
      }
7193
  
7194
  
7195
      sub next_chr {
7196
          return $ch = undef if($at >= $len);
7197
          $ch = substr($text, $at++, 1);
7198
      }
7199
  
7200
  
7201
      sub value {
7202
          white();
7203
          return          if(!defined $ch);
7204
          return object() if($ch eq '{');
7205
          return array()  if($ch eq '[');
7206
          return string() if($ch eq '"' or ($singlequote and $ch eq "'"));
7207
          return number() if($ch =~ /[0-9]/ or $ch eq '-');
7208
          return word();
7209
      }
7210
  
7211
      sub string {
7212
          my ($i, $s, $t, $u);
7213
          my $utf16;
7214
          my $is_utf8;
7215
  
7216
          ($is_valid_utf8, $utf8_len) = ('', 0);
7217
  
7218
          $s = ''; # basically UTF8 flag on
7219
  
7220
          if($ch eq '"' or ($singlequote and $ch eq "'")){
7221
              my $boundChar = $ch;
7222
  
7223
              OUTER: while( defined(next_chr()) ){
7224
  
7225
                  if($ch eq $boundChar){
7226
                      next_chr();
7227
  
7228
                      if ($utf16) {
7229
                          decode_error("missing low surrogate character in surrogate pair");
7230
                      }
7231
  
7232
                      utf8::decode($s) if($is_utf8);
7233
  
7234
                      return $s;
7235
                  }
7236
                  elsif($ch eq '\\'){
7237
                      next_chr();
7238
                      if(exists $escapes{$ch}){
7239
                          $s .= $escapes{$ch};
7240
                      }
7241
                      elsif($ch eq 'u'){ # UNICODE handling
7242
                          my $u = '';
7243
  
7244
                          for(1..4){
7245
                              $ch = next_chr();
7246
                              last OUTER if($ch !~ /[0-9a-fA-F]/);
7247
                              $u .= $ch;
7248
                          }
7249
  
7250
                          # U+D800 - U+DBFF
7251
                          if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/) { # UTF-16 high surrogate?
7252
                              $utf16 = $u;
7253
                          }
7254
                          # U+DC00 - U+DFFF
7255
                          elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/) { # UTF-16 low surrogate?
7256
                              unless (defined $utf16) {
7257
                                  decode_error("missing high surrogate character in surrogate pair");
7258
                              }
7259
                              $is_utf8 = 1;
7260
                              $s .= JSON_PP_decode_surrogates($utf16, $u) || next;
7261
                              $utf16 = undef;
7262
                          }
7263
                          else {
7264
                              if (defined $utf16) {
7265
                                  decode_error("surrogate pair expected");
7266
                              }
7267
  
7268
                              if ( ( my $hex = hex( $u ) ) > 127 ) {
7269
                                  $is_utf8 = 1;
7270
                                  $s .= JSON_PP_decode_unicode($u) || next;
7271
                              }
7272
                              else {
7273
                                  $s .= chr $hex;
7274
                              }
7275
                          }
7276
  
7277
                      }
7278
                      else{
7279
                          unless ($loose) {
7280
                              $at -= 2;
7281
                              decode_error('illegal backslash escape sequence in string');
7282
                          }
7283
                          $s .= $ch;
7284
                      }
7285
                  }
7286
                  else{
7287
  
7288
                      if ( ord $ch  > 127 ) {
7289
                          if ( $utf8 ) {
7290
                              unless( $ch = is_valid_utf8($ch) ) {
7291
                                  $at -= 1;
7292
                                  decode_error("malformed UTF-8 character in JSON string");
7293
                              }
7294
                              else {
7295
                                  $at += $utf8_len - 1;
7296
                              }
7297
                          }
7298
                          else {
7299
                              utf8::encode( $ch );
7300
                          }
7301
  
7302
                          $is_utf8 = 1;
7303
                      }
7304
  
7305
                      if (!$loose) {
7306
                          if ($ch =~ /[\x00-\x1f\x22\x5c]/)  { # '/' ok
7307
                              $at--;
7308
                              decode_error('invalid character encountered while parsing JSON string');
7309
                          }
7310
                      }
7311
  
7312
                      $s .= $ch;
7313
                  }
7314
              }
7315
          }
7316
  
7317
          decode_error("unexpected end of string while parsing JSON string");
7318
      }
7319
  
7320
  
7321
      sub white {
7322
          while( defined $ch  ){
7323
              if($ch le ' '){
7324
                  next_chr();
7325
              }
7326
              elsif($ch eq '/'){
7327
                  next_chr();
7328
                  if(defined $ch and $ch eq '/'){
7329
                      1 while(defined(next_chr()) and $ch ne "\n" and $ch ne "\r");
7330
                  }
7331
                  elsif(defined $ch and $ch eq '*'){
7332
                      next_chr();
7333
                      while(1){
7334
                          if(defined $ch){
7335
                              if($ch eq '*'){
7336
                                  if(defined(next_chr()) and $ch eq '/'){
7337
                                      next_chr();
7338
                                      last;
7339
                                  }
7340
                              }
7341
                              else{
7342
                                  next_chr();
7343
                              }
7344
                          }
7345
                          else{
7346
                              decode_error("Unterminated comment");
7347
                          }
7348
                      }
7349
                      next;
7350
                  }
7351
                  else{
7352
                      $at--;
7353
                      decode_error("malformed JSON string, neither array, object, number, string or atom");
7354
                  }
7355
              }
7356
              else{
7357
                  if ($relaxed and $ch eq '#') { # correctly?
7358
                      pos($text) = $at;
7359
                      $text =~ /\G([^\n]*(?:\r\n|\r|\n|$))/g;
7360
                      $at = pos($text);
7361
                      next_chr;
7362
                      next;
7363
                  }
7364
  
7365
                  last;
7366
              }
7367
          }
7368
      }
7369
  
7370
  
7371
      sub array {
7372
          my $a  = $_[0] || []; # you can use this code to use another array ref object.
7373
  
7374
          decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')
7375
                                                      if (++$depth > $max_depth);
7376
  
7377
          next_chr();
7378
          white();
7379
  
7380
          if(defined $ch and $ch eq ']'){
7381
              --$depth;
7382
              next_chr();
7383
              return $a;
7384
          }
7385
          else {
7386
              while(defined($ch)){
7387
                  push @$a, value();
7388
  
7389
                  white();
7390
  
7391
                  if (!defined $ch) {
7392
                      last;
7393
                  }
7394
  
7395
                  if($ch eq ']'){
7396
                      --$depth;
7397
                      next_chr();
7398
                      return $a;
7399
                  }
7400
  
7401
                  if($ch ne ','){
7402
                      last;
7403
                  }
7404
  
7405
                  next_chr();
7406
                  white();
7407
  
7408
                  if ($relaxed and $ch eq ']') {
7409
                      --$depth;
7410
                      next_chr();
7411
                      return $a;
7412
                  }
7413
  
7414
              }
7415
          }
7416
  
7417
          decode_error(", or ] expected while parsing array");
7418
      }
7419
  
7420
  
7421
      sub object {
7422
          my $o = $_[0] || {}; # you can use this code to use another hash ref object.
7423
          my $k;
7424
  
7425
          decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')
7426
                                                  if (++$depth > $max_depth);
7427
          next_chr();
7428
          white();
7429
  
7430
          if(defined $ch and $ch eq '}'){
7431
              --$depth;
7432
              next_chr();
7433
              if ($F_HOOK) {
7434
                  return _json_object_hook($o);
7435
              }
7436
              return $o;
7437
          }
7438
          else {
7439
              while (defined $ch) {
7440
                  $k = ($allow_barekey and $ch ne '"' and $ch ne "'") ? bareKey() : string();
7441
                  white();
7442
  
7443
                  if(!defined $ch or $ch ne ':'){
7444
                      $at--;
7445
                      decode_error("':' expected");
7446
                  }
7447
  
7448
                  next_chr();
7449
                  $o->{$k} = value();
7450
                  white();
7451
  
7452
                  last if (!defined $ch);
7453
  
7454
                  if($ch eq '}'){
7455
                      --$depth;
7456
                      next_chr();
7457
                      if ($F_HOOK) {
7458
                          return _json_object_hook($o);
7459
                      }
7460
                      return $o;
7461
                  }
7462
  
7463
                  if($ch ne ','){
7464
                      last;
7465
                  }
7466
  
7467
                  next_chr();
7468
                  white();
7469
  
7470
                  if ($relaxed and $ch eq '}') {
7471
                      --$depth;
7472
                      next_chr();
7473
                      if ($F_HOOK) {
7474
                          return _json_object_hook($o);
7475
                      }
7476
                      return $o;
7477
                  }
7478
  
7479
              }
7480
  
7481
          }
7482
  
7483
          $at--;
7484
          decode_error(", or } expected while parsing object/hash");
7485
      }
7486
  
7487
  
7488
      sub bareKey { # doesn't strictly follow Standard ECMA-262 3rd Edition
7489
          my $key;
7490
          while($ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){
7491
              $key .= $ch;
7492
              next_chr();
7493
          }
7494
          return $key;
7495
      }
7496
  
7497
  
7498
      sub word {
7499
          my $word =  substr($text,$at-1,4);
7500
  
7501
          if($word eq 'true'){
7502
              $at += 3;
7503
              next_chr;
7504
              return $JSON::PP::true;
7505
          }
7506
          elsif($word eq 'null'){
7507
              $at += 3;
7508
              next_chr;
7509
              return undef;
7510
          }
7511
          elsif($word eq 'fals'){
7512
              $at += 3;
7513
              if(substr($text,$at,1) eq 'e'){
7514
                  $at++;
7515
                  next_chr;
7516
                  return $JSON::PP::false;
7517
              }
7518
          }
7519
  
7520
          $at--; # for decode_error report
7521
  
7522
          decode_error("'null' expected")  if ($word =~ /^n/);
7523
          decode_error("'true' expected")  if ($word =~ /^t/);
7524
          decode_error("'false' expected") if ($word =~ /^f/);
7525
          decode_error("malformed JSON string, neither array, object, number, string or atom");
7526
      }
7527
  
7528
  
7529
      sub number {
7530
          my $n    = '';
7531
          my $v;
7532
  
7533
          # According to RFC4627, hex or oct digts are invalid.
7534
          if($ch eq '0'){
7535
              my $peek = substr($text,$at,1);
7536
              my $hex  = $peek =~ /[xX]/; # 0 or 1
7537
  
7538
              if($hex){
7539
                  decode_error("malformed number (leading zero must not be followed by another digit)");
7540
                  ($n) = ( substr($text, $at+1) =~ /^([0-9a-fA-F]+)/);
7541
              }
7542
              else{ # oct
7543
                  ($n) = ( substr($text, $at) =~ /^([0-7]+)/);
7544
                  if (defined $n and length $n > 1) {
7545
                      decode_error("malformed number (leading zero must not be followed by another digit)");
7546
                  }
7547
              }
7548
  
7549
              if(defined $n and length($n)){
7550
                  if (!$hex and length($n) == 1) {
7551
                     decode_error("malformed number (leading zero must not be followed by another digit)");
7552
                  }
7553
                  $at += length($n) + $hex;
7554
                  next_chr;
7555
                  return $hex ? hex($n) : oct($n);
7556
              }
7557
          }
7558
  
7559
          if($ch eq '-'){
7560
              $n = '-';
7561
              next_chr;
7562
              if (!defined $ch or $ch !~ /\d/) {
7563
                  decode_error("malformed number (no digits after initial minus)");
7564
              }
7565
          }
7566
  
7567
          while(defined $ch and $ch =~ /\d/){
7568
              $n .= $ch;
7569
              next_chr;
7570
          }
7571
  
7572
          if(defined $ch and $ch eq '.'){
7573
              $n .= '.';
7574
  
7575
              next_chr;
7576
              if (!defined $ch or $ch !~ /\d/) {
7577
                  decode_error("malformed number (no digits after decimal point)");
7578
              }
7579
              else {
7580
                  $n .= $ch;
7581
              }
7582
  
7583
              while(defined(next_chr) and $ch =~ /\d/){
7584
                  $n .= $ch;
7585
              }
7586
          }
7587
  
7588
          if(defined $ch and ($ch eq 'e' or $ch eq 'E')){
7589
              $n .= $ch;
7590
              next_chr;
7591
  
7592
              if(defined($ch) and ($ch eq '+' or $ch eq '-')){
7593
                  $n .= $ch;
7594
                  next_chr;
7595
                  if (!defined $ch or $ch =~ /\D/) {
7596
                      decode_error("malformed number (no digits after exp sign)");
7597
                  }
7598
                  $n .= $ch;
7599
              }
7600
              elsif(defined($ch) and $ch =~ /\d/){
7601
                  $n .= $ch;
7602
              }
7603
              else {
7604
                  decode_error("malformed number (no digits after exp sign)");
7605
              }
7606
  
7607
              while(defined(next_chr) and $ch =~ /\d/){
7608
                  $n .= $ch;
7609
              }
7610
  
7611
          }
7612
  
7613
          $v .= $n;
7614
  
7615
          if ($v !~ /[.eE]/ and length $v > $max_intsize) {
7616
              if ($allow_bigint) { # from Adam Sussman
7617
                  require Math::BigInt;
7618
                  return Math::BigInt->new($v);
7619
              }
7620
              else {
7621
                  return "$v";
7622
              }
7623
          }
7624
          elsif ($allow_bigint) {
7625
              require Math::BigFloat;
7626
              return Math::BigFloat->new($v);
7627
          }
7628
  
7629
          return 0+$v;
7630
      }
7631
  
7632
  
7633
      sub is_valid_utf8 {
7634
  
7635
          $utf8_len = $_[0] =~ /[\x00-\x7F]/  ? 1
7636
                    : $_[0] =~ /[\xC2-\xDF]/  ? 2
7637
                    : $_[0] =~ /[\xE0-\xEF]/  ? 3
7638
                    : $_[0] =~ /[\xF0-\xF4]/  ? 4
7639
                    : 0
7640
                    ;
7641
  
7642
          return unless $utf8_len;
7643
  
7644
          my $is_valid_utf8 = substr($text, $at - 1, $utf8_len);
7645
  
7646
          return ( $is_valid_utf8 =~ /^(?:
7647
               [\x00-\x7F]
7648
              |[\xC2-\xDF][\x80-\xBF]
7649
              |[\xE0][\xA0-\xBF][\x80-\xBF]
7650
              |[\xE1-\xEC][\x80-\xBF][\x80-\xBF]
7651
              |[\xED][\x80-\x9F][\x80-\xBF]
7652
              |[\xEE-\xEF][\x80-\xBF][\x80-\xBF]
7653
              |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF]
7654
              |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF]
7655
              |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF]
7656
          )$/x )  ? $is_valid_utf8 : '';
7657
      }
7658
  
7659
  
7660
      sub decode_error {
7661
          my $error  = shift;
7662
          my $no_rep = shift;
7663
          my $str    = defined $text ? substr($text, $at) : '';
7664
          my $mess   = '';
7665
          my $type   = $] >= 5.008           ? 'U*'
7666
                     : $] <  5.006           ? 'C*'
7667
                     : utf8::is_utf8( $str ) ? 'U*' # 5.6
7668
                     : 'C*'
7669
                     ;
7670
  
7671
          for my $c ( unpack( $type, $str ) ) { # emulate pv_uni_display() ?
7672
              $mess .=  $c == 0x07 ? '\a'
7673
                      : $c == 0x09 ? '\t'
7674
                      : $c == 0x0a ? '\n'
7675
                      : $c == 0x0d ? '\r'
7676
                      : $c == 0x0c ? '\f'
7677
                      : $c <  0x20 ? sprintf('\x{%x}', $c)
7678
                      : $c == 0x5c ? '\\\\'
7679
                      : $c <  0x80 ? chr($c)
7680
                      : sprintf('\x{%x}', $c)
7681
                      ;
7682
              if ( length $mess >= 20 ) {
7683
                  $mess .= '...';
7684
                  last;
7685
              }
7686
          }
7687
  
7688
          unless ( length $mess ) {
7689
              $mess = '(end of string)';
7690
          }
7691
  
7692
          Carp::croak (
7693
              $no_rep ? "$error" : "$error, at character offset $at (before \"$mess\")"
7694
          );
7695
  
7696
      }
7697
  
7698
  
7699
      sub _json_object_hook {
7700
          my $o    = $_[0];
7701
          my @ks = keys %{$o};
7702
  
7703
          if ( $cb_sk_object and @ks == 1 and exists $cb_sk_object->{ $ks[0] } and ref $cb_sk_object->{ $ks[0] } ) {
7704
              my @val = $cb_sk_object->{ $ks[0] }->( $o->{$ks[0]} );
7705
              if (@val == 1) {
7706
                  return $val[0];
7707
              }
7708
          }
7709
  
7710
          my @val = $cb_object->($o) if ($cb_object);
7711
          if (@val == 0 or @val > 1) {
7712
              return $o;
7713
          }
7714
          else {
7715
              return $val[0];
7716
          }
7717
      }
7718
  
7719
  
7720
      sub PP_decode_box {
7721
          {
7722
              text    => $text,
7723
              at      => $at,
7724
              ch      => $ch,
7725
              len     => $len,
7726
              depth   => $depth,
7727
              encoding      => $encoding,
7728
              is_valid_utf8 => $is_valid_utf8,
7729
          };
7730
      }
7731
  
7732
  } # PARSE
7733
  
7734
  
7735
  sub _decode_surrogates { # from perlunicode
7736
      my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00);
7737
      my $un  = pack('U*', $uni);
7738
      utf8::encode( $un );
7739
      return $un;
7740
  }
7741
  
7742
  
7743
  sub _decode_unicode {
7744
      my $un = pack('U', hex shift);
7745
      utf8::encode( $un );
7746
      return $un;
7747
  }
7748
  
7749
  #
7750
  # Setup for various Perl versions (the code from JSON::PP58)
7751
  #
7752
  
7753
  BEGIN {
7754
  
7755
      unless ( defined &utf8::is_utf8 ) {
7756
         require Encode;
7757
         *utf8::is_utf8 = *Encode::is_utf8;
7758
      }
7759
  
7760
      if ( $] >= 5.008 ) {
7761
          *JSON::PP::JSON_PP_encode_ascii      = \&_encode_ascii;
7762
          *JSON::PP::JSON_PP_encode_latin1     = \&_encode_latin1;
7763
          *JSON::PP::JSON_PP_decode_surrogates = \&_decode_surrogates;
7764
          *JSON::PP::JSON_PP_decode_unicode    = \&_decode_unicode;
7765
      }
7766
  
7767
      if ($] >= 5.008 and $] < 5.008003) { # join() in 5.8.0 - 5.8.2 is broken.
7768
          package JSON::PP;
7769
          require subs;
7770
          subs->import('join');
7771
          eval q|
7772
              sub join {
7773
                  return '' if (@_ < 2);
7774
                  my $j   = shift;
7775
                  my $str = shift;
7776
                  for (@_) { $str .= $j . $_; }
7777
                  return $str;
7778
              }
7779
          |;
7780
      }
7781
  
7782
  
7783
      sub JSON::PP::incr_parse {
7784
          local $Carp::CarpLevel = 1;
7785
          ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ );
7786
      }
7787
  
7788
  
7789
      sub JSON::PP::incr_skip {
7790
          ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip;
7791
      }
7792
  
7793
  
7794
      sub JSON::PP::incr_reset {
7795
          ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset;
7796
      }
7797
  
7798
      eval q{
7799
          sub JSON::PP::incr_text : lvalue {
7800
              $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new;
7801
  
7802
              if ( $_[0]->{_incr_parser}->{incr_parsing} ) {
7803
                  Carp::croak("incr_text can not be called when the incremental parser already started parsing");
7804
              }
7805
              $_[0]->{_incr_parser}->{incr_text};
7806
          }
7807
      } if ( $] >= 5.006 );
7808
  
7809
  } # Setup for various Perl versions (the code from JSON::PP58)
7810
  
7811
  
7812
  ###############################
7813
  # Utilities
7814
  #
7815
  
7816
  BEGIN {
7817
      eval 'require Scalar::Util';
7818
      unless($@){
7819
          *JSON::PP::blessed = \&Scalar::Util::blessed;
7820
          *JSON::PP::reftype = \&Scalar::Util::reftype;
7821
          *JSON::PP::refaddr = \&Scalar::Util::refaddr;
7822
      }
7823
      else{ # This code is from Sclar::Util.
7824
          # warn $@;
7825
          eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }';
7826
          *JSON::PP::blessed = sub {
7827
              local($@, $SIG{__DIE__}, $SIG{__WARN__});
7828
              ref($_[0]) ? eval { $_[0]->a_sub_not_likely_to_be_here } : undef;
7829
          };
7830
          my %tmap = qw(
7831
              B::NULL   SCALAR
7832
              B::HV     HASH
7833
              B::AV     ARRAY
7834
              B::CV     CODE
7835
              B::IO     IO
7836
              B::GV     GLOB
7837
              B::REGEXP REGEXP
7838
          );
7839
          *JSON::PP::reftype = sub {
7840
              my $r = shift;
7841
  
7842
              return undef unless length(ref($r));
7843
  
7844
              my $t = ref(B::svref_2object($r));
7845
  
7846
              return
7847
                  exists $tmap{$t} ? $tmap{$t}
7848
                : length(ref($$r)) ? 'REF'
7849
                :                    'SCALAR';
7850
          };
7851
          *JSON::PP::refaddr = sub {
7852
            return undef unless length(ref($_[0]));
7853
  
7854
            my $addr;
7855
            if(defined(my $pkg = blessed($_[0]))) {
7856
              $addr .= bless $_[0], 'Scalar::Util::Fake';
7857
              bless $_[0], $pkg;
7858
            }
7859
            else {
7860
              $addr .= $_[0]
7861
            }
7862
  
7863
            $addr =~ /0x(\w+)/;
7864
            local $^W;
7865
            #no warnings 'portable';
7866
            hex($1);
7867
          }
7868
      }
7869
  }
7870
  
7871
  
7872
  # shamely copied and modified from JSON::XS code.
7873
  
7874
  $JSON::PP::true  = do { bless \(my $dummy = 1), "JSON::PP::Boolean" };
7875
  $JSON::PP::false = do { bless \(my $dummy = 0), "JSON::PP::Boolean" };
7876
  
7877
  sub is_bool { defined $_[0] and UNIVERSAL::isa($_[0], "JSON::PP::Boolean"); }
7878
  
7879
  sub true  { $JSON::PP::true  }
7880
  sub false { $JSON::PP::false }
7881
  sub null  { undef; }
7882
  
7883
  ###############################
7884
  
7885
  package JSON::PP::Boolean;
7886
  
7887
  use overload (
7888
     "0+"     => sub { ${$_[0]} },
7889
     "++"     => sub { $_[0] = ${$_[0]} + 1 },
7890
     "--"     => sub { $_[0] = ${$_[0]} - 1 },
7891
     fallback => 1,
7892
  );
7893
  
7894
  
7895
  ###############################
7896
  
7897
  package JSON::PP::IncrParser;
7898
  
7899
  use strict;
7900
  
7901
  use constant INCR_M_WS   => 0; # initial whitespace skipping
7902
  use constant INCR_M_STR  => 1; # inside string
7903
  use constant INCR_M_BS   => 2; # inside backslash
7904
  use constant INCR_M_JSON => 3; # outside anything, count nesting
7905
  use constant INCR_M_C0   => 4;
7906
  use constant INCR_M_C1   => 5;
7907
  
7908
  $JSON::PP::IncrParser::VERSION = '1.01';
7909
  
7910
  my $unpack_format = $] < 5.006 ? 'C*' : 'U*';
7911
  
7912
  sub new {
7913
      my ( $class ) = @_;
7914
  
7915
      bless {
7916
          incr_nest    => 0,
7917
          incr_text    => undef,
7918
          incr_parsing => 0,
7919
          incr_p       => 0,
7920
      }, $class;
7921
  }
7922
  
7923
  
7924
  sub incr_parse {
7925
      my ( $self, $coder, $text ) = @_;
7926
  
7927
      $self->{incr_text} = '' unless ( defined $self->{incr_text} );
7928
  
7929
      if ( defined $text ) {
7930
          if ( utf8::is_utf8( $text ) and !utf8::is_utf8( $self->{incr_text} ) ) {
7931
              utf8::upgrade( $self->{incr_text} ) ;
7932
              utf8::decode( $self->{incr_text} ) ;
7933
          }
7934
          $self->{incr_text} .= $text;
7935
      }
7936
  
7937
  
7938
      my $max_size = $coder->get_max_size;
7939
  
7940
      if ( defined wantarray ) {
7941
  
7942
          $self->{incr_mode} = INCR_M_WS unless defined $self->{incr_mode};
7943
  
7944
          if ( wantarray ) {
7945
              my @ret;
7946
  
7947
              $self->{incr_parsing} = 1;
7948
  
7949
              do {
7950
                  push @ret, $self->_incr_parse( $coder, $self->{incr_text} );
7951
  
7952
                  unless ( !$self->{incr_nest} and $self->{incr_mode} == INCR_M_JSON ) {
7953
                      $self->{incr_mode} = INCR_M_WS if $self->{incr_mode} != INCR_M_STR;
7954
                  }
7955
  
7956
              } until ( length $self->{incr_text} >= $self->{incr_p} );
7957
  
7958
              $self->{incr_parsing} = 0;
7959
  
7960
              return @ret;
7961
          }
7962
          else { # in scalar context
7963
              $self->{incr_parsing} = 1;
7964
              my $obj = $self->_incr_parse( $coder, $self->{incr_text} );
7965
              $self->{incr_parsing} = 0 if defined $obj; # pointed by Martin J. Evans
7966
              return $obj ? $obj : undef; # $obj is an empty string, parsing was completed.
7967
          }
7968
  
7969
      }
7970
  
7971
  }
7972
  
7973
  
7974
  sub _incr_parse {
7975
      my ( $self, $coder, $text, $skip ) = @_;
7976
      my $p = $self->{incr_p};
7977
      my $restore = $p;
7978
  
7979
      my @obj;
7980
      my $len = length $text;
7981
  
7982
      if ( $self->{incr_mode} == INCR_M_WS ) {
7983
          while ( $len > $p ) {
7984
              my $s = substr( $text, $p, 1 );
7985
              $p++ and next if ( 0x20 >= unpack($unpack_format, $s) );
7986
              $self->{incr_mode} = INCR_M_JSON;
7987
              last;
7988
         }
7989
      }
7990
  
7991
      while ( $len > $p ) {
7992
          my $s = substr( $text, $p++, 1 );
7993
  
7994
          if ( $s eq '"' ) {
7995
              if (substr( $text, $p - 2, 1 ) eq '\\' ) {
7996
                  next;
7997
              }
7998
  
7999
              if ( $self->{incr_mode} != INCR_M_STR  ) {
8000
                  $self->{incr_mode} = INCR_M_STR;
8001
              }
8002
              else {
8003
                  $self->{incr_mode} = INCR_M_JSON;
8004
                  unless ( $self->{incr_nest} ) {
8005
                      last;
8006
                  }
8007
              }
8008
          }
8009
  
8010
          if ( $self->{incr_mode} == INCR_M_JSON ) {
8011
  
8012
              if ( $s eq '[' or $s eq '{' ) {
8013
                  if ( ++$self->{incr_nest} > $coder->get_max_depth ) {
8014
                      Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)');
8015
                  }
8016
              }
8017
              elsif ( $s eq ']' or $s eq '}' ) {
8018
                  last if ( --$self->{incr_nest} <= 0 );
8019
              }
8020
              elsif ( $s eq '#' ) {
8021
                  while ( $len > $p ) {
8022
                      last if substr( $text, $p++, 1 ) eq "\n";
8023
                  }
8024
              }
8025
  
8026
          }
8027
  
8028
      }
8029
  
8030
      $self->{incr_p} = $p;
8031
  
8032
      return if ( $self->{incr_mode} == INCR_M_STR and not $self->{incr_nest} );
8033
      return if ( $self->{incr_mode} == INCR_M_JSON and $self->{incr_nest} > 0 );
8034
  
8035
      return '' unless ( length substr( $self->{incr_text}, 0, $p ) );
8036
  
8037
      local $Carp::CarpLevel = 2;
8038
  
8039
      $self->{incr_p} = $restore;
8040
      $self->{incr_c} = $p;
8041
  
8042
      my ( $obj, $tail ) = $coder->PP_decode_json( substr( $self->{incr_text}, 0, $p ), 0x10000001 );
8043
  
8044
      $self->{incr_text} = substr( $self->{incr_text}, $p );
8045
      $self->{incr_p} = 0;
8046
  
8047
      return $obj or '';
8048
  }
8049
  
8050
  
8051
  sub incr_text {
8052
      if ( $_[0]->{incr_parsing} ) {
8053
          Carp::croak("incr_text can not be called when the incremental parser already started parsing");
8054
      }
8055
      $_[0]->{incr_text};
8056
  }
8057
  
8058
  
8059
  sub incr_skip {
8060
      my $self  = shift;
8061
      $self->{incr_text} = substr( $self->{incr_text}, $self->{incr_c} );
8062
      $self->{incr_p} = 0;
8063
  }
8064
  
8065
  
8066
  sub incr_reset {
8067
      my $self = shift;
8068
      $self->{incr_text}    = undef;
8069
      $self->{incr_p}       = 0;
8070
      $self->{incr_mode}    = 0;
8071
      $self->{incr_nest}    = 0;
8072
      $self->{incr_parsing} = 0;
8073
  }
8074
  
8075
  ###############################
8076
  
8077
  
8078
  1;
8079
  __END__
8080
  =pod
8081
  
8082
JSON_PP
8083

            
8084
$fatpacked{"JSON/PP/Boolean.pm"} = <<'JSON_PP_BOOLEAN';
8085
  use JSON::PP ();
8086
  use strict;
8087
  
8088
  1;
8089
  
8090
JSON_PP_BOOLEAN
8091

            
8092
$fatpacked{"Module/Metadata.pm"} = <<'MODULE_METADATA';
8093
  # -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*-
8094
  # vim:ts=8:sw=2:et:sta:sts=2
8095
  package Module::Metadata;
8096
  
8097
  # Adapted from Perl-licensed code originally distributed with
8098
  # Module-Build by Ken Williams
8099
  
8100
  # This module provides routines to gather information about
8101
  # perl modules (assuming this may be expanded in the distant
8102
  # parrot future to look at other types of modules).
8103
  
8104
  use strict;
8105
  use vars qw($VERSION);
8106
  $VERSION = '1.000007';
8107
  $VERSION = eval $VERSION;
8108
  
8109
  use File::Spec;
8110
  use IO::File;
8111
  use version 0.87;
8112
  BEGIN {
8113
    if ($INC{'Log/Contextual.pm'}) {
8114
      Log::Contextual->import('log_info');
8115
    } else {
8116
      *log_info = sub (&) { warn $_[0]->() };
8117
    }
8118
  }
8119
  use File::Find qw(find);
8120
  
8121
  my $V_NUM_REGEXP = qr{v?[0-9._]+};  # crudely, a v-string or decimal
8122
  
8123
  my $PKG_REGEXP  = qr{   # match a package declaration
8124
    ^[\s\{;]*             # intro chars on a line
8125
    package               # the word 'package'
8126
    \s+                   # whitespace
8127
    ([\w:]+)              # a package name
8128
    \s*                   # optional whitespace
8129
    ($V_NUM_REGEXP)?        # optional version number
8130
    \s*                   # optional whitesapce
8131
    [;\{]                 # semicolon line terminator or block start (since 5.16)
8132
  }x;
8133
  
8134
  my $VARNAME_REGEXP = qr{ # match fully-qualified VERSION name
8135
    ([\$*])         # sigil - $ or *
8136
    (
8137
      (             # optional leading package name
8138
        (?:::|\')?  # possibly starting like just :: (�  la $::VERSION)
8139
        (?:\w+(?:::|\'))*  # Foo::Bar:: ...
8140
      )?
8141
      VERSION
8142
    )\b
8143
  }x;
8144
  
8145
  my $VERS_REGEXP = qr{ # match a VERSION definition
8146
    (?:
8147
      \(\s*$VARNAME_REGEXP\s*\) # with parens
8148
    |
8149
      $VARNAME_REGEXP           # without parens
8150
    )
8151
    \s*
8152
    =[^=~]  # = but not ==, nor =~
8153
  }x;
8154
  
8155
  
8156
  sub new_from_file {
8157
    my $class    = shift;
8158
    my $filename = File::Spec->rel2abs( shift );
8159
  
8160
    return undef unless defined( $filename ) && -f $filename;
8161
    return $class->_init(undef, $filename, @_);
8162
  }
8163
  
8164
  sub new_from_handle {
8165
    my $class    = shift;
8166
    my $handle   = shift;
8167
    my $filename = shift;
8168
    return undef unless defined($handle) && defined($filename);
8169
    $filename = File::Spec->rel2abs( $filename );
8170
  
8171
    return $class->_init(undef, $filename, @_, handle => $handle);
8172
  
8173
  }
8174
  
8175
  
8176
  sub new_from_module {
8177
    my $class   = shift;
8178
    my $module  = shift;
8179
    my %props   = @_;
8180
  
8181
    $props{inc} ||= \@INC;
8182
    my $filename = $class->find_module_by_name( $module, $props{inc} );
8183
    return undef unless defined( $filename ) && -f $filename;
8184
    return $class->_init($module, $filename, %props);
8185
  }
8186
  
8187
  {
8188
    
8189
    my $compare_versions = sub {
8190
      my ($v1, $op, $v2) = @_;
8191
      $v1 = version->new($v1)
8192
        unless UNIVERSAL::isa($v1,'version');
8193
    
8194
      my $eval_str = "\$v1 $op \$v2";
8195
      my $result   = eval $eval_str;
8196
      log_info { "error comparing versions: '$eval_str' $@" } if $@;
8197
    
8198
      return $result;
8199
    };
8200
  
8201
    my $normalize_version = sub {
8202
      my ($version) = @_;
8203
      if ( $version =~ /[=<>!,]/ ) { # logic, not just version
8204
        # take as is without modification
8205
      }
8206
      elsif ( ref $version eq 'version' ) { # version objects
8207
        $version = $version->is_qv ? $version->normal : $version->stringify;
8208
      }
8209
      elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots
8210
        # normalize string tuples without "v": "1.2.3" -> "v1.2.3"
8211
        $version = "v$version";
8212
      }
8213
      else {
8214
        # leave alone
8215
      }
8216
      return $version;
8217
    };
8218
  
8219
    # separate out some of the conflict resolution logic
8220
  
8221
    my $resolve_module_versions = sub {
8222
      my $packages = shift;
8223
    
8224
      my( $file, $version );
8225
      my $err = '';
8226
        foreach my $p ( @$packages ) {
8227
          if ( defined( $p->{version} ) ) {
8228
    	if ( defined( $version ) ) {
8229
     	  if ( $compare_versions->( $version, '!=', $p->{version} ) ) {
8230
    	    $err .= "  $p->{file} ($p->{version})\n";
8231
    	  } else {
8232
    	    # same version declared multiple times, ignore
8233
    	  }
8234
    	} else {
8235
    	  $file    = $p->{file};
8236
    	  $version = $p->{version};
8237
    	}
8238
          }
8239
          $file ||= $p->{file} if defined( $p->{file} );
8240
        }
8241
    
8242
      if ( $err ) {
8243
        $err = "  $file ($version)\n" . $err;
8244
      }
8245
    
8246
      my %result = (
8247
        file    => $file,
8248
        version => $version,
8249
        err     => $err
8250
      );
8251
    
8252
      return \%result;
8253
    };
8254
  
8255
    sub package_versions_from_directory {
8256
      my ( $class, $dir, $files ) = @_;
8257
  
8258
      my @files;
8259
  
8260
      if ( $files ) {
8261
        @files = @$files;
8262
      } else {
8263
        find( {
8264
          wanted => sub {
8265
            push @files, $_ if -f $_ && /\.pm$/;
8266
          },
8267
          no_chdir => 1,
8268
        }, $dir );
8269
      }
8270
  
8271
      # First, we enumerate all packages & versions,
8272
      # separating into primary & alternative candidates
8273
      my( %prime, %alt );
8274
      foreach my $file (@files) {
8275
        my $mapped_filename = File::Spec->abs2rel( $file, $dir );
8276
        my @path = split( /\//, $mapped_filename );
8277
        (my $prime_package = join( '::', @path )) =~ s/\.pm$//;
8278
    
8279
        my $pm_info = $class->new_from_file( $file );
8280
    
8281
        foreach my $package ( $pm_info->packages_inside ) {
8282
          next if $package eq 'main';  # main can appear numerous times, ignore
8283
          next if $package eq 'DB';    # special debugging package, ignore
8284
          next if grep /^_/, split( /::/, $package ); # private package, ignore
8285
    
8286
          my $version = $pm_info->version( $package );
8287
    
8288
          if ( $package eq $prime_package ) {
8289
            if ( exists( $prime{$package} ) ) {
8290
              die "Unexpected conflict in '$package'; multiple versions found.\n";
8291
            } else {
8292
              $prime{$package}{file} = $mapped_filename;
8293
              $prime{$package}{version} = $version if defined( $version );
8294
            }
8295
          } else {
8296
            push( @{$alt{$package}}, {
8297
                                      file    => $mapped_filename,
8298
                                      version => $version,
8299
                                     } );
8300
          }
8301
        }
8302
      }
8303
    
8304
      # Then we iterate over all the packages found above, identifying conflicts
8305
      # and selecting the "best" candidate for recording the file & version
8306
      # for each package.
8307
      foreach my $package ( keys( %alt ) ) {
8308
        my $result = $resolve_module_versions->( $alt{$package} );
8309
    
8310
        if ( exists( $prime{$package} ) ) { # primary package selected
8311
    
8312
          if ( $result->{err} ) {
8313
    	# Use the selected primary package, but there are conflicting
8314
    	# errors among multiple alternative packages that need to be
8315
    	# reported
8316
            log_info {
8317
    	    "Found conflicting versions for package '$package'\n" .
8318
    	    "  $prime{$package}{file} ($prime{$package}{version})\n" .
8319
    	    $result->{err}
8320
            };
8321
    
8322
          } elsif ( defined( $result->{version} ) ) {
8323
    	# There is a primary package selected, and exactly one
8324
    	# alternative package
8325
    
8326
    	if ( exists( $prime{$package}{version} ) &&
8327
    	     defined( $prime{$package}{version} ) ) {
8328
    	  # Unless the version of the primary package agrees with the
8329
    	  # version of the alternative package, report a conflict
8330
    	  if ( $compare_versions->(
8331
                   $prime{$package}{version}, '!=', $result->{version}
8332
                 )
8333
               ) {
8334
  
8335
              log_info {
8336
                "Found conflicting versions for package '$package'\n" .
8337
    	      "  $prime{$package}{file} ($prime{$package}{version})\n" .
8338
    	      "  $result->{file} ($result->{version})\n"
8339
              };
8340
    	  }
8341
    
8342
    	} else {
8343
    	  # The prime package selected has no version so, we choose to
8344
    	  # use any alternative package that does have a version
8345
    	  $prime{$package}{file}    = $result->{file};
8346
    	  $prime{$package}{version} = $result->{version};
8347
    	}
8348
    
8349
          } else {
8350
    	# no alt package found with a version, but we have a prime
8351
    	# package so we use it whether it has a version or not
8352
          }
8353
    
8354
        } else { # No primary package was selected, use the best alternative
8355
    
8356
          if ( $result->{err} ) {
8357
            log_info {
8358
              "Found conflicting versions for package '$package'\n" .
8359
    	    $result->{err}
8360
            };
8361
          }
8362
    
8363
          # Despite possible conflicting versions, we choose to record
8364
          # something rather than nothing
8365
          $prime{$package}{file}    = $result->{file};
8366
          $prime{$package}{version} = $result->{version}
8367
    	  if defined( $result->{version} );
8368
        }
8369
      }
8370
    
8371
      # Normalize versions.  Can't use exists() here because of bug in YAML::Node.
8372
      # XXX "bug in YAML::Node" comment seems irrelvant -- dagolden, 2009-05-18
8373
      for (grep defined $_->{version}, values %prime) {
8374
        $_->{version} = $normalize_version->( $_->{version} );
8375
      }
8376
    
8377
      return \%prime;
8378
    }
8379
  } 
8380
    
8381
  
8382
  sub _init {
8383
    my $class    = shift;
8384
    my $module   = shift;
8385
    my $filename = shift;
8386
    my %props = @_;
8387
  
8388
    my $handle = delete $props{handle};
8389
    my( %valid_props, @valid_props );
8390
    @valid_props = qw( collect_pod inc );
8391
    @valid_props{@valid_props} = delete( @props{@valid_props} );
8392
    warn "Unknown properties: @{[keys %props]}\n" if scalar( %props );
8393
  
8394
    my %data = (
8395
      module       => $module,
8396
      filename     => $filename,
8397
      version      => undef,
8398
      packages     => [],
8399
      versions     => {},
8400
      pod          => {},
8401
      pod_headings => [],
8402
      collect_pod  => 0,
8403
  
8404
      %valid_props,
8405
    );
8406
  
8407
    my $self = bless(\%data, $class);
8408
  
8409
    if ( $handle ) {
8410
      $self->_parse_fh($handle);
8411
    }
8412
    else {
8413
      $self->_parse_file();
8414
    }
8415
  
8416
    unless($self->{module} and length($self->{module})) {
8417
      my ($v, $d, $f) = File::Spec->splitpath($self->{filename});
8418
      if($f =~ /\.pm$/) {
8419
        $f =~ s/\..+$//;
8420
        my @candidates = grep /$f$/, @{$self->{packages}};
8421
        $self->{module} = shift(@candidates); # punt
8422
      }
8423
      else {
8424
        if(grep /main/, @{$self->{packages}}) {
8425
          $self->{module} = 'main';
8426
        }
8427
        else {
8428
          $self->{module} = $self->{packages}[0] || '';
8429
        }
8430
      }
8431
    }
8432
  
8433
    $self->{version} = $self->{versions}{$self->{module}}
8434
        if defined( $self->{module} );
8435
  
8436
    return $self;
8437
  }
8438
  
8439
  # class method
8440
  sub _do_find_module {
8441
    my $class   = shift;
8442
    my $module  = shift || die 'find_module_by_name() requires a package name';
8443
    my $dirs    = shift || \@INC;
8444
  
8445
    my $file = File::Spec->catfile(split( /::/, $module));
8446
    foreach my $dir ( @$dirs ) {
8447
      my $testfile = File::Spec->catfile($dir, $file);
8448
      return [ File::Spec->rel2abs( $testfile ), $dir ]
8449
  	if -e $testfile and !-d _;  # For stuff like ExtUtils::xsubpp
8450
      return [ File::Spec->rel2abs( "$testfile.pm" ), $dir ]
8451
  	if -e "$testfile.pm";
8452
    }
8453
    return;
8454
  }
8455
  
8456
  # class method
8457
  sub find_module_by_name {
8458
    my $found = shift()->_do_find_module(@_) or return;
8459
    return $found->[0];
8460
  }
8461
  
8462
  # class method
8463
  sub find_module_dir_by_name {
8464
    my $found = shift()->_do_find_module(@_) or return;
8465
    return $found->[1];
8466
  }
8467
  
8468
  
8469
  # given a line of perl code, attempt to parse it if it looks like a
8470
  # $VERSION assignment, returning sigil, full name, & package name
8471
  sub _parse_version_expression {
8472
    my $self = shift;
8473
    my $line = shift;
8474
  
8475
    my( $sig, $var, $pkg );
8476
    if ( $line =~ $VERS_REGEXP ) {
8477
      ( $sig, $var, $pkg ) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 );
8478
      if ( $pkg ) {
8479
        $pkg = ($pkg eq '::') ? 'main' : $pkg;
8480
        $pkg =~ s/::$//;
8481
      }
8482
    }
8483
  
8484
    return ( $sig, $var, $pkg );
8485
  }
8486
  
8487
  sub _parse_file {
8488
    my $self = shift;
8489
  
8490
    my $filename = $self->{filename};
8491
    my $fh = IO::File->new( $filename )
8492
      or die( "Can't open '$filename': $!" );
8493
  
8494
    $self->_parse_fh($fh);
8495
  }
8496
  
8497
  sub _parse_fh {
8498
    my ($self, $fh) = @_;
8499
  
8500
    my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 );
8501
    my( @pkgs, %vers, %pod, @pod );
8502
    my $pkg = 'main';
8503
    my $pod_sect = '';
8504
    my $pod_data = '';
8505
  
8506
    while (defined( my $line = <$fh> )) {
8507
      my $line_num = $.;
8508
  
8509
      chomp( $line );
8510
      next if $line =~ /^\s*#/;
8511
  
8512
      $in_pod = ($line =~ /^=(?!cut)/) ? 1 : ($line =~ /^=cut/) ? 0 : $in_pod;
8513
  
8514
      # Would be nice if we could also check $in_string or something too
8515
      last if !$in_pod && $line =~ /^__(?:DATA|END)__$/;
8516
  
8517
      if ( $in_pod || $line =~ /^=cut/ ) {
8518
  
8519
        if ( $line =~ /^=head\d\s+(.+)\s*$/ ) {
8520
  	push( @pod, $1 );
8521
  	if ( $self->{collect_pod} && length( $pod_data ) ) {
8522
            $pod{$pod_sect} = $pod_data;
8523
            $pod_data = '';
8524
          }
8525
  	$pod_sect = $1;
8526
  
8527
  
8528
        } elsif ( $self->{collect_pod} ) {
8529
  	$pod_data .= "$line\n";
8530
  
8531
        }
8532
  
8533
      } else {
8534
  
8535
        $pod_sect = '';
8536
        $pod_data = '';
8537
  
8538
        # parse $line to see if it's a $VERSION declaration
8539
        my( $vers_sig, $vers_fullname, $vers_pkg ) =
8540
  	  $self->_parse_version_expression( $line );
8541
  
8542
        if ( $line =~ $PKG_REGEXP ) {
8543
          $pkg = $1;
8544
          push( @pkgs, $pkg ) unless grep( $pkg eq $_, @pkgs );
8545
          $vers{$pkg} = (defined $2 ? $2 : undef)  unless exists( $vers{$pkg} );
8546
          $need_vers = defined $2 ? 0 : 1;
8547
  
8548
        # VERSION defined with full package spec, i.e. $Module::VERSION
8549
        } elsif ( $vers_fullname && $vers_pkg ) {
8550
  	push( @pkgs, $vers_pkg ) unless grep( $vers_pkg eq $_, @pkgs );
8551
  	$need_vers = 0 if $vers_pkg eq $pkg;
8552
  
8553
  	unless ( defined $vers{$vers_pkg} && length $vers{$vers_pkg} ) {
8554
  	  $vers{$vers_pkg} =
8555
  	    $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
8556
  	} else {
8557
  	  # Warn unless the user is using the "$VERSION = eval
8558
  	  # $VERSION" idiom (though there are probably other idioms
8559
  	  # that we should watch out for...)
8560
  	  warn <<"EOM" unless $line =~ /=\s*eval/;
8561
  Package '$vers_pkg' already declared with version '$vers{$vers_pkg}',
8562
  ignoring subsequent declaration on line $line_num.
8563
  EOM
8564
  	}
8565
  
8566
        # first non-comment line in undeclared package main is VERSION
8567
        } elsif ( !exists($vers{main}) && $pkg eq 'main' && $vers_fullname ) {
8568
  	$need_vers = 0;
8569
  	my $v =
8570
  	  $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
8571
  	$vers{$pkg} = $v;
8572
  	push( @pkgs, 'main' );
8573
  
8574
        # first non-comment line in undeclared package defines package main
8575
        } elsif ( !exists($vers{main}) && $pkg eq 'main' && $line =~ /\w+/ ) {
8576
  	$need_vers = 1;
8577
  	$vers{main} = '';
8578
  	push( @pkgs, 'main' );
8579
  
8580
        # only keep if this is the first $VERSION seen
8581
        } elsif ( $vers_fullname && $need_vers ) {
8582
  	$need_vers = 0;
8583
  	my $v =
8584
  	  $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
8585
  
8586
  
8587
  	unless ( defined $vers{$pkg} && length $vers{$pkg} ) {
8588
  	  $vers{$pkg} = $v;
8589
  	} else {
8590
  	  warn <<"EOM";
8591
  Package '$pkg' already declared with version '$vers{$pkg}'
8592
  ignoring new version '$v' on line $line_num.
8593
  EOM
8594
  	}
8595
  
8596
        }
8597
  
8598
      }
8599
  
8600
    }
8601
  
8602
    if ( $self->{collect_pod} && length($pod_data) ) {
8603
      $pod{$pod_sect} = $pod_data;
8604
    }
8605
  
8606
    $self->{versions} = \%vers;
8607
    $self->{packages} = \@pkgs;
8608
    $self->{pod} = \%pod;
8609
    $self->{pod_headings} = \@pod;
8610
  }
8611
  
8612
  {
8613
  my $pn = 0;
8614
  sub _evaluate_version_line {
8615
    my $self = shift;
8616
    my( $sigil, $var, $line ) = @_;
8617
  
8618
    # Some of this code came from the ExtUtils:: hierarchy.
8619
  
8620
    # We compile into $vsub because 'use version' would cause
8621
    # compiletime/runtime issues with local()
8622
    my $vsub;
8623
    $pn++; # everybody gets their own package
8624
    my $eval = qq{BEGIN { q#  Hide from _packages_inside()
8625
      #; package Module::Metadata::_version::p$pn;
8626
      use version;
8627
      no strict;
8628
  
8629
        \$vsub = sub {
8630
          local $sigil$var;
8631
          \$$var=undef;
8632
          $line;
8633
          \$$var
8634
        };
8635
    }};
8636
  
8637
    local $^W;
8638
    # Try to get the $VERSION
8639
    eval $eval;
8640
    # some modules say $VERSION = $Foo::Bar::VERSION, but Foo::Bar isn't
8641
    # installed, so we need to hunt in ./lib for it
8642
    if ( $@ =~ /Can't locate/ && -d 'lib' ) {
8643
      local @INC = ('lib',@INC);
8644
      eval $eval;
8645
    }
8646
    warn "Error evaling version line '$eval' in $self->{filename}: $@\n"
8647
      if $@;
8648
    (ref($vsub) eq 'CODE') or
8649
      die "failed to build version sub for $self->{filename}";
8650
    my $result = eval { $vsub->() };
8651
    die "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n"
8652
      if $@;
8653
  
8654
    # Upgrade it into a version object
8655
    my $version = eval { _dwim_version($result) };
8656
  
8657
    die "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n"
8658
      unless defined $version; # "0" is OK!
8659
  
8660
    return $version;
8661
  }
8662
  }
8663
  
8664
  # Try to DWIM when things fail the lax version test in obvious ways
8665
  {
8666
    my @version_prep = (
8667
      # Best case, it just works
8668
      sub { return shift },
8669
  
8670
      # If we still don't have a version, try stripping any
8671
      # trailing junk that is prohibited by lax rules
8672
      sub {
8673
        my $v = shift;
8674
        $v =~ s{([0-9])[a-z-].*$}{$1}i; # 1.23-alpha or 1.23b
8675
        return $v;
8676
      },
8677
  
8678
      # Activestate apparently creates custom versions like '1.23_45_01', which
8679
      # cause version.pm to think it's an invalid alpha.  So check for that
8680
      # and strip them
8681
      sub {
8682
        my $v = shift;
8683
        my $num_dots = () = $v =~ m{(\.)}g;
8684
        my $num_unders = () = $v =~ m{(_)}g;
8685
        my $leading_v = substr($v,0,1) eq 'v';
8686
        if ( ! $leading_v && $num_dots < 2 && $num_unders > 1 ) {
8687
          $v =~ s{_}{}g;
8688
          $num_unders = () = $v =~ m{(_)}g;
8689
        }
8690
        return $v;
8691
      },
8692
  
8693
      # Worst case, try numifying it like we would have before version objects
8694
      sub {
8695
        my $v = shift;
8696
        no warnings 'numeric';
8697
        return 0 + $v;
8698
      },
8699
  
8700
    );
8701
  
8702
    sub _dwim_version {
8703
      my ($result) = shift;
8704
  
8705
      return $result if ref($result) eq 'version';
8706
  
8707
      my ($version, $error);
8708
      for my $f (@version_prep) {
8709
        $result = $f->($result);
8710
        $version = eval { version->new($result) };
8711
        $error ||= $@ if $@; # capture first failure
8712
        last if defined $version;
8713
      }
8714
  
8715
      die $error unless defined $version;
8716
  
8717
      return $version;
8718
    }
8719
  }
8720
  
8721
  ############################################################
8722
  
8723
  # accessors
8724
  sub name            { $_[0]->{module}           }
8725
  
8726
  sub filename        { $_[0]->{filename}         }
8727
  sub packages_inside { @{$_[0]->{packages}}      }
8728
  sub pod_inside      { @{$_[0]->{pod_headings}}  }
8729
  sub contains_pod    { $#{$_[0]->{pod_headings}} }
8730
  
8731
  sub version {
8732
      my $self = shift;
8733
      my $mod  = shift || $self->{module};
8734
      my $vers;
8735
      if ( defined( $mod ) && length( $mod ) &&
8736
  	 exists( $self->{versions}{$mod} ) ) {
8737
  	return $self->{versions}{$mod};
8738
      } else {
8739
  	return undef;
8740
      }
8741
  }
8742
  
8743
  sub pod {
8744
      my $self = shift;
8745
      my $sect = shift;
8746
      if ( defined( $sect ) && length( $sect ) &&
8747
  	 exists( $self->{pod}{$sect} ) ) {
8748
  	return $self->{pod}{$sect};
8749
      } else {
8750
  	return undef;
8751
      }
8752
  }
8753
  
8754
  1;
8755
  
8756
MODULE_METADATA
8757

            
8758
$fatpacked{"Parse/CPAN/Meta.pm"} = <<'PARSE_CPAN_META';
8759
  package Parse::CPAN::Meta;
8760
  
8761
  use strict;
8762
  use Carp 'croak';
8763
  
8764
  # UTF Support?
8765
  sub HAVE_UTF8 () { $] >= 5.007003 }
8766
  sub IO_LAYER () { $] >= 5.008001 ? ":utf8" : "" }  
8767
  
8768
  BEGIN {
8769
  	if ( HAVE_UTF8 ) {
8770
  		# The string eval helps hide this from Test::MinimumVersion
8771
  		eval "require utf8;";
8772
  		die "Failed to load UTF-8 support" if $@;
8773
  	}
8774
  
8775
  	# Class structure
8776
  	require 5.004;
8777
  	require Exporter;
8778
  	$Parse::CPAN::Meta::VERSION   = '1.4401';
8779
  	@Parse::CPAN::Meta::ISA       = qw{ Exporter      };
8780
  	@Parse::CPAN::Meta::EXPORT_OK = qw{ Load LoadFile };
8781
  }
8782
  
8783
  sub load_file {
8784
    my ($class, $filename) = @_;
8785
  
8786
    if ($filename =~ /\.ya?ml$/) {
8787
      return $class->load_yaml_string(_slurp($filename));
8788
    }
8789
  
8790
    if ($filename =~ /\.json$/) {
8791
      return $class->load_json_string(_slurp($filename));
8792
    }
8793
  
8794
    croak("file type cannot be determined by filename");
8795
  }
8796
  
8797
  sub load_yaml_string {
8798
    my ($class, $string) = @_;
8799
    my $backend = $class->yaml_backend();
8800
    my $data = eval { no strict 'refs'; &{"$backend\::Load"}($string) };
8801
    if ( $@ ) { 
8802
      croak $backend->can('errstr') ? $backend->errstr : $@
8803
    }
8804
    return $data || {}; # in case document was valid but empty
8805
  }
8806
  
8807
  sub load_json_string {
8808
    my ($class, $string) = @_;
8809
    return $class->json_backend()->new->decode($string);
8810
  }
8811
  
8812
  sub yaml_backend {
8813
    local $Module::Load::Conditional::CHECK_INC_HASH = 1;
8814
    if (! defined $ENV{PERL_YAML_BACKEND} ) {
8815
      _can_load( 'CPAN::Meta::YAML', 0.002 )
8816
        or croak "CPAN::Meta::YAML 0.002 is not available\n";
8817
      return "CPAN::Meta::YAML";
8818
    }
8819
    else {
8820
      my $backend = $ENV{PERL_YAML_BACKEND};
8821
      _can_load( $backend )
8822
        or croak "Could not load PERL_YAML_BACKEND '$backend'\n";
8823
      $backend->can("Load")
8824
        or croak "PERL_YAML_BACKEND '$backend' does not implement Load()\n";
8825
      return $backend;
8826
    }
8827
  }
8828
  
8829
  sub json_backend {
8830
    local $Module::Load::Conditional::CHECK_INC_HASH = 1;
8831
    if (! $ENV{PERL_JSON_BACKEND} or $ENV{PERL_JSON_BACKEND} eq 'JSON::PP') {
8832
      _can_load( 'JSON::PP' => 2.27103 )
8833
        or croak "JSON::PP 2.27103 is not available\n";
8834
      return 'JSON::PP';
8835
    }
8836
    else {
8837
      _can_load( 'JSON' => 2.5 )
8838
        or croak  "JSON 2.5 is required for " .
8839
                  "\$ENV{PERL_JSON_BACKEND} = '$ENV{PERL_JSON_BACKEND}'\n";
8840
      return "JSON";
8841
    }
8842
  }
8843
  
8844
  sub _slurp {
8845
    open my $fh, "<" . IO_LAYER, "$_[0]"
8846
      or die "can't open $_[0] for reading: $!";
8847
    return do { local $/; <$fh> };
8848
  }
8849
    
8850
  sub _can_load {
8851
    my ($module, $version) = @_;
8852
    (my $file = $module) =~ s{::}{/}g;
8853
    $file .= ".pm";
8854
    return 1 if $INC{$file};
8855
    return 0 if exists $INC{$file}; # prior load failed
8856
    eval { require $file; 1 }
8857
      or return 0;
8858
    if ( defined $version ) {
8859
      eval { $module->VERSION($version); 1 }
8860
        or return 0;
8861
    }
8862
    return 1;
8863
  }
8864
  
8865
  # Kept for backwards compatibility only
8866
  # Create an object from a file
8867
  sub LoadFile ($) {
8868
    require CPAN::Meta::YAML;
8869
    return CPAN::Meta::YAML::LoadFile(shift)
8870
      or die CPAN::Meta::YAML->errstr;
8871
  }
8872
  
8873
  # Parse a document from a string.
8874
  sub Load ($) {
8875
    require CPAN::Meta::YAML;
8876
    return CPAN::Meta::YAML::Load(shift)
8877
      or die CPAN::Meta::YAML->errstr;
8878
  }
8879
  
8880
  1;
8881
  
8882
  __END__
8883
  
8884
PARSE_CPAN_META
8885

            
8886
$fatpacked{"Try/Tiny.pm"} = <<'TRY_TINY';
8887
  package Try::Tiny;
8888
  
8889
  use strict;
8890
  #use warnings;
8891
  
8892
  use vars qw(@EXPORT @EXPORT_OK $VERSION @ISA);
8893
  
8894
  BEGIN {
8895
  	require Exporter;
8896
  	@ISA = qw(Exporter);
8897
  }
8898
  
8899
  $VERSION = "0.09";
8900
  
8901
  $VERSION = eval $VERSION;
8902
  
8903
  @EXPORT = @EXPORT_OK = qw(try catch finally);
8904
  
8905
  $Carp::Internal{+__PACKAGE__}++;
8906
  
8907
  # Need to prototype as @ not $$ because of the way Perl evaluates the prototype.
8908
  # Keeping it at $$ means you only ever get 1 sub because we need to eval in a list
8909
  # context & not a scalar one
8910
  
8911
  sub try (&;@) {
8912
  	my ( $try, @code_refs ) = @_;
8913
  
8914
  	# we need to save this here, the eval block will be in scalar context due
8915
  	# to $failed
8916
  	my $wantarray = wantarray;
8917
  
8918
  	my ( $catch, @finally );
8919
  
8920
  	# find labeled blocks in the argument list.
8921
  	# catch and finally tag the blocks by blessing a scalar reference to them.
8922
  	foreach my $code_ref (@code_refs) {
8923
  		next unless $code_ref;
8924
  
8925
  		my $ref = ref($code_ref);
8926
  
8927
  		if ( $ref eq 'Try::Tiny::Catch' ) {
8928
  			$catch = ${$code_ref};
8929
  		} elsif ( $ref eq 'Try::Tiny::Finally' ) {
8930
  			push @finally, ${$code_ref};
8931
  		} else {
8932
  			use Carp;
8933
  			confess("Unknown code ref type given '${ref}'. Check your usage & try again");
8934
  		}
8935
  	}
8936
  
8937
  	# save the value of $@ so we can set $@ back to it in the beginning of the eval
8938
  	my $prev_error = $@;
8939
  
8940
  	my ( @ret, $error, $failed );
8941
  
8942
  	# FIXME consider using local $SIG{__DIE__} to accumulate all errors. It's
8943
  	# not perfect, but we could provide a list of additional errors for
8944
  	# $catch->();
8945
  
8946
  	{
8947
  		# localize $@ to prevent clobbering of previous value by a successful
8948
  		# eval.
8949
  		local $@;
8950
  
8951
  		# failed will be true if the eval dies, because 1 will not be returned
8952
  		# from the eval body
8953
  		$failed = not eval {
8954
  			$@ = $prev_error;
8955
  
8956
  			# evaluate the try block in the correct context
8957
  			if ( $wantarray ) {
8958
  				@ret = $try->();
8959
  			} elsif ( defined $wantarray ) {
8960
  				$ret[0] = $try->();
8961
  			} else {
8962
  				$try->();
8963
  			};
8964
  
8965
  			return 1; # properly set $fail to false
8966
  		};
8967
  
8968
  		# copy $@ to $error; when we leave this scope, local $@ will revert $@
8969
  		# back to its previous value
8970
  		$error = $@;
8971
  	}
8972
  
8973
  	# set up a scope guard to invoke the finally block at the end
8974
  	my @guards =
8975
      map { Try::Tiny::ScopeGuard->_new($_, $failed ? $error : ()) }
8976
      @finally;
8977
  
8978
  	# at this point $failed contains a true value if the eval died, even if some
8979
  	# destructor overwrote $@ as the eval was unwinding.
8980
  	if ( $failed ) {
8981
  		# if we got an error, invoke the catch block.
8982
  		if ( $catch ) {
8983
  			# This works like given($error), but is backwards compatible and
8984
  			# sets $_ in the dynamic scope for the body of C<$catch>
8985
  			for ($error) {
8986
  				return $catch->($error);
8987
  			}
8988
  
8989
  			# in case when() was used without an explicit return, the C<for>
8990
  			# loop will be aborted and there's no useful return value
8991
  		}
8992
  
8993
  		return;
8994
  	} else {
8995
  		# no failure, $@ is back to what it was, everything is fine
8996
  		return $wantarray ? @ret : $ret[0];
8997
  	}
8998
  }
8999
  
9000
  sub catch (&;@) {
9001
  	my ( $block, @rest ) = @_;
9002
  
9003
  	return (
9004
  		bless(\$block, 'Try::Tiny::Catch'),
9005
  		@rest,
9006
  	);
9007
  }
9008
  
9009
  sub finally (&;@) {
9010
  	my ( $block, @rest ) = @_;
9011
  
9012
  	return (
9013
  		bless(\$block, 'Try::Tiny::Finally'),
9014
  		@rest,
9015
  	);
9016
  }
9017
  
9018
  {
9019
    package # hide from PAUSE
9020
      Try::Tiny::ScopeGuard;
9021
  
9022
    sub _new {
9023
      shift;
9024
      bless [ @_ ];
9025
    }
9026
  
9027
    sub DESTROY {
9028
      my @guts = @{ shift() };
9029
      my $code = shift @guts;
9030
      $code->(@guts);
9031
    }
9032
  }
9033
  
9034
  __PACKAGE__
9035
  
9036
  __END__
9037
  
9038
TRY_TINY
9039

            
9040
$fatpacked{"lib/core/only.pm"} = <<'LIB_CORE_ONLY';
9041
  package lib::core::only;
9042
  
9043
  use strict;
9044
  use warnings FATAL => 'all';
9045
  use Config;
9046
  
9047
  sub import {
9048
    @INC = @Config{qw(privlibexp archlibexp)};
9049
    return
9050
  }
9051
  
9052
  1;
9053
LIB_CORE_ONLY
9054

            
9055
$fatpacked{"local/lib.pm"} = <<'LOCAL_LIB';
9056
  use strict;
9057
  use warnings;
9058
  
9059
  package local::lib;
9060
  
9061
  use 5.008001; # probably works with earlier versions but I'm not supporting them
9062
                # (patches would, of course, be welcome)
9063
  
9064
  use File::Spec ();
9065
  use File::Path ();
9066
  use Carp ();
9067
  use Config;
9068
  
9069
  our $VERSION = '1.008001'; # 1.8.1
9070
  
9071
  our @KNOWN_FLAGS = qw(--self-contained);
9072
  
9073
  sub import {
9074
    my ($class, @args) = @_;
9075
  
9076
    # Remember what PERL5LIB was when we started
9077
    my $perl5lib = $ENV{PERL5LIB} || '';
9078
  
9079
    my %arg_store;
9080
    for my $arg (@args) {
9081
      # check for lethal dash first to stop processing before causing problems
9082
      if ($arg =~ /−/) {
9083
        die <<'DEATH';
9084
  WHOA THERE! It looks like you've got some fancy dashes in your commandline!
9085
  These are *not* the traditional -- dashes that software recognizes. You
9086
  probably got these by copy-pasting from the perldoc for this module as
9087
  rendered by a UTF8-capable formatter. This most typically happens on an OS X
9088
  terminal, but can happen elsewhere too. Please try again after replacing the
9089
  dashes with normal minus signs.
9090
  DEATH
9091
      }
9092
      elsif(grep { $arg eq $_ } @KNOWN_FLAGS) {
9093
        (my $flag = $arg) =~ s/--//;
9094
        $arg_store{$flag} = 1;
9095
      }
9096
      elsif($arg =~ /^--/) {
9097
        die "Unknown import argument: $arg";
9098
      }
9099
      else {
9100
        # assume that what's left is a path
9101
        $arg_store{path} = $arg;
9102
      }
9103
    }
9104
  
9105
    if($arg_store{'self-contained'}) {
9106
      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";
9107
    }
9108
  
9109
    $arg_store{path} = $class->resolve_path($arg_store{path});
9110
    $class->setup_local_lib_for($arg_store{path});
9111
  
9112
    for (@INC) { # Untaint @INC
9113
      next if ref; # Skip entry if it is an ARRAY, CODE, blessed, etc.
9114
      m/(.*)/ and $_ = $1;
9115
    }
9116
  }
9117
  
9118
  sub pipeline;
9119
  
9120
  sub pipeline {
9121
    my @methods = @_;
9122
    my $last = pop(@methods);
9123
    if (@methods) {
9124
      \sub {
9125
        my ($obj, @args) = @_;
9126
        $obj->${pipeline @methods}(
9127
          $obj->$last(@args)
9128
        );
9129
      };
9130
    } else {
9131
      \sub {
9132
        shift->$last(@_);
9133
      };
9134
    }
9135
  }
9136
  
9137
  sub _uniq {
9138
      my %seen;
9139
      grep { ! $seen{$_}++ } @_;
9140
  }
9141
  
9142
  sub resolve_path {
9143
    my ($class, $path) = @_;
9144
    $class->${pipeline qw(
9145
      resolve_relative_path
9146
      resolve_home_path
9147
      resolve_empty_path
9148
    )}($path);
9149
  }
9150
  
9151
  sub resolve_empty_path {
9152
    my ($class, $path) = @_;
9153
    if (defined $path) {
9154
      $path;
9155
    } else {
9156
      '~/perl5';
9157
    }
9158
  }
9159
  
9160
  sub resolve_home_path {
9161
    my ($class, $path) = @_;
9162
    return $path unless ($path =~ /^~/);
9163
    my ($user) = ($path =~ /^~([^\/]+)/); # can assume ^~ so undef for 'us'
9164
    my $tried_file_homedir;
9165
    my $homedir = do {
9166
      if (eval { require File::HomeDir } && $File::HomeDir::VERSION >= 0.65) {
9167
        $tried_file_homedir = 1;
9168
        if (defined $user) {
9169
          File::HomeDir->users_home($user);
9170
        } else {
9171
          File::HomeDir->my_home;
9172
        }
9173
      } else {
9174
        if (defined $user) {
9175
          (getpwnam $user)[7];
9176
        } else {
9177
          if (defined $ENV{HOME}) {
9178
            $ENV{HOME};
9179
          } else {
9180
            (getpwuid $<)[7];
9181
          }
9182
        }
9183
      }
9184
    };
9185
    unless (defined $homedir) {
9186
      Carp::croak(
9187
        "Couldn't resolve homedir for "
9188
        .(defined $user ? $user : 'current user')
9189
        .($tried_file_homedir ? '' : ' - consider installing File::HomeDir')
9190
      );
9191
    }
9192
    $path =~ s/^~[^\/]*/$homedir/;
9193
    $path;
9194
  }
9195
  
9196
  sub resolve_relative_path {
9197
    my ($class, $path) = @_;
9198
    $path = File::Spec->rel2abs($path);
9199
  }
9200
  
9201
  sub setup_local_lib_for {
9202
    my ($class, $path) = @_;
9203
    $path = $class->ensure_dir_structure_for($path);
9204
    if ($0 eq '-') {
9205
      $class->print_environment_vars_for($path);
9206
      exit 0;
9207
    } else {
9208
      $class->setup_env_hash_for($path);
9209
      @INC = _uniq(split($Config{path_sep}, $ENV{PERL5LIB}), @INC);
9210
    }
9211
  }
9212
  
9213
  sub install_base_bin_path {
9214
    my ($class, $path) = @_;
9215
    File::Spec->catdir($path, 'bin');
9216
  }
9217
  
9218
  sub install_base_perl_path {
9219
    my ($class, $path) = @_;
9220
    File::Spec->catdir($path, 'lib', 'perl5');
9221
  }
9222
  
9223
  sub install_base_arch_path {
9224
    my ($class, $path) = @_;
9225
    File::Spec->catdir($class->install_base_perl_path($path), $Config{archname});
9226
  }
9227
  
9228
  sub ensure_dir_structure_for {
9229
    my ($class, $path) = @_;
9230
    unless (-d $path) {
9231
      warn "Attempting to create directory ${path}\n";
9232
    }
9233
    File::Path::mkpath($path);
9234
    # Need to have the path exist to make a short name for it, so
9235
    # converting to a short name here.
9236
    $path = Win32::GetShortPathName($path) if $^O eq 'MSWin32';
9237
  
9238
    return $path;
9239
  }
9240
  
9241
  sub INTERPOLATE_ENV () { 1 }
9242
  sub LITERAL_ENV     () { 0 }
9243
  
9244
  sub guess_shelltype {
9245
    my $shellbin = 'sh';
9246
    if(defined $ENV{'SHELL'}) {
9247
        my @shell_bin_path_parts = File::Spec->splitpath($ENV{'SHELL'});
9248
        $shellbin = $shell_bin_path_parts[-1];
9249
    }
9250
    my $shelltype = do {
9251
        local $_ = $shellbin;
9252
        if(/csh/) {
9253
            'csh'
9254
        } else {
9255
            'bourne'
9256
        }
9257
    };
9258
  
9259
    # Both Win32 and Cygwin have $ENV{COMSPEC} set.
9260
    if (defined $ENV{'COMSPEC'} && $^O ne 'cygwin') {
9261
        my @shell_bin_path_parts = File::Spec->splitpath($ENV{'COMSPEC'});
9262
        $shellbin = $shell_bin_path_parts[-1];
9263
           $shelltype = do {
9264
                   local $_ = $shellbin;
9265
                   if(/command\.com/) {
9266
                           'win32'
9267
                   } elsif(/cmd\.exe/) {
9268
                           'win32'
9269
                   } elsif(/4nt\.exe/) {
9270
                           'win32'
9271
                   } else {
9272
                           $shelltype
9273
                   }
9274
           };
9275
    }
9276
    return $shelltype;
9277
  }
9278
  
9279
  sub print_environment_vars_for {
9280
    my ($class, $path) = @_;
9281
    print $class->environment_vars_string_for($path);
9282
  }
9283
  
9284
  sub environment_vars_string_for {
9285
    my ($class, $path) = @_;
9286
    my @envs = $class->build_environment_vars_for($path, LITERAL_ENV);
9287
    my $out = '';
9288
  
9289
    # rather basic csh detection, goes on the assumption that something won't
9290
    # call itself csh unless it really is. also, default to bourne in the
9291
    # pathological situation where a user doesn't have $ENV{SHELL} defined.
9292
    # note also that shells with funny names, like zoid, are assumed to be
9293
    # bourne.
9294
  
9295
    my $shelltype = $class->guess_shelltype;
9296
  
9297
    while (@envs) {
9298
      my ($name, $value) = (shift(@envs), shift(@envs));
9299
      $value =~ s/(\\")/\\$1/g;
9300
      $out .= $class->${\"build_${shelltype}_env_declaration"}($name, $value);
9301
    }
9302
    return $out;
9303
  }
9304
  
9305
  # simple routines that take two arguments: an %ENV key and a value. return
9306
  # strings that are suitable for passing directly to the relevant shell to set
9307
  # said key to said value.
9308
  sub build_bourne_env_declaration {
9309
    my $class = shift;
9310
    my($name, $value) = @_;
9311
    return qq{export ${name}="${value}"\n};
9312
  }
9313
  
9314
  sub build_csh_env_declaration {
9315
    my $class = shift;
9316
    my($name, $value) = @_;
9317
    return qq{setenv ${name} "${value}"\n};
9318
  }
9319
  
9320
  sub build_win32_env_declaration {
9321
    my $class = shift;
9322
    my($name, $value) = @_;
9323
    return qq{set ${name}=${value}\n};
9324
  }
9325
  
9326
  sub setup_env_hash_for {
9327
    my ($class, $path) = @_;
9328
    my %envs = $class->build_environment_vars_for($path, INTERPOLATE_ENV);
9329
    @ENV{keys %envs} = values %envs;
9330
  }
9331
  
9332
  sub build_environment_vars_for {
9333
    my ($class, $path, $interpolate) = @_;
9334
    return (
9335
      PERL_LOCAL_LIB_ROOT => $path,
9336
      PERL_MB_OPT => "--install_base ${path}",
9337
      PERL_MM_OPT => "INSTALL_BASE=${path}",
9338
      PERL5LIB => join($Config{path_sep},
9339
                    $class->install_base_arch_path($path),
9340
                    $class->install_base_perl_path($path),
9341
                    (($ENV{PERL5LIB}||()) ?
9342
                      ($interpolate == INTERPOLATE_ENV
9343
                        ? ($ENV{PERL5LIB})
9344
                        : (($^O ne 'MSWin32') ? '$PERL5LIB' : '%PERL5LIB%' ))
9345
                      : ())
9346
                  ),
9347
      PATH => join($Config{path_sep},
9348
                $class->install_base_bin_path($path),
9349
                ($interpolate == INTERPOLATE_ENV
9350
                  ? ($ENV{PATH}||())
9351
                  : (($^O ne 'MSWin32') ? '$PATH' : '%PATH%' ))
9352
               ),
9353
    )
9354
  }
9355
  
9356
  1;
9357
LOCAL_LIB
9358

            
9359
$fatpacked{"parent.pm"} = <<'PARENT';
9360
  package parent;
9361
  use strict;
9362
  use vars qw($VERSION);
9363
  $VERSION = '0.225';
9364
  
9365
  sub import {
9366
      my $class = shift;
9367
  
9368
      my $inheritor = caller(0);
9369
  
9370
      if ( @_ and $_[0] eq '-norequire' ) {
9371
          shift @_;
9372
      } else {
9373
          for ( my @filename = @_ ) {
9374
              if ( $_ eq $inheritor ) {
9375
                  warn "Class '$inheritor' tried to inherit from itself\n";
9376
              };
9377
  
9378
              s{::|'}{/}g;
9379
              require "$_.pm"; # dies if the file is not found
9380
          }
9381
      }
9382
  
9383
      {
9384
          no strict 'refs';
9385
          push @{"$inheritor\::ISA"}, @_;
9386
      };
9387
  };
9388
  
9389
  "All your base are belong to us"
9390
  
9391
  __END__
9392
  
9393
PARENT
9394

            
9395
$fatpacked{"version.pm"} = <<'VERSION';
9396
  #!perl -w
9397
  package version;
9398
  
9399
  use 5.005_04;
9400
  use strict;
9401
  
9402
  use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv);
9403
  
9404
  $VERSION = 0.88;
9405
  
9406
  $CLASS = 'version';
9407
  
9408
  #--------------------------------------------------------------------------#
9409
  # Version regexp components
9410
  #--------------------------------------------------------------------------#
9411
  
9412
  # Fraction part of a decimal version number.  This is a common part of
9413
  # both strict and lax decimal versions
9414
  
9415
  my $FRACTION_PART = qr/\.[0-9]+/;
9416
  
9417
  # First part of either decimal or dotted-decimal strict version number.
9418
  # Unsigned integer with no leading zeroes (except for zero itself) to
9419
  # avoid confusion with octal.
9420
  
9421
  my $STRICT_INTEGER_PART = qr/0|[1-9][0-9]*/;
9422
  
9423
  # First part of either decimal or dotted-decimal lax version number.
9424
  # Unsigned integer, but allowing leading zeros.  Always interpreted
9425
  # as decimal.  However, some forms of the resulting syntax give odd
9426
  # results if used as ordinary Perl expressions, due to how perl treats
9427
  # octals.  E.g.
9428
  #   version->new("010" ) == 10
9429
  #   version->new( 010  ) == 8
9430
  #   version->new( 010.2) == 82  # "8" . "2"
9431
  
9432
  my $LAX_INTEGER_PART = qr/[0-9]+/;
9433
  
9434
  # Second and subsequent part of a strict dotted-decimal version number.
9435
  # Leading zeroes are permitted, and the number is always decimal.
9436
  # Limited to three digits to avoid overflow when converting to decimal
9437
  # form and also avoid problematic style with excessive leading zeroes.
9438
  
9439
  my $STRICT_DOTTED_DECIMAL_PART = qr/\.[0-9]{1,3}/;
9440
  
9441
  # Second and subsequent part of a lax dotted-decimal version number.
9442
  # Leading zeroes are permitted, and the number is always decimal.  No
9443
  # limit on the numerical value or number of digits, so there is the
9444
  # possibility of overflow when converting to decimal form.
9445
  
9446
  my $LAX_DOTTED_DECIMAL_PART = qr/\.[0-9]+/;
9447
  
9448
  # Alpha suffix part of lax version number syntax.  Acts like a
9449
  # dotted-decimal part.
9450
  
9451
  my $LAX_ALPHA_PART = qr/_[0-9]+/;
9452
  
9453
  #--------------------------------------------------------------------------#
9454
  # Strict version regexp definitions
9455
  #--------------------------------------------------------------------------#
9456
  
9457
  # Strict decimal version number.
9458
  
9459
  my $STRICT_DECIMAL_VERSION =
9460
      qr/ $STRICT_INTEGER_PART $FRACTION_PART? /x;
9461
  
9462
  # Strict dotted-decimal version number.  Must have both leading "v" and
9463
  # at least three parts, to avoid confusion with decimal syntax.
9464
  
9465
  my $STRICT_DOTTED_DECIMAL_VERSION =
9466
      qr/ v $STRICT_INTEGER_PART $STRICT_DOTTED_DECIMAL_PART{2,} /x;
9467
  
9468
  # Complete strict version number syntax -- should generally be used
9469
  # anchored: qr/ \A $STRICT \z /x
9470
  
9471
  $STRICT =
9472
      qr/ $STRICT_DECIMAL_VERSION | $STRICT_DOTTED_DECIMAL_VERSION /x;
9473
  
9474
  #--------------------------------------------------------------------------#
9475
  # Lax version regexp definitions
9476
  #--------------------------------------------------------------------------#
9477
  
9478
  # Lax decimal version number.  Just like the strict one except for
9479
  # allowing an alpha suffix or allowing a leading or trailing
9480
  # decimal-point
9481
  
9482
  my $LAX_DECIMAL_VERSION =
9483
      qr/ $LAX_INTEGER_PART (?: \. | $FRACTION_PART $LAX_ALPHA_PART? )?
9484
  	|
9485
  	$FRACTION_PART $LAX_ALPHA_PART?
9486
      /x;
9487
  
9488
  # Lax dotted-decimal version number.  Distinguished by having either
9489
  # leading "v" or at least three non-alpha parts.  Alpha part is only
9490
  # permitted if there are at least two non-alpha parts. Strangely
9491
  # enough, without the leading "v", Perl takes .1.2 to mean v0.1.2,
9492
  # so when there is no "v", the leading part is optional
9493
  
9494
  my $LAX_DOTTED_DECIMAL_VERSION =
9495
      qr/
9496
  	v $LAX_INTEGER_PART (?: $LAX_DOTTED_DECIMAL_PART+ $LAX_ALPHA_PART? )?
9497
  	|
9498
  	$LAX_INTEGER_PART? $LAX_DOTTED_DECIMAL_PART{2,} $LAX_ALPHA_PART?
9499
      /x;
9500
  
9501
  # Complete lax version number syntax -- should generally be used
9502
  # anchored: qr/ \A $LAX \z /x
9503
  #
9504
  # The string 'undef' is a special case to make for easier handling
9505
  # of return values from ExtUtils::MM->parse_version
9506
  
9507
  $LAX =
9508
      qr/ undef | $LAX_DECIMAL_VERSION | $LAX_DOTTED_DECIMAL_VERSION /x;
9509
  
9510
  #--------------------------------------------------------------------------#
9511
  
9512
  eval "use version::vxs $VERSION";
9513
  if ( $@ ) { # don't have the XS version installed
9514
      eval "use version::vpp $VERSION"; # don't tempt fate
9515
      die "$@" if ( $@ );
9516
      push @ISA, "version::vpp";
9517
      local $^W;
9518
      *version::qv = \&version::vpp::qv;
9519
      *version::declare = \&version::vpp::declare;
9520
      *version::_VERSION = \&version::vpp::_VERSION;
9521
      if ($] >= 5.009000 && $] < 5.011004) {
9522
  	no strict 'refs';
9523
  	*version::stringify = \&version::vpp::stringify;
9524
  	*{'version::(""'} = \&version::vpp::stringify;
9525
  	*version::new = \&version::vpp::new;
9526
  	*version::parse = \&version::vpp::parse;
9527
      }
9528
  }
9529
  else { # use XS module
9530
      push @ISA, "version::vxs";
9531
      local $^W;
9532
      *version::declare = \&version::vxs::declare;
9533
      *version::qv = \&version::vxs::qv;
9534
      *version::_VERSION = \&version::vxs::_VERSION;
9535
      *version::vcmp = \&version::vxs::VCMP;
9536
      if ($] >= 5.009000 && $] < 5.011004) {
9537
  	no strict 'refs';
9538
  	*version::stringify = \&version::vxs::stringify;
9539
  	*{'version::(""'} = \&version::vxs::stringify;
9540
  	*version::new = \&version::vxs::new;
9541
  	*version::parse = \&version::vxs::parse;
9542
      }
9543
  
9544
  }
9545
  
9546
  # Preloaded methods go here.
9547
  sub import {
9548
      no strict 'refs';
9549
      my ($class) = shift;
9550
  
9551
      # Set up any derived class
9552
      unless ($class eq 'version') {
9553
  	local $^W;
9554
  	*{$class.'::declare'} =  \&version::declare;
9555
  	*{$class.'::qv'} = \&version::qv;
9556
      }
9557
  
9558
      my %args;
9559
      if (@_) { # any remaining terms are arguments
9560
  	map { $args{$_} = 1 } @_
9561
      }
9562
      else { # no parameters at all on use line
9563
      	%args = 
9564
  	(
9565
  	    qv => 1,
9566
  	    'UNIVERSAL::VERSION' => 1,
9567
  	);
9568
      }
9569
  
9570
      my $callpkg = caller();
9571
      
9572
      if (exists($args{declare})) {
9573
  	*{$callpkg.'::declare'} = 
9574
  	    sub {return $class->declare(shift) }
9575
  	  unless defined(&{$callpkg.'::declare'});
9576
      }
9577
  
9578
      if (exists($args{qv})) {
9579
  	*{$callpkg.'::qv'} =
9580
  	    sub {return $class->qv(shift) }
9581
  	  unless defined(&{$callpkg.'::qv'});
9582
      }
9583
  
9584
      if (exists($args{'UNIVERSAL::VERSION'})) {
9585
  	local $^W;
9586
  	*UNIVERSAL::VERSION 
9587
  		= \&version::_VERSION;
9588
      }
9589
  
9590
      if (exists($args{'VERSION'})) {
9591
  	*{$callpkg.'::VERSION'} = \&version::_VERSION;
9592
      }
9593
  
9594
      if (exists($args{'is_strict'})) {
9595
  	*{$callpkg.'::is_strict'} = \&version::is_strict
9596
  	  unless defined(&{$callpkg.'::is_strict'});
9597
      }
9598
  
9599
      if (exists($args{'is_lax'})) {
9600
  	*{$callpkg.'::is_lax'} = \&version::is_lax
9601
  	  unless defined(&{$callpkg.'::is_lax'});
9602
      }
9603
  }
9604
  
9605
  sub is_strict	{ defined $_[0] && $_[0] =~ qr/ \A $STRICT \z /x }
9606
  sub is_lax	{ defined $_[0] && $_[0] =~ qr/ \A $LAX \z /x }
9607
  
9608
  1;
9609
VERSION
9610

            
9611
$fatpacked{"Version/Requirements.pm"} = <<'VERSION_REQUIREMENTS';
9612
  use strict;
9613
  use warnings;
9614
  package Version::Requirements;
9615
  BEGIN {
9616
    $Version::Requirements::VERSION = '0.101020';
9617
  }
9618
  # ABSTRACT: a set of version requirements for a CPAN dist
9619
  
9620
  
9621
  use Carp ();
9622
  use Scalar::Util ();
9623
  use version 0.77 (); # the ->parse method
9624
  
9625
  
9626
  sub new {
9627
    my ($class) = @_;
9628
    return bless {} => $class;
9629
  }
9630
  
9631
  sub _version_object {
9632
    my ($self, $version) = @_;
9633
  
9634
    $version = (! defined $version)                ? version->parse(0)
9635
             : (! Scalar::Util::blessed($version)) ? version->parse($version)
9636
             :                                       $version;
9637
  
9638
    return $version;
9639
  }
9640
  
9641
  
9642
  BEGIN {
9643
    for my $type (qw(minimum maximum exclusion exact_version)) {
9644
      my $method = "with_$type";
9645
      my $to_add = $type eq 'exact_version' ? $type : "add_$type";
9646
  
9647
      my $code = sub {
9648
        my ($self, $name, $version) = @_;
9649
  
9650
        $version = $self->_version_object( $version );
9651
  
9652
        $self->__modify_entry_for($name, $method, $version);
9653
  
9654
        return $self;
9655
      };
9656
      
9657
      no strict 'refs';
9658
      *$to_add = $code;
9659
    }
9660
  }
9661
  
9662
  
9663
  sub add_requirements {
9664
    my ($self, $req) = @_;
9665
  
9666
    for my $module ($req->required_modules) {
9667
      my $modifiers = $req->__entry_for($module)->as_modifiers;
9668
      for my $modifier (@$modifiers) {
9669
        my ($method, @args) = @$modifier;
9670
        $self->$method($module => @args);
9671
      };
9672
    }
9673
  
9674
    return $self;
9675
  }
9676
  
9677
  
9678
  sub accepts_module {
9679
    my ($self, $module, $version) = @_;
9680
  
9681
    $version = $self->_version_object( $version );
9682
  
9683
    return 1 unless my $range = $self->__entry_for($module);
9684
    return $range->_accepts($version);
9685
  }
9686
  
9687
  
9688
  sub clear_requirement {
9689
    my ($self, $module) = @_;
9690
  
9691
    return $self unless $self->__entry_for($module);
9692
  
9693
    Carp::confess("can't clear requirements on finalized requirements")
9694
      if $self->is_finalized;
9695
  
9696
    delete $self->{requirements}{ $module };
9697
  
9698
    return $self;
9699
  }
9700
  
9701
  
9702
  sub required_modules { keys %{ $_[0]{requirements} } }
9703
  
9704
  
9705
  sub clone {
9706
    my ($self) = @_;
9707
    my $new = (ref $self)->new;
9708
  
9709
    return $new->add_requirements($self);
9710
  }
9711
  
9712
  sub __entry_for     { $_[0]{requirements}{ $_[1] } }
9713
  
9714
  sub __modify_entry_for {
9715
    my ($self, $name, $method, $version) = @_;
9716
  
9717
    my $fin = $self->is_finalized;
9718
    my $old = $self->__entry_for($name);
9719
  
9720
    Carp::confess("can't add new requirements to finalized requirements")
9721
      if $fin and not $old;
9722
  
9723
    my $new = ($old || 'Version::Requirements::_Range::Range')
9724
            ->$method($version);
9725
  
9726
    Carp::confess("can't modify finalized requirements")
9727
      if $fin and $old->as_string ne $new->as_string;
9728
  
9729
    $self->{requirements}{ $name } = $new;
9730
  }
9731
  
9732
  
9733
  sub is_simple {
9734
    my ($self) = @_;
9735
    for my $module ($self->required_modules) {
9736
      # XXX: This is a complete hack, but also entirely correct.
9737
      return if $self->__entry_for($module)->as_string =~ /\s/;
9738
    }
9739
  
9740
    return 1;
9741
  }
9742
  
9743
  
9744
  sub is_finalized { $_[0]{finalized} }
9745
  
9746
  
9747
  sub finalize { $_[0]{finalized} = 1 }
9748
  
9749
  
9750
  sub as_string_hash {
9751
    my ($self) = @_;
9752
  
9753
    my %hash = map {; $_ => $self->{requirements}{$_}->as_string }
9754
               $self->required_modules;
9755
  
9756
    return \%hash;
9757
  }
9758
  
9759
  
9760
  my %methods_for_op = (
9761
    '==' => [ qw(exact_version) ],
9762
    '!=' => [ qw(add_exclusion) ],
9763
    '>=' => [ qw(add_minimum)   ],
9764
    '<=' => [ qw(add_maximum)   ],
9765
    '>'  => [ qw(add_minimum add_exclusion) ],
9766
    '<'  => [ qw(add_maximum add_exclusion) ],
9767
  );
9768
  
9769
  sub from_string_hash {
9770
    my ($class, $hash) = @_;
9771
  
9772
    my $self = $class->new;
9773
  
9774
    for my $module (keys %$hash) {
9775
      my @parts = split qr{\s*,\s*}, $hash->{ $module };
9776
      for my $part (@parts) {
9777
        my ($op, $ver) = split /\s+/, $part, 2;
9778
  
9779
        if (! defined $ver) {
9780
          $self->add_minimum($module => $op);
9781
        } else {
9782
          Carp::confess("illegal requirement string: $hash->{ $module }")
9783
            unless my $methods = $methods_for_op{ $op };
9784
  
9785
          $self->$_($module => $ver) for @$methods;
9786
        }
9787
      }
9788
    }
9789
  
9790
    return $self;
9791
  }
9792
  
9793
  ##############################################################
9794
  
9795
  {
9796
    package
9797
      Version::Requirements::_Range::Exact;
9798
  BEGIN {
9799
    $Version::Requirements::_Range::Exact::VERSION = '0.101020';
9800
  }
9801
    sub _new     { bless { version => $_[1] } => $_[0] }
9802
  
9803
    sub _accepts { return $_[0]{version} == $_[1] }
9804
  
9805
    sub as_string { return "== $_[0]{version}" }
9806
  
9807
    sub as_modifiers { return [ [ exact_version => $_[0]{version} ] ] }
9808
  
9809
    sub _clone {
9810
      (ref $_[0])->_new( version->new( $_[0]{version} ) )
9811
    }
9812
  
9813
    sub with_exact_version {
9814
      my ($self, $version) = @_;
9815
  
9816
      return $self->_clone if $self->_accepts($version);
9817
  
9818
      Carp::confess("illegal requirements: unequal exact version specified");
9819
    }
9820
  
9821
    sub with_minimum {
9822
      my ($self, $minimum) = @_;
9823
      return $self->_clone if $self->{version} >= $minimum;
9824
      Carp::confess("illegal requirements: minimum above exact specification");
9825
    }
9826
  
9827
    sub with_maximum {
9828
      my ($self, $maximum) = @_;
9829
      return $self->_clone if $self->{version} <= $maximum;
9830
      Carp::confess("illegal requirements: maximum below exact specification");
9831
    }
9832
  
9833
    sub with_exclusion {
9834
      my ($self, $exclusion) = @_;
9835
      return $self->_clone unless $exclusion == $self->{version};
9836
      Carp::confess("illegal requirements: excluded exact specification");
9837
    }
9838
  }
9839
  
9840
  ##############################################################
9841
  
9842
  {
9843
    package
9844
      Version::Requirements::_Range::Range;
9845
  BEGIN {
9846
    $Version::Requirements::_Range::Range::VERSION = '0.101020';
9847
  }
9848
  
9849
    sub _self { ref($_[0]) ? $_[0] : (bless { } => $_[0]) }
9850
  
9851
    sub _clone {
9852
      return (bless { } => $_[0]) unless ref $_[0];
9853
  
9854
      my ($s) = @_;
9855
      my %guts = (
9856
        (exists $s->{minimum} ? (minimum => version->new($s->{minimum})) : ()),
9857
        (exists $s->{maximum} ? (maximum => version->new($s->{maximum})) : ()),
9858
  
9859
        (exists $s->{exclusions}
9860
          ? (exclusions => [ map { version->new($_) } @{ $s->{exclusions} } ])
9861
          : ()),
9862
      );
9863
  
9864
      bless \%guts => ref($s);
9865
    }
9866
  
9867
    sub as_modifiers {
9868
      my ($self) = @_;
9869
      my @mods;
9870
      push @mods, [ add_minimum => $self->{minimum} ] if exists $self->{minimum};
9871
      push @mods, [ add_maximum => $self->{maximum} ] if exists $self->{maximum};
9872
      push @mods, map {; [ add_exclusion => $_ ] } @{$self->{exclusions} || []};
9873
      return \@mods;
9874
    }
9875
  
9876
    sub as_string {
9877
      my ($self) = @_;
9878
  
9879
      return 0 if ! keys %$self;
9880
  
9881
      return "$self->{minimum}" if (keys %$self) == 1 and exists $self->{minimum};
9882
  
9883
      my @exclusions = @{ $self->{exclusions} || [] };
9884
  
9885
      my @parts;
9886
  
9887
      for my $pair (
9888
        [ qw( >= > minimum ) ],
9889
        [ qw( <= < maximum ) ],
9890
      ) {
9891
        my ($op, $e_op, $k) = @$pair;
9892
        if (exists $self->{$k}) {
9893
          my @new_exclusions = grep { $_ != $self->{ $k } } @exclusions;
9894
          if (@new_exclusions == @exclusions) {
9895
            push @parts, "$op $self->{ $k }";
9896
          } else {
9897
            push @parts, "$e_op $self->{ $k }";
9898
            @exclusions = @new_exclusions;
9899
          }
9900
        }
9901
      }
9902
  
9903
      push @parts, map {; "!= $_" } @exclusions;
9904
  
9905
      return join q{, }, @parts;
9906
    }
9907
  
9908
    sub with_exact_version {
9909
      my ($self, $version) = @_;
9910
      $self = $self->_clone;
9911
  
9912
      Carp::confess("illegal requirements: exact specification outside of range")
9913
        unless $self->_accepts($version);
9914
  
9915
      return Version::Requirements::_Range::Exact->_new($version);
9916
    }
9917
  
9918
    sub _simplify {
9919
      my ($self) = @_;
9920
  
9921
      if (defined $self->{minimum} and defined $self->{maximum}) {
9922
        if ($self->{minimum} == $self->{maximum}) {
9923
          Carp::confess("illegal requirements: excluded all values")
9924
            if grep { $_ == $self->{minimum} } @{ $self->{exclusions} || [] };
9925
  
9926
          return Version::Requirements::_Range::Exact->_new($self->{minimum})
9927
        }
9928
  
9929
        Carp::confess("illegal requirements: minimum exceeds maximum")
9930
          if $self->{minimum} > $self->{maximum};
9931
      }
9932
  
9933
      # eliminate irrelevant exclusions
9934
      if ($self->{exclusions}) {
9935
        my %seen;
9936
        @{ $self->{exclusions} } = grep {
9937
          (! defined $self->{minimum} or $_ >= $self->{minimum})
9938
          and
9939
          (! defined $self->{maximum} or $_ <= $self->{maximum})
9940
          and
9941
          ! $seen{$_}++
9942
        } @{ $self->{exclusions} };
9943
      }
9944
  
9945
      return $self;
9946
    }
9947
  
9948
    sub with_minimum {
9949
      my ($self, $minimum) = @_;
9950
      $self = $self->_clone;
9951
  
9952
      if (defined (my $old_min = $self->{minimum})) {
9953
        $self->{minimum} = (sort { $b cmp $a } ($minimum, $old_min))[0];
9954
      } else {
9955
        $self->{minimum} = $minimum;
9956
      }
9957
  
9958
      return $self->_simplify;
9959
    }
9960
  
9961
    sub with_maximum {
9962
      my ($self, $maximum) = @_;
9963
      $self = $self->_clone;
9964
  
9965
      if (defined (my $old_max = $self->{maximum})) {
9966
        $self->{maximum} = (sort { $a cmp $b } ($maximum, $old_max))[0];
9967
      } else {
9968
        $self->{maximum} = $maximum;
9969
      }
9970
  
9971
      return $self->_simplify;
9972
    }
9973
  
9974
    sub with_exclusion {
9975
      my ($self, $exclusion) = @_;
9976
      $self = $self->_clone;
9977
  
9978
      push @{ $self->{exclusions} ||= [] }, $exclusion;
9979
  
9980
      return $self->_simplify;
9981
    }
9982
  
9983
    sub _accepts {
9984
      my ($self, $version) = @_;
9985
  
9986
      return if defined $self->{minimum} and $version < $self->{minimum};
9987
      return if defined $self->{maximum} and $version > $self->{maximum};
9988
      return if defined $self->{exclusions}
9989
            and grep { $version == $_ } @{ $self->{exclusions} };
9990
  
9991
      return 1;
9992
    }
9993
  }
9994
  
9995
  1;
9996
  
9997
  __END__
9998
  =pod
9999
  
10000
VERSION_REQUIREMENTS
10001

            
10002
$fatpacked{"version/vpp.pm"} = <<'VERSION_VPP';
10003
  package charstar;
10004
  # a little helper class to emulate C char* semantics in Perl
10005
  # so that prescan_version can use the same code as in C
10006
  
10007
  use overload (
10008
      '""'	=> \&thischar,
10009
      '0+'	=> \&thischar,
10010
      '++'	=> \&increment,
10011
      '--'	=> \&decrement,
10012
      '+'		=> \&plus,
10013
      '-'		=> \&minus,
10014
      '*'		=> \&multiply,
10015
      'cmp'	=> \&cmp,
10016
      '<=>'	=> \&spaceship,
10017
      'bool'	=> \&thischar,
10018
      '='		=> \&clone,
10019
  );
10020
  
10021
  sub new {
10022
      my ($self, $string) = @_;
10023
      my $class = ref($self) || $self;
10024
  
10025
      my $obj = {
10026
  	string  => [split(//,$string)],
10027
  	current => 0,
10028
      };
10029
      return bless $obj, $class;
10030
  }
10031
  
10032
  sub thischar {
10033
      my ($self) = @_;
10034
      my $last = $#{$self->{string}};
10035
      my $curr = $self->{current};
10036
      if ($curr >= 0 && $curr <= $last) {
10037
  	return $self->{string}->[$curr];
10038
      }
10039
      else {
10040
  	return '';
10041
      }
10042
  }
10043
  
10044
  sub increment {
10045
      my ($self) = @_;
10046
      $self->{current}++;
10047
  }
10048
  
10049
  sub decrement {
10050
      my ($self) = @_;
10051
      $self->{current}--;
10052
  }
10053
  
10054
  sub plus {
10055
      my ($self, $offset) = @_;
10056
      my $rself = $self->clone;
10057
      $rself->{current} += $offset;
10058
      return $rself;
10059
  }
10060
  
10061
  sub minus {
10062
      my ($self, $offset) = @_;
10063
      my $rself = $self->clone;
10064
      $rself->{current} -= $offset;
10065
      return $rself;
10066
  }
10067
  
10068
  sub multiply {
10069
      my ($left, $right, $swapped) = @_;
10070
      my $char = $left->thischar();
10071
      return $char * $right;
10072
  }
10073
  
10074
  sub spaceship {
10075
      my ($left, $right, $swapped) = @_;
10076
      unless (ref($right)) { # not an object already
10077
  	$right = $left->new($right);
10078
      }
10079
      return $left->{current} <=> $right->{current};
10080
  }
10081
  
10082
  sub cmp {
10083
      my ($left, $right, $swapped) = @_;
10084
      unless (ref($right)) { # not an object already
10085
  	if (length($right) == 1) { # comparing single character only
10086
  	    return $left->thischar cmp $right;
10087
  	}
10088
  	$right = $left->new($right);
10089
      }
10090
      return $left->currstr cmp $right->currstr;
10091
  }
10092
  
10093
  sub bool {
10094
      my ($self) = @_;
10095
      my $char = $self->thischar;
10096
      return ($char ne '');
10097
  }
10098
  
10099
  sub clone {
10100
      my ($left, $right, $swapped) = @_;
10101
      $right = {
10102
  	string  => [@{$left->{string}}],
10103
  	current => $left->{current},
10104
      };
10105
      return bless $right, ref($left);
10106
  }
10107
  
10108
  sub currstr {
10109
      my ($self, $s) = @_;
10110
      my $curr = $self->{current};
10111
      my $last = $#{$self->{string}};
10112
      if (defined($s) && $s->{current} < $last) {
10113
  	$last = $s->{current};
10114
      }
10115
  
10116
      my $string = join('', @{$self->{string}}[$curr..$last]);
10117
      return $string;
10118
  }
10119
  
10120
  package version::vpp;
10121
  use strict;
10122
  
10123
  use POSIX qw/locale_h/;
10124
  use locale;
10125
  use vars qw ($VERSION @ISA @REGEXS);
10126
  $VERSION = 0.88;
10127
  
10128
  use overload (
10129
      '""'       => \&stringify,
10130
      '0+'       => \&numify,
10131
      'cmp'      => \&vcmp,
10132
      '<=>'      => \&vcmp,
10133
      'bool'     => \&vbool,
10134
      'nomethod' => \&vnoop,
10135
  );
10136
  
10137
  eval "use warnings";
10138
  if ($@) {
10139
      eval '
10140
  	package warnings;
10141
  	sub enabled {return $^W;}
10142
  	1;
10143
      ';
10144
  }
10145
  
10146
  my $VERSION_MAX = 0x7FFFFFFF;
10147
  
10148
  # implement prescan_version as closely to the C version as possible
10149
  use constant TRUE  => 1;
10150
  use constant FALSE => 0;
10151
  
10152
  sub isDIGIT {
10153
      my ($char) = shift->thischar();
10154
      return ($char =~ /\d/);
10155
  }
10156
  
10157
  sub isALPHA {
10158
      my ($char) = shift->thischar();
10159
      return ($char =~ /[a-zA-Z]/);
10160
  }
10161
  
10162
  sub isSPACE {
10163
      my ($char) = shift->thischar();
10164
      return ($char =~ /\s/);
10165
  }
10166
  
10167
  sub BADVERSION {
10168
      my ($s, $errstr, $error) = @_;
10169
      if ($errstr) {
10170
  	$$errstr = $error;
10171
      }
10172
      return $s;
10173
  }
10174
  
10175
  sub prescan_version {
10176
      my ($s, $strict, $errstr, $sqv, $ssaw_decimal, $swidth, $salpha) = @_;
10177
      my $qv          = defined $sqv          ? $$sqv          : FALSE;
10178
      my $saw_decimal = defined $ssaw_decimal ? $$ssaw_decimal : 0;
10179
      my $width       = defined $swidth       ? $$swidth       : 3;
10180
      my $alpha       = defined $salpha       ? $$salpha       : FALSE;
10181
  
10182
      my $d = $s;
10183
  
10184
      if ($qv && isDIGIT($d)) {
10185
  	goto dotted_decimal_version;
10186
      }
10187
  
10188
      if ($d eq 'v') { # explicit v-string
10189
  	$d++;
10190
  	if (isDIGIT($d)) {
10191
  	    $qv = TRUE;
10192
  	}
10193
  	else { # degenerate v-string
10194
  	    # requires v1.2.3
10195
  	    return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
10196
  	}
10197
  
10198
  dotted_decimal_version:
10199
  	if ($strict && $d eq '0' && isDIGIT($d+1)) {
10200
  	    # no leading zeros allowed
10201
  	    return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)");
10202
  	}
10203
  
10204
  	while (isDIGIT($d)) { 	# integer part
10205
  	    $d++;
10206
  	}
10207
  
10208
  	if ($d eq '.')
10209
  	{
10210
  	    $saw_decimal++;
10211
  	    $d++; 		# decimal point
10212
  	}
10213
  	else
10214
  	{
10215
  	    if ($strict) {
10216
  		# require v1.2.3
10217
  		return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
10218
  	    }
10219
  	    else {
10220
  		goto version_prescan_finish;
10221
  	    }
10222
  	}
10223
  
10224
  	{
10225
  	    my $i = 0;
10226
  	    my $j = 0;
10227
  	    while (isDIGIT($d)) {	# just keep reading
10228
  		$i++;
10229
  		while (isDIGIT($d)) {
10230
  		    $d++; $j++;
10231
  		    # maximum 3 digits between decimal
10232
  		    if ($strict && $j > 3) {
10233
  			return BADVERSION($s,$errstr,"Invalid version format (maximum 3 digits between decimals)");
10234
  		    }
10235
  		}
10236
  		if ($d eq '_') {
10237
  		    if ($strict) {
10238
  			return BADVERSION($s,$errstr,"Invalid version format (no underscores)");
10239
  		    }
10240
  		    if ( $alpha ) {
10241
  			return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)");
10242
  		    }
10243
  		    $d++;
10244
  		    $alpha = TRUE;
10245
  		}
10246
  		elsif ($d eq '.') {
10247
  		    if ($alpha) {
10248
  			return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)");
10249
  		    }
10250
  		    $saw_decimal++;
10251
  		    $d++;
10252
  		}
10253
  		elsif (!isDIGIT($d)) {
10254
  		    last;
10255
  		}
10256
  		$j = 0;
10257
  	    }
10258
  	
10259
  	    if ($strict && $i < 2) {
10260
  		# requires v1.2.3
10261
  		return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
10262
  	    }
10263
  	}
10264
      } 					# end if dotted-decimal
10265
      else
10266
      {					# decimal versions
10267
  	# special $strict case for leading '.' or '0'
10268
  	if ($strict) {
10269
  	    if ($d eq '.') {
10270
  		return BADVERSION($s,$errstr,"Invalid version format (0 before decimal required)");
10271
  	    }
10272
  	    if ($d eq '0' && isDIGIT($d+1)) {
10273
  		return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)");
10274
  	    }
10275
  	}
10276
  
10277
  	# consume all of the integer part
10278
  	while (isDIGIT($d)) {
10279
  	    $d++;
10280
  	}
10281
  
10282
  	# look for a fractional part
10283
  	if ($d eq '.') {
10284
  	    # we found it, so consume it
10285
  	    $saw_decimal++;
10286
  	    $d++;
10287
  	}
10288
  	elsif (!$d || $d eq ';' || isSPACE($d) || $d eq '}') {
10289
  	    if ( $d == $s ) {
10290
  		# found nothing
10291
  		return BADVERSION($s,$errstr,"Invalid version format (version required)");
10292
  	    }
10293
  	    # found just an integer
10294
  	    goto version_prescan_finish;
10295
  	}
10296
  	elsif ( $d == $s ) {
10297
  	    # didn't find either integer or period
10298
  	    return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)");
10299
  	}
10300
  	elsif ($d eq '_') {
10301
  	    # underscore can't come after integer part
10302
  	    if ($strict) {
10303
  		return BADVERSION($s,$errstr,"Invalid version format (no underscores)");
10304
  	    }
10305
  	    elsif (isDIGIT($d+1)) {
10306
  		return BADVERSION($s,$errstr,"Invalid version format (alpha without decimal)");
10307
  	    }
10308
  	    else {
10309
  		return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)");
10310
  	    }
10311
  	}
10312
  	elsif ($d) {
10313
  	    # anything else after integer part is just invalid data
10314
  	    return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)");
10315
  	}
10316
  
10317
  	# scan the fractional part after the decimal point
10318
  	if ($d && !isDIGIT($d) && ($strict || ! ($d eq ';' || isSPACE($d) || $d eq '}') )) {
10319
  		# $strict or lax-but-not-the-end
10320
  		return BADVERSION($s,$errstr,"Invalid version format (fractional part required)");
10321
  	}
10322
  
10323
  	while (isDIGIT($d)) {
10324
  	    $d++;
10325
  	    if ($d eq '.' && isDIGIT($d-1)) {
10326
  		if ($alpha) {
10327
  		    return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)");
10328
  		}
10329
  		if ($strict) {
10330
  		    return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
10331
  		}
10332
  		$d = $s; # start all over again
10333
  		$qv = TRUE;
10334
  		goto dotted_decimal_version;
10335
  	    }
10336
  	    if ($d eq '_') {
10337
  		if ($strict) {
10338
  		    return BADVERSION($s,$errstr,"Invalid version format (no underscores)");
10339
  		}
10340
  		if ( $alpha ) {
10341
  		    return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)");
10342
  		}
10343
  		if ( ! isDIGIT($d+1) ) {
10344
  		    return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)");
10345
  		}
10346
  		$d++;
10347
  		$alpha = TRUE;
10348
  	    }
10349
  	}
10350
      }
10351
  
10352
  version_prescan_finish:
10353
      while (isSPACE($d)) {
10354
  	$d++;
10355
      }
10356
  
10357
      if ($d && !isDIGIT($d) && (! ($d eq ';' || $d eq '}') )) {
10358
  	# trailing non-numeric data
10359
  	return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)");
10360
      }
10361
  
10362
      if (defined $sqv) {
10363
  	$$sqv = $qv;
10364
      }
10365
      if (defined $swidth) {
10366
  	$$swidth = $width;
10367
      }
10368
      if (defined $ssaw_decimal) {
10369
  	$$ssaw_decimal = $saw_decimal;
10370
      }
10371
      if (defined $salpha) {
10372
  	$$salpha = $alpha;
10373
      }
10374
      return $d;
10375
  }
10376
  
10377
  sub scan_version {
10378
      my ($s, $rv, $qv) = @_;
10379
      my $start;
10380
      my $pos;
10381
      my $last;
10382
      my $errstr;
10383
      my $saw_decimal = 0;
10384
      my $width = 3;
10385
      my $alpha = FALSE;
10386
      my $vinf = FALSE;
10387
      my @av;
10388
  
10389
      $s = new charstar $s;
10390
  
10391
      while (isSPACE($s)) { # leading whitespace is OK
10392
  	$s++;
10393
      }
10394
  
10395
      $last = prescan_version($s, FALSE, \$errstr, \$qv, \$saw_decimal,
10396
  	\$width, \$alpha);
10397
  
10398
      if ($errstr) {
10399
  	# 'undef' is a special case and not an error
10400
  	if ( $s ne 'undef') {
10401
  	    use Carp;
10402
  	    Carp::croak($errstr);
10403
  	}
10404
      }
10405
  
10406
      $start = $s;
10407
      if ($s eq 'v') {
10408
  	$s++;
10409
      }
10410
      $pos = $s;
10411
  
10412
      if ( $qv ) {
10413
  	$$rv->{qv} = $qv;
10414
      }
10415
      if ( $alpha ) {
10416
  	$$rv->{alpha} = $alpha;
10417
      }
10418
      if ( !$qv && $width < 3 ) {
10419
  	$$rv->{width} = $width;
10420
      }
10421
      
10422
      while (isDIGIT($pos)) {
10423
  	$pos++;
10424
      }
10425
      if (!isALPHA($pos)) {
10426
  	my $rev;
10427
  
10428
  	for (;;) {
10429
  	    $rev = 0;
10430
  	    {
10431
    		# this is atoi() that delimits on underscores
10432
    		my $end = $pos;
10433
    		my $mult = 1;
10434
  		my $orev;
10435
  
10436
  		#  the following if() will only be true after the decimal
10437
  		#  point of a version originally created with a bare
10438
  		#  floating point number, i.e. not quoted in any way
10439
  		#
10440
   		if ( !$qv && $s > $start && $saw_decimal == 1 ) {
10441
  		    $mult *= 100;
10442
   		    while ( $s < $end ) {
10443
  			$orev = $rev;
10444
   			$rev += $s * $mult;
10445
   			$mult /= 10;
10446
  			if (   (abs($orev) > abs($rev)) 
10447
  			    || (abs($rev) > $VERSION_MAX )) {
10448
  			    warn("Integer overflow in version %d",
10449
  					   $VERSION_MAX);
10450
  			    $s = $end - 1;
10451
  			    $rev = $VERSION_MAX;
10452
  			    $vinf = 1;
10453
  			}
10454
   			$s++;
10455
  			if ( $s eq '_' ) {
10456
  			    $s++;
10457
  			}
10458
   		    }
10459
    		}
10460
   		else {
10461
   		    while (--$end >= $s) {
10462
  			$orev = $rev;
10463
   			$rev += $end * $mult;
10464
   			$mult *= 10;
10465
  			if (   (abs($orev) > abs($rev)) 
10466
  			    || (abs($rev) > $VERSION_MAX )) {
10467
  			    warn("Integer overflow in version");
10468
  			    $end = $s - 1;
10469
  			    $rev = $VERSION_MAX;
10470
  			    $vinf = 1;
10471
  			}
10472
   		    }
10473
   		} 
10474
    	    }
10475
  
10476
    	    # Append revision
10477
  	    push @av, $rev;
10478
  	    if ( $vinf ) {
10479
  		$s = $last;
10480
  		last;
10481
  	    }
10482
  	    elsif ( $pos eq '.' ) {
10483
  		$s = ++$pos;
10484
  	    }
10485
  	    elsif ( $pos eq '_' && isDIGIT($pos+1) ) {
10486
  		$s = ++$pos;
10487
  	    }
10488
  	    elsif ( $pos eq ',' && isDIGIT($pos+1) ) {
10489
  		$s = ++$pos;
10490
  	    }
10491
  	    elsif ( isDIGIT($pos) ) {
10492
  		$s = $pos;
10493
  	    }
10494
  	    else {
10495
  		$s = $pos;
10496
  		last;
10497
  	    }
10498
  	    if ( $qv ) {
10499
  		while ( isDIGIT($pos) ) {
10500
  		    $pos++;
10501
  		}
10502
  	    }
10503
  	    else {
10504
  		my $digits = 0;
10505
  		while ( ( isDIGIT($pos) || $pos eq '_' ) && $digits < 3 ) {
10506
  		    if ( $pos ne '_' ) {
10507
  			$digits++;
10508
  		    }
10509
  		    $pos++;
10510
  		}
10511
  	    }
10512
  	}
10513
      }
10514
      if ( $qv ) { # quoted versions always get at least three terms
10515
  	my $len = $#av;
10516
  	#  This for loop appears to trigger a compiler bug on OS X, as it
10517
  	#  loops infinitely. Yes, len is negative. No, it makes no sense.
10518
  	#  Compiler in question is:
10519
  	#  gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
10520
  	#  for ( len = 2 - len; len > 0; len-- )
10521
  	#  av_push(MUTABLE_AV(sv), newSViv(0));
10522
  	# 
10523
  	$len = 2 - $len;
10524
  	while ($len-- > 0) {
10525
  	    push @av, 0;
10526
  	}
10527
      }
10528
  
10529
      # need to save off the current version string for later
10530
      if ( $vinf ) {
10531
  	$$rv->{original} = "v.Inf";
10532
  	$$rv->{vinf} = 1;
10533
      }
10534
      elsif ( $s > $start ) {
10535
  	$$rv->{original} = $start->currstr($s);
10536
  	if ( $qv && $saw_decimal == 1 && $start ne 'v' ) {
10537
  	    # need to insert a v to be consistent
10538
  	    $$rv->{original} = 'v' . $$rv->{original};
10539
  	}
10540
      }
10541
      else {
10542
  	$$rv->{original} = '0';
10543
  	push(@av, 0);
10544
      }
10545
  
10546
      # And finally, store the AV in the hash
10547
      $$rv->{version} = \@av;
10548
  
10549
      # fix RT#19517 - special case 'undef' as string
10550
      if ($s eq 'undef') {
10551
  	$s += 5;
10552
      }
10553
  
10554
      return $s;
10555
  }
10556
  
10557
  sub new
10558
  {
10559
  	my ($class, $value) = @_;
10560
  	my $self = bless ({}, ref ($class) || $class);
10561
  	my $qv = FALSE;
10562
  	
10563
  	if ( ref($value) && eval('$value->isa("version")') ) {
10564
  	    # Can copy the elements directly
10565
  	    $self->{version} = [ @{$value->{version} } ];
10566
  	    $self->{qv} = 1 if $value->{qv};
10567
  	    $self->{alpha} = 1 if $value->{alpha};
10568
  	    $self->{original} = ''.$value->{original};
10569
  	    return $self;
10570
  	}
10571
  
10572
  	my $currlocale = setlocale(LC_ALL);
10573
  
10574
  	# if the current locale uses commas for decimal points, we
10575
  	# just replace commas with decimal places, rather than changing
10576
  	# locales
10577
  	if ( localeconv()->{decimal_point} eq ',' ) {
10578
  	    $value =~ tr/,/./;
10579
  	}
10580
  
10581
  	if ( not defined $value or $value =~ /^undef$/ ) {
10582
  	    # RT #19517 - special case for undef comparison
10583
  	    # or someone forgot to pass a value
10584
  	    push @{$self->{version}}, 0;
10585
  	    $self->{original} = "0";
10586
  	    return ($self);
10587
  	}
10588
  
10589
  	if ( $#_ == 2 ) { # must be CVS-style
10590
  	    $value = $_[2];
10591
  	    $qv = TRUE;
10592
  	}
10593
  
10594
  	$value = _un_vstring($value);
10595
  
10596
  	# exponential notation
10597
  	if ( $value =~ /\d+.?\d*e[-+]?\d+/ ) {
10598
  	    $value = sprintf("%.9f",$value);
10599
  	    $value =~ s/(0+)$//; # trim trailing zeros
10600
  	}
10601
  	
10602
  	my $s = scan_version($value, \$self, $qv);
10603
  
10604
  	if ($s) { # must be something left over
10605
  	    warn("Version string '%s' contains invalid data; "
10606
                         ."ignoring: '%s'", $value, $s);
10607
  	}
10608
  
10609
  	return ($self);
10610
  }
10611
  
10612
  *parse = \&new;
10613
  
10614
  sub numify 
10615
  {
10616
      my ($self) = @_;
10617
      unless (_verify($self)) {
10618
  	require Carp;
10619
  	Carp::croak("Invalid version object");
10620
      }
10621
      my $width = $self->{width} || 3;
10622
      my $alpha = $self->{alpha} || "";
10623
      my $len = $#{$self->{version}};
10624
      my $digit = $self->{version}[0];
10625
      my $string = sprintf("%d.", $digit );
10626
  
10627
      for ( my $i = 1 ; $i < $len ; $i++ ) {
10628
  	$digit = $self->{version}[$i];
10629
  	if ( $width < 3 ) {
10630
  	    my $denom = 10**(3-$width);
10631
  	    my $quot = int($digit/$denom);
10632
  	    my $rem = $digit - ($quot * $denom);
10633
  	    $string .= sprintf("%0".$width."d_%d", $quot, $rem);
10634
  	}
10635
  	else {
10636
  	    $string .= sprintf("%03d", $digit);
10637
  	}
10638
      }
10639
  
10640
      if ( $len > 0 ) {
10641
  	$digit = $self->{version}[$len];
10642
  	if ( $alpha && $width == 3 ) {
10643
  	    $string .= "_";
10644
  	}
10645
  	$string .= sprintf("%0".$width."d", $digit);
10646
      }
10647
      else # $len = 0
10648
      {
10649
  	$string .= sprintf("000");
10650
      }
10651
  
10652
      return $string;
10653
  }
10654
  
10655
  sub normal 
10656
  {
10657
      my ($self) = @_;
10658
      unless (_verify($self)) {
10659
  	require Carp;
10660
  	Carp::croak("Invalid version object");
10661
      }
10662
      my $alpha = $self->{alpha} || "";
10663
      my $len = $#{$self->{version}};
10664
      my $digit = $self->{version}[0];
10665
      my $string = sprintf("v%d", $digit );
10666
  
10667
      for ( my $i = 1 ; $i < $len ; $i++ ) {
10668
  	$digit = $self->{version}[$i];
10669
  	$string .= sprintf(".%d", $digit);
10670
      }
10671
  
10672
      if ( $len > 0 ) {
10673
  	$digit = $self->{version}[$len];
10674
  	if ( $alpha ) {
10675
  	    $string .= sprintf("_%0d", $digit);
10676
  	}
10677
  	else {
10678
  	    $string .= sprintf(".%0d", $digit);
10679
  	}
10680
      }
10681
  
10682
      if ( $len <= 2 ) {
10683
  	for ( $len = 2 - $len; $len != 0; $len-- ) {
10684
  	    $string .= sprintf(".%0d", 0);
10685
  	}
10686
      }
10687
  
10688
      return $string;
10689
  }
10690
  
10691
  sub stringify
10692
  {
10693
      my ($self) = @_;
10694
      unless (_verify($self)) {
10695
  	require Carp;
10696
  	Carp::croak("Invalid version object");
10697
      }
10698
      return exists $self->{original} 
10699
      	? $self->{original} 
10700
  	: exists $self->{qv} 
10701
  	    ? $self->normal
10702
  	    : $self->numify;
10703
  }
10704
  
10705
  sub vcmp
10706
  {
10707
      require UNIVERSAL;
10708
      my ($left,$right,$swap) = @_;
10709
      my $class = ref($left);
10710
      unless ( UNIVERSAL::isa($right, $class) ) {
10711
  	$right = $class->new($right);
10712
      }
10713
  
10714
      if ( $swap ) {
10715
  	($left, $right) = ($right, $left);
10716
      }
10717
      unless (_verify($left)) {
10718
  	require Carp;
10719
  	Carp::croak("Invalid version object");
10720
      }
10721
      unless (_verify($right)) {
10722
  	require Carp;
10723
  	Carp::croak("Invalid version object");
10724
      }
10725
      my $l = $#{$left->{version}};
10726
      my $r = $#{$right->{version}};
10727
      my $m = $l < $r ? $l : $r;
10728
      my $lalpha = $left->is_alpha;
10729
      my $ralpha = $right->is_alpha;
10730
      my $retval = 0;
10731
      my $i = 0;
10732
      while ( $i <= $m && $retval == 0 ) {
10733
  	$retval = $left->{version}[$i] <=> $right->{version}[$i];
10734
  	$i++;
10735
      }
10736
  
10737
      # tiebreaker for alpha with identical terms
10738
      if ( $retval == 0 
10739
  	&& $l == $r 
10740
  	&& $left->{version}[$m] == $right->{version}[$m]
10741
  	&& ( $lalpha || $ralpha ) ) {
10742
  
10743
  	if ( $lalpha && !$ralpha ) {
10744
  	    $retval = -1;
10745
  	}
10746
  	elsif ( $ralpha && !$lalpha) {
10747
  	    $retval = +1;
10748
  	}
10749
      }
10750
  
10751
      # possible match except for trailing 0's
10752
      if ( $retval == 0 && $l != $r ) {
10753
  	if ( $l < $r ) {
10754
  	    while ( $i <= $r && $retval == 0 ) {
10755
  		if ( $right->{version}[$i] != 0 ) {
10756
  		    $retval = -1; # not a match after all
10757
  		}
10758
  		$i++;
10759
  	    }
10760
  	}
10761
  	else {
10762
  	    while ( $i <= $l && $retval == 0 ) {
10763
  		if ( $left->{version}[$i] != 0 ) {
10764
  		    $retval = +1; # not a match after all
10765
  		}
10766
  		$i++;
10767
  	    }
10768
  	}
10769
      }
10770
  
10771
      return $retval;  
10772
  }
10773
  
10774
  sub vbool {
10775
      my ($self) = @_;
10776
      return vcmp($self,$self->new("0"),1);
10777
  }
10778
  
10779
  sub vnoop { 
10780
      require Carp; 
10781
      Carp::croak("operation not supported with version object");
10782
  }
10783
  
10784
  sub is_alpha {
10785
      my ($self) = @_;
10786
      return (exists $self->{alpha});
10787
  }
10788
  
10789
  sub qv {
10790
      my $value = shift;
10791
      my $class = 'version';
10792
      if (@_) {
10793
  	$class = ref($value) || $value;
10794
  	$value = shift;
10795
      }
10796
  
10797
      $value = _un_vstring($value);
10798
      $value = 'v'.$value unless $value =~ /(^v|\d+\.\d+\.\d)/;
10799
      my $version = $class->new($value);
10800
      return $version;
10801
  }
10802
  
10803
  *declare = \&qv;
10804
  
10805
  sub is_qv {
10806
      my ($self) = @_;
10807
      return (exists $self->{qv});
10808
  }
10809
  
10810
  
10811
  sub _verify {
10812
      my ($self) = @_;
10813
      if ( ref($self)
10814
  	&& eval { exists $self->{version} }
10815
  	&& ref($self->{version}) eq 'ARRAY'
10816
  	) {
10817
  	return 1;
10818
      }
10819
      else {
10820
  	return 0;
10821
      }
10822
  }
10823
  
10824
  sub _is_non_alphanumeric {
10825
      my $s = shift;
10826
      $s = new charstar $s;
10827
      while ($s) {
10828
  	return 0 if isSPACE($s); # early out
10829
  	return 1 unless (isALPHA($s) || isDIGIT($s) || $s =~ /[.-]/);
10830
  	$s++;
10831
      }
10832
      return 0;
10833
  }
10834
  
10835
  sub _un_vstring {
10836
      my $value = shift;
10837
      # may be a v-string
10838
      if ( length($value) >= 3 && $value !~ /[._]/ 
10839
  	&& _is_non_alphanumeric($value)) {
10840
  	my $tvalue;
10841
  	if ( $] ge 5.008_001 ) {
10842
  	    $tvalue = _find_magic_vstring($value);
10843
  	    $value = $tvalue if length $tvalue;
10844
  	}
10845
  	elsif ( $] ge 5.006_000 ) {
10846
  	    $tvalue = sprintf("v%vd",$value);
10847
  	    if ( $tvalue =~ /^v\d+(\.\d+){2,}$/ ) {
10848
  		# must be a v-string
10849
  		$value = $tvalue;
10850
  	    }
10851
  	}
10852
      }
10853
      return $value;
10854
  }
10855
  
10856
  sub _find_magic_vstring {
10857
      my $value = shift;
10858
      my $tvalue = '';
10859
      require B;
10860
      my $sv = B::svref_2object(\$value);
10861
      my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef;
10862
      while ( $magic ) {
10863
  	if ( $magic->TYPE eq 'V' ) {
10864
  	    $tvalue = $magic->PTR;
10865
  	    $tvalue =~ s/^v?(.+)$/v$1/;
10866
  	    last;
10867
  	}
10868
  	else {
10869
  	    $magic = $magic->MOREMAGIC;
10870
  	}
10871
      }
10872
      return $tvalue;
10873
  }
10874
  
10875
  sub _VERSION {
10876
      my ($obj, $req) = @_;
10877
      my $class = ref($obj) || $obj;
10878
  
10879
      no strict 'refs';
10880
      if ( exists $INC{"$class.pm"} and not %{"$class\::"} and $] >= 5.008) {
10881
  	 # file but no package
10882
  	require Carp;
10883
  	Carp::croak( "$class defines neither package nor VERSION"
10884
  	    ."--version check failed");
10885
      }
10886
  
10887
      my $version = eval "\$$class\::VERSION";
10888
      if ( defined $version ) {
10889
  	local $^W if $] <= 5.008;
10890
  	$version = version::vpp->new($version);
10891
      }
10892
  
10893
      if ( defined $req ) {
10894
  	unless ( defined $version ) {
10895
  	    require Carp;
10896
  	    my $msg =  $] < 5.006 
10897
  	    ? "$class version $req required--this is only version "
10898
  	    : "$class does not define \$$class\::VERSION"
10899
  	      ."--version check failed";
10900
  
10901
  	    if ( $ENV{VERSION_DEBUG} ) {
10902
  		Carp::confess($msg);
10903
  	    }
10904
  	    else {
10905
  		Carp::croak($msg);
10906
  	    }
10907
  	}
10908
  
10909
  	$req = version::vpp->new($req);
10910
  
10911
  	if ( $req > $version ) {
10912
  	    require Carp;
10913
  	    if ( $req->is_qv ) {
10914
  		Carp::croak( 
10915
  		    sprintf ("%s version %s required--".
10916
  			"this is only version %s", $class,
10917
  			$req->normal, $version->normal)
10918
  		);
10919
  	    }
10920
  	    else {
10921
  		Carp::croak( 
10922
  		    sprintf ("%s version %s required--".
10923
  			"this is only version %s", $class,
10924
  			$req->stringify, $version->stringify)
10925
  		);
10926
  	    }
10927
  	}
10928
      }
10929
  
10930
      return defined $version ? $version->stringify : undef;
10931
  }
10932
  
10933
  1; #this line is important and will help the module return a true value
10934
VERSION_VPP
10935

            
10936
s/^  //mg for values %fatpacked;
10937

            
10938
unshift @INC, sub {
10939
  if (my $fat = $fatpacked{$_[1]}) {
10940
    open my $fh, '<', \$fat
10941
      or die "FatPacker error loading $_[1] (could be a perl installation issue?)";
10942
    return $fh;
10943
  }
10944
  return
10945
};
10946

            
10947
} # END OF FATPACK CODE
10948

            
10949
use strict;
10950
use App::cpanminus::script;
10951

            
10952
unless (caller) {
10953
    my $app = App::cpanminus::script->new;
10954
    $app->parse_options(@ARGV);
10955
    $app->doit or exit(1);
10956
}
10957

            
10958
__END__
10959

            
10960
=head1 NAME
10961

            
10962
cpanm - get, unpack build and install modules from CPAN
10963

            
10964
=head1 SYNOPSIS
10965

            
10966
  cpanm Test::More                                          # install Test::More
10967
  cpanm MIYAGAWA/Plack-0.99_05.tar.gz                       # full distribution path
10968
  cpanm http://example.org/LDS/CGI.pm-3.20.tar.gz           # install from URL
10969
  cpanm ~/dists/MyCompany-Enterprise-1.00.tar.gz            # install from a local file
10970
  cpanm --interactive Task::Kensho                          # Configure interactively
10971
  cpanm .                                                   # install from local directory
10972
  cpanm --installdeps .                                     # install all the deps for the current directory
10973
  cpanm -L extlib Plack                                     # install Plack and all non-core deps into extlib
10974
  cpanm --mirror http://cpan.cpantesters.org/ DBI           # use the fast-syncing mirror
10975
  cpanm --scandeps Moose                                    # See what modules will be installed for Moose
10976

            
10977
=head1 COMMANDS
10978

            
10979
=over 4
10980

            
10981
=item -i, --install
10982

            
10983
Installs the modules. This is a default behavior and this is just a
10984
compatibility option to make it work like L<cpan> or L<cpanp>.
10985

            
10986
=item --self-upgrade
10987

            
10988
Upgrades itself. It's just an alias for:
10989

            
10990
  cpanm App::cpanminus
10991

            
10992
=item --info
10993

            
10994
Displays the distribution information in
10995
C<AUTHOR/Dist-Name-ver.tar.gz> format in the standard out.
10996

            
10997
=item --installdeps
10998

            
10999
Installs the dependencies of the target distribution but won't build
11000
itself. Handy if you want to try the application from a version
11001
controlled repository such as git.
11002

            
11003
  cpanm --installdeps .
11004

            
11005
=item --look
11006

            
11007
Download and unpack the distribution and then open the directory with
11008
your shell. Handy to poke around the source code or do manual
11009
testing.
11010

            
11011
=item -h, --help
11012

            
11013
Displays the help message.
11014

            
11015
=item -V, --version
11016

            
11017
Displays the version number.
11018

            
11019
=back
11020

            
11021
=head1 OPTIONS
11022

            
11023
You can specify the default options in C<PERL_CPANM_OPT> environment variable.
11024

            
11025
=over 4
11026

            
11027
=item -f, --force
11028

            
11029
Force install modules even when testing failed.
11030

            
11031
=item -n, --notest
11032

            
11033
Skip the testing of modules. Use this only when you just want to save
11034
time for installing hundreds of distributions to the same perl and
11035
architecture you've already tested to make sure it builds fine.
11036

            
11037
Defaults to false, and you can say C<--no-notest> to override when it
11038
is set in the default options in C<PERL_CPANM_OPT>.
11039

            
11040
=item -S, --sudo
11041

            
11042
Switch to the root user with C<sudo> when installing modules. Use this
11043
if you want to install modules to the system perl include path.
11044

            
11045
Defaults to false, and you can say C<--no-sudo> to override when it is
11046
set in the default options in C<PERL_CPANM_OPT>.
11047

            
11048
=item -v, --verbose
11049

            
11050
Makes the output verbose. It also enables the interactive
11051
configuration. (See --interactive)
11052

            
11053
=item -q, --quiet
11054

            
11055
Makes the output even more quiet than the default. It doesn't print
11056
anything to the STDERR.
11057

            
11058
=item -l, --local-lib
11059

            
11060
Sets the L<local::lib> compatible path to install modules to. You
11061
don't need to set this if you already configure the shell environment
11062
variables using L<local::lib>, but this can be used to override that
11063
as well.
11064

            
11065
=item -L, --local-lib-contained
11066

            
11067
Same with C<--local-lib> but when examining the dependencies, it
11068
assumes no non-core modules are installed on the system. It's handy if
11069
you want to bundle application dependencies in one directory so you
11070
can distribute to other machines.
11071

            
11072
For instance,
11073

            
11074
  cpanm -L extlib Plack
11075

            
11076
would install Plack and all of its non-core dependencies into the
11077
directory C<extlib>, which can be loaded from your application with:
11078

            
11079
  use local::lib '/path/to/extlib';
11080

            
11081
=item --mirror
11082

            
11083
Specifies the base URL for the CPAN mirror to use, such as
11084
C<http://cpan.cpantesters.org/> (you can omit the trailing slash). You
11085
can specify multiple mirror URLs by repeating the command line option.
11086

            
11087
Defaults to C<http://search.cpan.org/CPAN> which is a geo location
11088
aware redirector.
11089

            
11090
=item --mirror-only
11091

            
11092
Download the mirror's 02packages.details.txt.gz index file instead of
11093
querying the CPAN Meta DB.
11094

            
11095
Select this option if you are using a local mirror of CPAN, such as
11096
minicpan when you're offline, or your own CPAN index (a.k.a darkpan).
11097

            
11098
B<Tip:> It might be useful if you name these mirror options with your
11099
shell aliases, like:
11100

            
11101
  alias minicpanm='cpanm --mirror ~/minicpan --mirror-only'
11102
  alias darkpan='cpanm --mirror http://mycompany.example.com/DPAN --mirror-only'
11103

            
11104
=item --mirror-index
11105

            
11106
B<EXPERIMENTAL>: Specifies the file path to C<02packages.details.txt>
11107
for module search index.
11108

            
11109
=item --metacpan
11110

            
11111
B<EXPERIMENTAL>: Use L<http://api.metacpan.org/> API for module lookup instead of
11112
L<http://cpanmetadb.plackperl.org/>.
11113
    
11114
=item --prompt
11115

            
11116
Prompts when a test fails so that you can skip, force install, retry
11117
or look in the shell to see what's going wrong. It also prompts when
11118
one of the dependency failed if you want to proceed the installation.
11119

            
11120
Defaults to false, and you can say C<--no-prompt> to override if it's
11121
set in the default options in C<PERL_CPANM_OPT>.
11122

            
11123
=item --reinstall
11124

            
11125
cpanm, when given a module name in the command line (i.e. C<cpanm
11126
Plack>), checks the locally installed version first and skips if it is
11127
already installed. This option makes it skip the check, so:
11128

            
11129
  cpanm --reinstall Plack
11130

            
11131
would reinstall L<Plack> even if your locally installed version is
11132
latest, or even newer (which would happen if you install a developer
11133
release from version control repositories).
11134

            
11135
Defaults to false.
11136

            
11137
=item --interactive
11138

            
11139
Makes the configuration (such as C<Makefile.PL> and C<Build.PL>)
11140
interactive, so you can answer questions in the distribution that
11141
requires custom configuration or Task:: distributions.
11142

            
11143
Defaults to false, and you can say C<--no-interactive> to override
11144
when it's set in the default options in C<PERL_CPANM_OPT>.
11145

            
11146
=item --scandeps
11147

            
11148
Scans the depencencies of given modules and output the tree in a text
11149
format. (See C<--format> below for more options)
11150

            
11151
Because this command doesn't actually install any distributions, it
11152
will be useful that by typing:
11153

            
11154
  cpanm --scandeps Catalyst::Runtime
11155

            
11156
you can make sure what modules will be installed.
11157

            
11158
This command takes into account which modules you already have
11159
installed in your system. If you want to see what modules will be
11160
installed against a vanilla perl installation, you might want to
11161
combine it with C<-L> option.
11162

            
11163
=item --format
11164

            
11165
Determines what format to display the scanned dependency
11166
tree. Available options are C<tree>, C<json>, C<yaml> and C<dists>.
11167

            
11168
=over 8
11169

            
11170
=item tree
11171

            
11172
Displays the tree in a plain text format. This is the default value.
11173

            
11174
=item json, yaml
11175

            
11176
Outputs the tree in a JSON or YAML format. L<JSON> and L<YAML> modules
11177
need to be installed respectively. The output tree is represented as a
11178
recursive tuple of:
11179

            
11180
  [ distribution, dependencies ]
11181

            
11182
and the container is an array containing the root elements. Note that
11183
there may be multiple root nodes, since you can give multiple modules
11184
to the C<--scandeps> command.
11185

            
11186
=item dists
11187

            
11188
C<dists> is a special output format, where it prints the distribution
11189
filename in the I<depth first order> after the dependency resolution,
11190
like:
11191

            
11192
  GAAS/MIME-Base64-3.13.tar.gz
11193
  GAAS/URI-1.58.tar.gz
11194
  PETDANCE/HTML-Tagset-3.20.tar.gz
11195
  GAAS/HTML-Parser-3.68.tar.gz
11196
  GAAS/libwww-perl-5.837.tar.gz
11197

            
11198
which means you can install these distributions in this order without
11199
extra dependencies. When combined with C<-L> option, it will be useful
11200
to replay installations on other machines.
11201

            
11202
=back
11203

            
11204
=item --save-dists
11205

            
11206
Specifies the optional directory path to copy downloaded tarballs in
11207
the CPAN mirror compatible directory structure
11208
i.e. I<authors/id/A/AU/AUTHORS/Foo-Bar-version.tar.gz>
11209

            
11210
=item --uninst-shadows
11211

            
11212
Uninstalls the shadow files of the distribution that you're
11213
installing. This eliminates the confusion if you're trying to install
11214
core (dual-life) modules from CPAN against perl 5.10 or older, or
11215
modules that used to be XS-based but switched to pure perl at some
11216
version.
11217

            
11218
If you run cpanm as root and use C<INSTALL_BASE> or equivalent to
11219
specify custom installation path, you SHOULD disable this option so
11220
you won't accidentally uninstall dual-life modules from the core
11221
include path.
11222

            
11223
Defaults to true if your perl version is smaller than 5.12, and you
11224
can disable that with C<--no-uninst-shadows>.
11225

            
11226
B<NOTE>: Since version 1.3000 this flag is turned off by default for
11227
perl newer than 5.12, since with 5.12 @INC contains site_perl directory
11228
I<before> the perl core library path, and uninstalling shadows is not
11229
necessary anymore and does more harm by deleting files from the core
11230
library path.
11231

            
11232
=item --cascade-search
11233

            
11234
B<EXPERIMENTAL>: Specifies whether to cascade search when you specify
11235
multiple mirrors and a mirror has a lower version of the module than
11236
requested. Defaults to false.
11237

            
11238
=item --skip-installed
11239

            
11240
Specifies whether a module given in the command line is skipped if its latest
11241
version is already installed. Defaults to true.
11242

            
11243
B<NOTE>: The C<PERL5LIB> environment variable have to be correctly set for this
11244
to work with modules installed using L<local::lib>.
11245

            
11246
=item --skip-satisfied
11247

            
11248
B<EXPERIMENTAL>: Specifies whether a module (and version) given in the
11249
command line is skipped if it's already installed.
11250

            
11251
If you run:
11252

            
11253
  cpanm --skip-satisfied CGI DBI~1.2
11254

            
11255
cpanm won't install them if you already have CGI (for whatever
11256
versions) or have DBI with version higher than 1.2. It is similar to
11257
C<--skip-installed> but while C<--skip-installed> checks if the
11258
I<latest> version of CPAN is installed, C<--skip-satisfied> checks if
11259
a requested version (or not, which means any version) is installed.
11260

            
11261
Defaults to false for bare module names, but if you specify versions
11262
with C<~>, it will always skip satisfied requirements.
11263

            
11264
=item --auto-cleanup
11265

            
11266
Specifies the number of days in which cpanm's work directories
11267
expire. Defaults to 7, which means old work directories will be
11268
cleaned up in one week.
11269

            
11270
You can set the value to C<0> to make cpan never cleanup those
11271
directories.
11272

            
11273
=item --man-pages
11274

            
11275
Generates man pages for executables (man1) and libraries (man3).
11276

            
11277
Defaults to false (no man pages generated) if
11278
C<-L|--local-lib-contained> option is supplied. Otherwise, defaults to
11279
true, and you can disable it with C<--no-man-pages>.
11280

            
11281
=item --lwp
11282

            
11283
Uses L<LWP> module to download stuff over HTTP. Defaults to true, and
11284
you can say C<--no-lwp> to disable using LWP, when you want to upgrade
11285
LWP from CPAN on some broken perl systems.
11286

            
11287
=item --wget
11288

            
11289
Uses GNU Wget (if available) to download stuff. Defaults to true, and
11290
you can say C<--no-wget> to disable using Wget (versions of Wget older
11291
than 1.9 don't support the C<--retry-connrefused> option used by cpanm).
11292

            
11293
=item --curl
11294

            
11295
Uses cURL (if available) to download stuff. Defaults to true, and
11296
you can say C<--no-curl> to disable using cURL.
11297

            
11298
Normally with C<--lwp>, C<--wget> and C<--curl> options set to true
11299
(which is the default) cpanm tries L<LWP>, Wget, cURL and L<HTTP::Tiny>
11300
(in that order) and uses the first one available.
11301

            
11302
=back
11303

            
11304
=head1 SEE ALSO
11305

            
11306
L<App::cpanminus>
11307

            
11308
=head1 COPYRIGHT
11309

            
11310
Copyright 2010 Tatsuhiko Miyagawa.
11311

            
11312
=head1 AUTHOR
11313

            
11314
Tatsuhiko Miyagawa
11315

            
11316
=cut