biblesearch / cpanm /
Yuki Kimoto add files
aa0f2e9 11 years ago
1 contributor
12603 lines | 366.554kb
  1. #!/usr/bin/env perl
  2. #
  3. # You want to install cpanminus? Run the following command and it will
  4. # install itself for you. You might want to run it as a root with sudo
  5. # if you want to install to places like /usr/local/bin.
  6. #
  7. # % curl -L http://cpanmin.us | perl - --self-upgrade
  8. #
  9. # If you don't have curl but wget, replace `curl -L` with `wget -O -`.
  10. #
  11. # For more details about this program, visit http://search.cpan.org/dist/App-cpanminus
  12. #
  13. # DO NOT EDIT -- this is an auto generated file
  14. # This chunk of stuff was generated by App::FatPacker. To find the original
  15. # file's code, look for the end of this BEGIN block or the string 'FATPACK'
  16. BEGIN {
  17. my %fatpacked;
  18.  
  19. $fatpacked{"App/cpanminus.pm"} = <<'APP_CPANMINUS';
  20. package App::cpanminus;
  21. our $VERSION = "1.6005";
  22. =head1 NAME
  23. App::cpanminus - get, unpack, build and install modules from CPAN
  24. =head1 SYNOPSIS
  25. cpanm Module
  26. Run C<cpanm -h> or C<perldoc cpanm> for more options.
  27. =head1 DESCRIPTION
  28. cpanminus is a script to get, unpack, build and install modules from
  29. CPAN and does nothing else.
  30. It's dependency free (can bootstrap itself), requires zero
  31. configuration, and stands alone. When running, it requires only 10MB
  32. of RAM.
  33. =head1 INSTALLATION
  34. There are several ways to install cpanminus to your system.
  35. =head2 Package management system
  36. There are Debian packages, RPMs, FreeBSD ports, and packages for other
  37. operation systems available. If you want to use the package management system,
  38. search for cpanminus and use the appropriate command to install. This makes it
  39. easy to install C<cpanm> to your system without thinking about where to
  40. install, and later upgrade.
  41. =head2 Installing to system perl
  42. You can also use the latest cpanminus to install cpanminus itself:
  43. curl -L http://cpanmin.us | perl - --sudo App::cpanminus
  44. This will install C<cpanm> to your bin directory like
  45. C</usr/local/bin> (unless you configured C<INSTALL_BASE> with
  46. L<local::lib>), so you probably need the C<--sudo> option.
  47. =head2 Installing to local perl (perlbrew)
  48. If you have perl in your home directory, which is the case if you use
  49. tools like L<perlbrew>, you don't need the C<--sudo> option, since
  50. you're most likely to have a write permission to the perl's library
  51. path. You can just do:
  52. curl -L http://cpanmin.us | perl - App::cpanminus
  53. to install the C<cpanm> executable to the perl's bin path, like
  54. C<~/perl5/perlbrew/bin/cpanm>.
  55. =head2 Downloading the standalone executable
  56. You can also copy the standalone executable to whatever location you'd like.
  57. cd ~/bin
  58. curl -LO http://xrl.us/cpanm
  59. chmod +x cpanm
  60. # edit shebang if you don't have /usr/bin/env
  61. This just works, but be sure to grab the new version manually when you
  62. upgrade because C<--self-upgrade> might not work for this.
  63. =head1 DEPENDENCIES
  64. perl 5.8 or later.
  65. =over 4
  66. =item *
  67. 'tar' executable (bsdtar or GNU tar version 1.22 are rcommended) or Archive::Tar to unpack files.
  68. =item *
  69. C compiler, if you want to build XS modules.
  70. =item *
  71. make
  72. =item *
  73. Module::Build (core in 5.10)
  74. =back
  75. =head1 QUESTIONS
  76. =head2 Another CPAN installer?
  77. OK, the first motivation was this: the CPAN shell runs out of memory (or swaps
  78. heavily and gets really slow) on Slicehost/linode's most affordable plan with
  79. only 256MB RAM. Should I pay more to install perl modules from CPAN? I don't
  80. think so.
  81. =head2 But why a new client?
  82. First of all, let me be clear that CPAN and CPANPLUS are great tools
  83. I've used for I<literally> years (you know how many modules I have on
  84. CPAN, right?). I really respect their efforts of maintaining the most
  85. important tools in the CPAN toolchain ecosystem.
  86. However, for less experienced users (mostly from outside the Perl community),
  87. or even really experienced Perl developers who know how to shoot themselves in
  88. their feet, setting up the CPAN toolchain often feels like yak shaving,
  89. especially when all they want to do is just install some modules and start
  90. writing code.
  91. =head2 Zero-conf? How does this module get/parse/update the CPAN index?
  92. It queries the CPAN Meta DB site at L<http://cpanmetadb.plackperl.org/>.
  93. The site is updated at least every hour to reflect the latest changes
  94. from fast syncing mirrors. The script then also falls back to query the
  95. module at L<http://metacpan.org/> using its wonderful API.
  96. Fetched files are unpacked in C<~/.cpanm> and automatically cleaned up
  97. periodically. You can configure the location of this with the
  98. C<PERL_CPANM_HOME> environment variable.
  99. =head2 Where does this install modules to? Do I need root access?
  100. It installs to wherever ExtUtils::MakeMaker and Module::Build are
  101. configured to (via C<PERL_MM_OPT> and C<PERL_MB_OPT>). So if you're
  102. using local::lib, then it installs to your local perl5
  103. directory. Otherwise it installs to the site_perl directory that
  104. belongs to your perl.
  105. cpanminus at a boot time checks whether you have configured
  106. local::lib, or have the permission to install modules to the site_perl
  107. directory. If neither, it automatically sets up local::lib compatible
  108. installation path in a C<perl5> directory under your home
  109. directory. To avoid this, run the script as the root user, with
  110. C<--sudo> option or with C<--local-lib> option.
  111. =head2 cpanminus can't install the module XYZ. Is it a bug?
  112. It is more likely a problem with the distribution itself. cpanminus
  113. doesn't support or is known to have issues with distributions like as
  114. follows:
  115. =over 4
  116. =item *
  117. Tests that require input from STDIN.
  118. =item *
  119. Tests that might fail when C<AUTOMATED_TESTING> is enabled.
  120. =item *
  121. Modules that have invalid numeric values as VERSION (such as C<1.1a>)
  122. =back
  123. These failures can be reported back to the author of the module so
  124. that they can fix it accordingly, rather than me.
  125. =head2 Does cpanm support the feature XYZ of L<CPAN> and L<CPANPLUS>?
  126. Most likely not. Here are the things that cpanm doesn't do by
  127. itself. And it's a feature - you got that from the name I<minus>,
  128. right?
  129. If you need these features, use L<CPAN>, L<CPANPLUS> or the standalone
  130. tools that are mentioned.
  131. =over 4
  132. =item *
  133. Bundle:: module dependencies
  134. =item *
  135. CPAN testers reporting
  136. =item *
  137. Building RPM packages from CPAN modules
  138. =item *
  139. Listing the outdated modules that needs upgrading. See L<App::cpanoutdated>
  140. =item *
  141. Uninstalling modules. See L<pm-uninstall>.
  142. =item *
  143. Showing the changes of the modules you're about to upgrade. See L<cpan-listchanges>
  144. =item *
  145. Patching CPAN modules with distroprefs.
  146. =back
  147. See L<cpanm> or C<cpanm -h> to see what cpanminus I<can> do :)
  148. =head1 COPYRIGHT
  149. Copyright 2010- Tatsuhiko Miyagawa
  150. The standalone executable contains the following modules embedded.
  151. =over 4
  152. =item L<CPAN::DistnameInfo> Copyright 2003 Graham Barr
  153. =item L<Parse::CPAN::Meta> Copyright 2006-2009 Adam Kennedy
  154. =item L<local::lib> Copyright 2007-2009 Matt S Trout
  155. =item L<HTTP::Tiny> Copyright 2011 Christian Hansen
  156. =item L<Module::Metadata> Copyright 2001-2006 Ken Williams. 2010 Matt S Trout
  157. =item L<version> Copyright 2004-2010 John Peacock
  158. =item L<JSON::PP> Copyright 2007−2011 by Makamaka Hannyaharamitu
  159. =item L<CPAN::Meta>, L<CPAN::Meta::Requirements> Copyright (c) 2010 by David Golden and Ricardo Signes
  160. =item L<CPAN::Meta::YAML> Copyright 2010 Adam Kennedy
  161. =item L<File::pushd> Copyright 2012 David Golden
  162. =back
  163. =head1 LICENSE
  164. Same as Perl.
  165. =head1 CREDITS
  166. =head2 CONTRIBUTORS
  167. Patches and code improvements were contributed by:
  168. Goro Fuji, Kazuhiro Osawa, Tokuhiro Matsuno, Kenichi Ishigaki, Ian
  169. Wells, Pedro Melo, Masayoshi Sekimura, Matt S Trout (mst), squeeky,
  170. horus and Ingy dot Net.
  171. =head2 ACKNOWLEDGEMENTS
  172. Bug reports, suggestions and feedbacks were sent by, or general
  173. acknowledgement goes to:
  174. Jesse Vincent, David Golden, Andreas Koenig, Jos Boumans, Chris
  175. Williams, Adam Kennedy, Audrey Tang, J. Shirley, Chris Prather, Jesse
  176. Luehrs, Marcus Ramberg, Shawn M Moore, chocolateboy, Chirs Nehren,
  177. Jonathan Rockway, Leon Brocard, Simon Elliott, Ricardo Signes, AEvar
  178. Arnfjord Bjarmason, Eric Wilhelm, Florian Ragwitz and xaicron.
  179. =head1 COMMUNITY
  180. =over 4
  181. =item L<http://github.com/miyagawa/cpanminus> - source code repository, issue tracker
  182. =item L<irc://irc.perl.org/#toolchain> - discussions about Perl toolchain. I'm there.
  183. =back
  184. =head1 NO WARRANTY
  185. This software is provided "as-is," without any express or implied
  186. warranty. In no event shall the author be held liable for any damages
  187. arising from the use of the software.
  188. =head1 SEE ALSO
  189. L<CPAN> L<CPANPLUS> L<pip>
  190. =cut
  191. 1;
  192. APP_CPANMINUS
  193.  
  194. $fatpacked{"App/cpanminus/script.pm"} = <<'APP_CPANMINUS_SCRIPT';
  195. package App::cpanminus::script;
  196. use strict;
  197. use Config;
  198. use Cwd ();
  199. use App::cpanminus;
  200. use File::Basename ();
  201. use File::Find ();
  202. use File::Path ();
  203. use File::Spec ();
  204. use File::Copy ();
  205. use File::Temp ();
  206. use Getopt::Long ();
  207. use Parse::CPAN::Meta;
  208. use Symbol ();
  209. use constant WIN32 => $^O eq 'MSWin32';
  210. use constant SUNOS => $^O eq 'solaris';
  211. our $VERSION = $App::cpanminus::VERSION;
  212. if ($INC{"App/FatPacker/Trace.pm"}) {
  213. require JSON::PP;
  214. require CPAN::Meta::YAML;
  215. require CPAN::Meta::Prereqs;
  216. require version::vpp;
  217. require File::pushd;
  218. }
  219. my $quote = WIN32 ? q/"/ : q/'/;
  220. sub agent {
  221. my $self = shift;
  222. "cpanminus/$VERSION perl/$]";
  223. }
  224. sub determine_home {
  225. my $class = shift;
  226. my $homedir = $ENV{HOME}
  227. || eval { require File::HomeDir; File::HomeDir->my_home }
  228. || join('', @ENV{qw(HOMEDRIVE HOMEPATH)}); # Win32
  229. if (WIN32) {
  230. require Win32; # no fatpack
  231. $homedir = Win32::GetShortPathName($homedir);
  232. }
  233. return "$homedir/.cpanm";
  234. }
  235. sub new {
  236. my $class = shift;
  237. bless {
  238. home => $class->determine_home,
  239. cmd => 'install',
  240. seen => {},
  241. notest => undef,
  242. test_only => undef,
  243. installdeps => undef,
  244. force => undef,
  245. sudo => undef,
  246. make => undef,
  247. verbose => undef,
  248. quiet => undef,
  249. interactive => undef,
  250. log => undef,
  251. mirrors => [],
  252. mirror_only => undef,
  253. mirror_index => undef,
  254. perl => $^X,
  255. argv => [],
  256. local_lib => undef,
  257. self_contained => undef,
  258. prompt_timeout => 0,
  259. prompt => undef,
  260. configure_timeout => 60,
  261. try_lwp => 1,
  262. try_wget => 1,
  263. try_curl => 1,
  264. uninstall_shadows => ($] < 5.012),
  265. skip_installed => 1,
  266. skip_satisfied => 0,
  267. auto_cleanup => 7, # days
  268. pod2man => 1,
  269. installed_dists => 0,
  270. showdeps => 0,
  271. scandeps => 0,
  272. scandeps_tree => [],
  273. format => 'tree',
  274. save_dists => undef,
  275. skip_configure => 0,
  276. verify => 0,
  277. @_,
  278. }, $class;
  279. }
  280. sub env {
  281. my($self, $key) = @_;
  282. $ENV{"PERL_CPANM_" . $key};
  283. }
  284. sub parse_options {
  285. my $self = shift;
  286. local @ARGV = @{$self->{argv}};
  287. push @ARGV, split /\s+/, $self->env('OPT');
  288. push @ARGV, @_;
  289. Getopt::Long::Configure("bundling");
  290. Getopt::Long::GetOptions(
  291. 'f|force' => sub { $self->{skip_installed} = 0; $self->{force} = 1 },
  292. 'n|notest!' => \$self->{notest},
  293. 'test-only' => sub { $self->{notest} = 0; $self->{skip_installed} = 0; $self->{test_only} = 1 },
  294. 'S|sudo!' => \$self->{sudo},
  295. 'v|verbose' => sub { $self->{verbose} = $self->{interactive} = 1 },
  296. 'verify!' => \$self->{verify},
  297. 'q|quiet!' => \$self->{quiet},
  298. 'h|help' => sub { $self->{action} = 'show_help' },
  299. 'V|version' => sub { $self->{action} = 'show_version' },
  300. 'perl=s' => \$self->{perl},
  301. 'l|local-lib=s' => sub { $self->{local_lib} = $self->maybe_abs($_[1]) },
  302. 'L|local-lib-contained=s' => sub {
  303. $self->{local_lib} = $self->maybe_abs($_[1]);
  304. $self->{self_contained} = 1;
  305. $self->{pod2man} = undef;
  306. },
  307. 'mirror=s@' => $self->{mirrors},
  308. 'mirror-only!' => \$self->{mirror_only},
  309. 'mirror-index=s' => \$self->{mirror_index},
  310. 'cascade-search!' => \$self->{cascade_search},
  311. 'prompt!' => \$self->{prompt},
  312. 'installdeps' => \$self->{installdeps},
  313. 'skip-installed!' => \$self->{skip_installed},
  314. 'skip-satisfied!' => \$self->{skip_satisfied},
  315. 'reinstall' => sub { $self->{skip_installed} = 0 },
  316. 'interactive!' => \$self->{interactive},
  317. 'i|install' => sub { $self->{cmd} = 'install' },
  318. 'info' => sub { $self->{cmd} = 'info' },
  319. 'look' => sub { $self->{cmd} = 'look'; $self->{skip_installed} = 0 },
  320. 'self-upgrade' => sub { $self->check_upgrade; $self->{cmd} = 'install'; $self->{skip_installed} = 1; push @ARGV, 'App::cpanminus' },
  321. 'uninst-shadows!' => \$self->{uninstall_shadows},
  322. 'lwp!' => \$self->{try_lwp},
  323. 'wget!' => \$self->{try_wget},
  324. 'curl!' => \$self->{try_curl},
  325. 'auto-cleanup=s' => \$self->{auto_cleanup},
  326. 'man-pages!' => \$self->{pod2man},
  327. 'scandeps' => \$self->{scandeps},
  328. 'showdeps' => sub { $self->{showdeps} = 1; $self->{skip_installed} = 0 },
  329. 'format=s' => \$self->{format},
  330. 'save-dists=s' => sub {
  331. $self->{save_dists} = $self->maybe_abs($_[1]);
  332. },
  333. 'skip-configure!' => \$self->{skip_configure},
  334. 'dev!' => \$self->{dev_release},
  335. 'metacpan!' => \$self->{metacpan},
  336. );
  337. if (!@ARGV && $0 ne '-' && !-t STDIN){ # e.g. # cpanm < author/requires.cpanm
  338. push @ARGV, $self->load_argv_from_fh(\*STDIN);
  339. $self->{load_from_stdin} = 1;
  340. }
  341. $self->{argv} = \@ARGV;
  342. }
  343. sub check_upgrade {
  344. if ($0 !~ /^$Config{installsitebin}/) {
  345. if ($0 =~ m!perlbrew/bin!) {
  346. warn <<WARN;
  347. It appears your cpanm executable was installed via `perlbrew install-cpanm`.
  348. cpanm --self-upgrade won't upgrade the version of cpanm you're running.
  349. Run the following command to get it upgraded.
  350. perlbrew install-cpanm
  351. WARN
  352. } else {
  353. warn <<WARN;
  354. You are running cpanm from the path where your current perl won't install executables to.
  355. Because of that, cpanm --self-upgrade won't upgrade the version of cpanm you're running.
  356. cpanm path : $0
  357. Install path : $Config{installsitebin}
  358. It means you either installed cpanm globally with system perl, or use distro packages such
  359. as rpm or apt-get, and you have to use them again to upgrade cpanm.
  360. WARN
  361. }
  362. }
  363. }
  364. sub check_libs {
  365. my $self = shift;
  366. return if $self->{_checked}++;
  367. $self->bootstrap_local_lib;
  368. if (@{$self->{bootstrap_deps} || []}) {
  369. local $self->{notest} = 1; # test failure in bootstrap should be tolerated
  370. local $self->{scandeps} = 0;
  371. $self->install_deps(Cwd::cwd, 0, @{$self->{bootstrap_deps}});
  372. }
  373. }
  374. sub setup_verify {
  375. my $self = shift;
  376. my $has_modules = eval { require Module::Signature; require Digest::SHA; 1 };
  377. $self->{cpansign} = $self->which('cpansign');
  378. unless ($has_modules && $self->{cpansign}) {
  379. warn "WARNING: Module::Signature and Digest::SHA is required for distribution verifications.\n";
  380. $self->{verify} = 0;
  381. }
  382. }
  383. sub parse_module_args {
  384. my($self, $module) = @_;
  385. # Plack@1.2 -> Plack~"==1.2"
  386. # BUT don't expand @ in git URLs
  387. $module =~ s/^([A-Za-z0-9_:]+)@([v\d\._]+)$/$1~== $2/;
  388. # Plack~1.20, DBI~"> 1.0, <= 2.0"
  389. if ($module =~ /\~[v\d\._,\!<>= ]+$/) {
  390. return split /\~/, $module, 2;
  391. } else {
  392. return $module, undef;
  393. }
  394. }
  395. sub doit {
  396. my $self = shift;
  397. $self->setup_home;
  398. $self->init_tools;
  399. $self->setup_verify if $self->{verify};
  400. if (my $action = $self->{action}) {
  401. $self->$action() and return 1;
  402. }
  403. $self->show_help(1)
  404. unless @{$self->{argv}} or $self->{load_from_stdin};
  405. $self->configure_mirrors;
  406. my $cwd = Cwd::cwd;
  407. my @fail;
  408. for my $module (@{$self->{argv}}) {
  409. if ($module =~ s/\.pm$//i) {
  410. my ($volume, $dirs, $file) = File::Spec->splitpath($module);
  411. $module = join '::', grep { $_ } File::Spec->splitdir($dirs), $file;
  412. }
  413. ($module, my $version) = $self->parse_module_args($module);
  414. if ($self->{skip_satisfied}) {
  415. $self->check_libs;
  416. my($ok, $local) = $self->check_module($module, $version || 0);
  417. if ($ok) {
  418. $self->diag("You have $module ($local)\n", 1);
  419. next;
  420. }
  421. }
  422. $self->chdir($cwd);
  423. $self->install_module($module, 0, $version)
  424. or push @fail, $module;
  425. }
  426. if ($self->{base} && $self->{auto_cleanup}) {
  427. $self->cleanup_workdirs;
  428. }
  429. if ($self->{installed_dists}) {
  430. my $dists = $self->{installed_dists} > 1 ? "distributions" : "distribution";
  431. $self->diag("$self->{installed_dists} $dists installed\n", 1);
  432. }
  433. if ($self->{scandeps}) {
  434. $self->dump_scandeps();
  435. }
  436. # Workaround for older File::Temp's
  437. # where creating a tempdir with an implicit $PWD
  438. # causes tempdir non-cleanup if $PWD changes
  439. # as paths are stored internally without being resolved
  440. # absolutely.
  441. # https://rt.cpan.org/Public/Bug/Display.html?id=44924
  442. $self->chdir($cwd);
  443. return !@fail;
  444. }
  445. sub setup_home {
  446. my $self = shift;
  447. $self->{home} = $self->env('HOME') if $self->env('HOME');
  448. unless (_writable($self->{home})) {
  449. die "Can't write to cpanm home '$self->{home}': You should fix it with chown/chmod first.\n";
  450. }
  451. $self->{base} = "$self->{home}/work/" . time . ".$$";
  452. File::Path::mkpath([ $self->{base} ], 0, 0777);
  453. my $link = "$self->{home}/latest-build";
  454. eval { unlink $link; symlink $self->{base}, $link };
  455. $self->{log} = File::Spec->catfile($self->{home}, "build.log"); # because we use shell redirect
  456. {
  457. my $log = $self->{log}; my $base = $self->{base};
  458. $self->{at_exit} = sub {
  459. my $self = shift;
  460. File::Copy::copy($self->{log}, "$self->{base}/build.log");
  461. };
  462. }
  463. { open my $out, ">$self->{log}" or die "$self->{log}: $!" }
  464. $self->chat("cpanm (App::cpanminus) $VERSION on perl $] built for $Config{archname}\n" .
  465. "Work directory is $self->{base}\n");
  466. }
  467. sub fetch_meta_sco {
  468. my($self, $dist) = @_;
  469. return if $self->{mirror_only};
  470. my $meta_yml = $self->get("http://search.cpan.org/meta/$dist->{distvname}/META.yml");
  471. return $self->parse_meta_string($meta_yml);
  472. }
  473. sub package_index_for {
  474. my ($self, $mirror) = @_;
  475. return $self->source_for($mirror) . "/02packages.details.txt";
  476. }
  477. sub generate_mirror_index {
  478. my ($self, $mirror) = @_;
  479. my $file = $self->package_index_for($mirror);
  480. my $gz_file = $file . '.gz';
  481. my $index_mtime = (stat $gz_file)[9];
  482. unless (-e $file && (stat $file)[9] >= $index_mtime) {
  483. $self->chat("Uncompressing index file...\n");
  484. if (eval {require Compress::Zlib}) {
  485. my $gz = Compress::Zlib::gzopen($gz_file, "rb")
  486. or do { $self->diag_fail("$Compress::Zlib::gzerrno opening compressed index"); return};
  487. open my $fh, '>', $file
  488. or do { $self->diag_fail("$! opening uncompressed index for write"); return };
  489. my $buffer;
  490. while (my $status = $gz->gzread($buffer)) {
  491. if ($status < 0) {
  492. $self->diag_fail($gz->gzerror . " reading compressed index");
  493. return;
  494. }
  495. print $fh $buffer;
  496. }
  497. } else {
  498. if (system("gunzip -c $gz_file > $file")) {
  499. $self->diag_fail("Cannot uncompress -- please install gunzip or Compress::Zlib");
  500. return;
  501. }
  502. }
  503. utime $index_mtime, $index_mtime, $file;
  504. }
  505. return 1;
  506. }
  507. sub search_mirror_index {
  508. my ($self, $mirror, $module, $version) = @_;
  509. $self->search_mirror_index_file($self->package_index_for($mirror), $module, $version);
  510. }
  511. sub search_mirror_index_file {
  512. my($self, $file, $module, $version) = @_;
  513. open my $fh, '<', $file or return;
  514. my $found;
  515. while (<$fh>) {
  516. if (m!^\Q$module\E\s+([\w\.]+)\s+(\S*)!m) {
  517. $found = $self->cpan_module($module, $2, $1);
  518. last;
  519. }
  520. }
  521. return $found unless $self->{cascade_search};
  522. if ($found) {
  523. if ($self->satisfy_version($module, $found->{module_version}, $version)) {
  524. return $found;
  525. } else {
  526. $self->chat("Found $module $found->{module_version} which doesn't satisfy $version.\n");
  527. }
  528. }
  529. return;
  530. }
  531. sub with_version_range {
  532. my($self, $version) = @_;
  533. defined($version) && $version =~ /[<>=]/;
  534. }
  535. sub encode_json {
  536. my($self, $data) = @_;
  537. require JSON::PP;
  538. my $json = JSON::PP::encode_json($data);
  539. $json =~ s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/eg;
  540. $json;
  541. }
  542. # TODO extract this as a module?
  543. sub version_to_query {
  544. my($self, $module, $version) = @_;
  545. require CPAN::Meta::Requirements;
  546. my $requirements = CPAN::Meta::Requirements->new;
  547. $requirements->add_string_requirement($module, $version || '0');
  548. my $req = $requirements->requirements_for_module($module);
  549. if ($req =~ s/^==\s*//) {
  550. return {
  551. term => { 'module.version' => $req },
  552. };
  553. } elsif ($req !~ /\s/) {
  554. return {
  555. range => { 'module.version_numified' => { 'gte' => $self->numify_ver($req) } },
  556. };
  557. } else {
  558. my %ops = qw(< lt <= lte > gt >= gte);
  559. my(%range, @exclusion);
  560. my @requirements = split /,\s*/, $req;
  561. for my $r (@requirements) {
  562. if ($r =~ s/^([<>]=?)\s*//) {
  563. $range{$ops{$1}} = $self->numify_ver($r);
  564. } elsif ($r =~ s/\!=\s*//) {
  565. push @exclusion, $self->numify_ver($r);
  566. }
  567. }
  568. my @filters= (
  569. { range => { 'module.version_numified' => \%range } },
  570. );
  571. if (@exclusion) {
  572. push @filters, {
  573. not => { or => [ map { +{ term => { 'module.version_numified' => $self->numify_ver($_) } } } @exclusion ] },
  574. };
  575. }
  576. return @filters;
  577. }
  578. }
  579. sub numify_ver {
  580. my($self, $ver) = @_;
  581. version->new($ver)->numify;
  582. }
  583. sub maturity_filter {
  584. my($self, $module, $version) = @_;
  585. my @filters;
  586. # TODO: dev release should be enabled per dist
  587. if (!$self->with_version_range($version) or $self->{dev_release}) {
  588. # backpan'ed dev release are considered "cancelled"
  589. push @filters, { not => { term => { status => 'backpan' } } };
  590. }
  591. unless ($self->{dev_release} or $version =~ /==/) {
  592. push @filters, { term => { maturity => 'released' } };
  593. }
  594. return @filters;
  595. }
  596. sub search_metacpan {
  597. my($self, $module, $version) = @_;
  598. require JSON::PP;
  599. $self->chat("Searching $module ($version) on metacpan ...\n");
  600. my $metacpan_uri = 'http://api.metacpan.org/v0';
  601. my @filter = $self->maturity_filter($module, $version);
  602. my $query = { filtered => {
  603. (@filter ? (filter => { and => \@filter }) : ()),
  604. query => { nested => {
  605. score_mode => 'max',
  606. path => 'module',
  607. query => { custom_score => {
  608. metacpan_script => "score_version_numified",
  609. query => { constant_score => {
  610. filter => { and => [
  611. { term => { 'module.authorized' => JSON::PP::true() } },
  612. { term => { 'module.indexed' => JSON::PP::true() } },
  613. { term => { 'module.name' => $module } },
  614. $self->version_to_query($module, $version),
  615. ] }
  616. } },
  617. } },
  618. } },
  619. } };
  620. my $module_uri = "$metacpan_uri/file/_search?source=";
  621. $module_uri .= $self->encode_json({
  622. query => $query,
  623. fields => [ 'release', 'module' ],
  624. });
  625. my($release, $module_version);
  626. my $module_json = $self->get($module_uri);
  627. my $module_meta = eval { JSON::PP::decode_json($module_json) };
  628. my $match = $module_meta ? $module_meta->{hits}{hits}[0]{fields} : undef;
  629. if ($match) {
  630. $release = $match->{release};
  631. my $module_matched = (grep { $_->{name} eq $module } @{$match->{module}})[0];
  632. $module_version = $module_matched->{version};
  633. }
  634. unless ($release) {
  635. $self->chat("! Could not find a release matching $module ($version) on MetaCPAN.\n");
  636. return;
  637. }
  638. my $dist_uri = "$metacpan_uri/release/_search?source=";
  639. $dist_uri .= $self->encode_json({
  640. filter => {
  641. term => { 'release.name' => $release },
  642. },
  643. fields => [ 'download_url', 'stat', 'status' ],
  644. });
  645. my $dist_json = $self->get($dist_uri);
  646. my $dist_meta = eval { JSON::PP::decode_json($dist_json) };
  647. if ($dist_meta) {
  648. $dist_meta = $dist_meta->{hits}{hits}[0]{fields};
  649. }
  650. if ($dist_meta && $dist_meta->{download_url}) {
  651. (my $distfile = $dist_meta->{download_url}) =~ s!.+/authors/id/!!;
  652. local $self->{mirrors} = $self->{mirrors};
  653. if ($dist_meta->{status} eq 'backpan') {
  654. $self->{mirrors} = [ 'http://backpan.perl.org' ];
  655. } elsif ($dist_meta->{stat}{mtime} > time()-24*60*60) {
  656. $self->{mirrors} = [ 'http://cpan.metacpan.org' ];
  657. }
  658. return $self->cpan_module($module, $distfile, $module_version);
  659. }
  660. $self->diag_fail("Finding $module on metacpan failed.");
  661. return;
  662. }
  663. sub search_database {
  664. my($self, $module, $version) = @_;
  665. my $found;
  666. my $range = ($self->with_version_range($version) || $self->{dev_release});
  667. if ($range or $self->{metacpan}) {
  668. $found = $self->search_metacpan($module, $version) and return $found;
  669. $found = $self->search_cpanmetadb($module, $version) and return $found;
  670. } else {
  671. $found = $self->search_cpanmetadb($module, $version) and return $found;
  672. $found = $self->search_metacpan($module, $version) and return $found;
  673. }
  674. }
  675. sub search_cpanmetadb {
  676. my($self, $module, $version) = @_;
  677. $self->chat("Searching $module on cpanmetadb ...\n");
  678. my $uri = "http://cpanmetadb.plackperl.org/v1.0/package/$module";
  679. my $yaml = $self->get($uri);
  680. my $meta = $self->parse_meta_string($yaml);
  681. if ($meta && $meta->{distfile}) {
  682. return $self->cpan_module($module, $meta->{distfile}, $meta->{version});
  683. }
  684. $self->diag_fail("Finding $module on cpanmetadb failed.");
  685. return;
  686. }
  687. sub search_module {
  688. my($self, $module, $version) = @_;
  689. if ($self->{mirror_index}) {
  690. $self->chat("Searching $module on mirror index $self->{mirror_index} ...\n");
  691. my $pkg = $self->search_mirror_index_file($self->{mirror_index}, $module, $version);
  692. return $pkg if $pkg;
  693. unless ($self->{cascade_search}) {
  694. $self->diag_fail("Finding $module ($version) on mirror index $self->{mirror_index} failed.");
  695. return;
  696. }
  697. }
  698. unless ($self->{mirror_only}) {
  699. my $found = $self->search_database($module, $version);
  700. return $found if $found;
  701. }
  702. MIRROR: for my $mirror (@{ $self->{mirrors} }) {
  703. $self->chat("Searching $module on mirror $mirror ...\n");
  704. my $name = '02packages.details.txt.gz';
  705. my $uri = "$mirror/modules/$name";
  706. my $gz_file = $self->package_index_for($mirror) . '.gz';
  707. unless ($self->{pkgs}{$uri}) {
  708. $self->chat("Downloading index file $uri ...\n");
  709. $self->mirror($uri, $gz_file);
  710. $self->generate_mirror_index($mirror) or next MIRROR;
  711. $self->{pkgs}{$uri} = "!!retrieved!!";
  712. }
  713. my $pkg = $self->search_mirror_index($mirror, $module, $version);
  714. return $pkg if $pkg;
  715. $self->diag_fail("Finding $module ($version) on mirror $mirror failed.");
  716. }
  717. return;
  718. }
  719. sub source_for {
  720. my($self, $mirror) = @_;
  721. $mirror =~ s/[^\w\.\-]+/%/g;
  722. my $dir = "$self->{home}/sources/$mirror";
  723. File::Path::mkpath([ $dir ], 0, 0777);
  724. return $dir;
  725. }
  726. sub load_argv_from_fh {
  727. my($self, $fh) = @_;
  728. my @argv;
  729. while(defined(my $line = <$fh>)){
  730. chomp $line;
  731. $line =~ s/#.+$//; # comment
  732. $line =~ s/^\s+//; # trim spaces
  733. $line =~ s/\s+$//; # trim spaces
  734. push @argv, split ' ', $line if $line;
  735. }
  736. return @argv;
  737. }
  738. sub show_version {
  739. print "cpanm (App::cpanminus) version $VERSION\n";
  740. return 1;
  741. }
  742. sub show_help {
  743. my $self = shift;
  744. if ($_[0]) {
  745. die <<USAGE;
  746. Usage: cpanm [options] Module [...]
  747. Try `cpanm --help` or `man cpanm` for more options.
  748. USAGE
  749. }
  750. print <<HELP;
  751. Usage: cpanm [options] Module [...]
  752. Options:
  753. -v,--verbose Turns on chatty output
  754. -q,--quiet Turns off the most output
  755. --interactive Turns on interactive configure (required for Task:: modules)
  756. -f,--force force install
  757. -n,--notest Do not run unit tests
  758. --test-only Run tests only, do not install
  759. -S,--sudo sudo to run install commands
  760. --installdeps Only install dependencies
  761. --showdeps Only display direct dependencies
  762. --reinstall Reinstall the distribution even if you already have the latest version installed
  763. --mirror Specify the base URL for the mirror (e.g. http://cpan.cpantesters.org/)
  764. --mirror-only Use the mirror's index file instead of the CPAN Meta DB
  765. --prompt Prompt when configure/build/test fails
  766. -l,--local-lib Specify the install base to install modules
  767. -L,--local-lib-contained Specify the install base to install all non-core modules
  768. --auto-cleanup Number of days that cpanm's work directories expire in. Defaults to 7
  769. Commands:
  770. --self-upgrade upgrades itself
  771. --info Displays distribution info on CPAN
  772. --look Opens the distribution with your SHELL
  773. -V,--version Displays software version
  774. Examples:
  775. cpanm Test::More # install Test::More
  776. cpanm MIYAGAWA/Plack-0.99_05.tar.gz # full distribution path
  777. cpanm http://example.org/LDS/CGI.pm-3.20.tar.gz # install from URL
  778. cpanm ~/dists/MyCompany-Enterprise-1.00.tar.gz # install from a local file
  779. cpanm --interactive Task::Kensho # Configure interactively
  780. cpanm . # install from local directory
  781. cpanm --installdeps . # install all the deps for the current directory
  782. cpanm -L extlib Plack # install Plack and all non-core deps into extlib
  783. cpanm --mirror http://cpan.cpantesters.org/ DBI # use the fast-syncing mirror
  784. You can also specify the default options in PERL_CPANM_OPT environment variable in the shell rc:
  785. export PERL_CPANM_OPT="--prompt --reinstall -l ~/perl --mirror http://cpan.cpantesters.org"
  786. Type `man cpanm` or `perldoc cpanm` for the more detailed explanation of the options.
  787. HELP
  788. return 1;
  789. }
  790. sub _writable {
  791. my $dir = shift;
  792. my @dir = File::Spec->splitdir($dir);
  793. while (@dir) {
  794. $dir = File::Spec->catdir(@dir);
  795. if (-e $dir) {
  796. return -w _;
  797. }
  798. pop @dir;
  799. }
  800. return;
  801. }
  802. sub maybe_abs {
  803. my($self, $lib) = @_;
  804. if ($lib eq '_' or $lib =~ /^~/ or File::Spec->file_name_is_absolute($lib)) {
  805. return $lib;
  806. } else {
  807. return File::Spec->canonpath(File::Spec->catdir(Cwd::cwd(), $lib));
  808. }
  809. }
  810. sub bootstrap_local_lib {
  811. my $self = shift;
  812. # If -l is specified, use that.
  813. if ($self->{local_lib}) {
  814. return $self->setup_local_lib($self->{local_lib});
  815. }
  816. # root, locally-installed perl or --sudo: don't care about install_base
  817. return if $self->{sudo} or (_writable($Config{installsitelib}) and _writable($Config{installsitebin}));
  818. # local::lib is configured in the shell -- yay
  819. if ($ENV{PERL_MM_OPT} and ($ENV{MODULEBUILDRC} or $ENV{PERL_MB_OPT})) {
  820. $self->bootstrap_local_lib_deps;
  821. return;
  822. }
  823. $self->setup_local_lib;
  824. $self->diag(<<DIAG);
  825. !
  826. ! Can't write to $Config{installsitelib} and $Config{installsitebin}: Installing modules to $ENV{HOME}/perl5
  827. ! To turn off this warning, you have to do one of the following:
  828. ! - run me as a root or with --sudo option (to install to $Config{installsitelib} and $Config{installsitebin})
  829. ! - Configure local::lib your existing local::lib in this shell to set PERL_MM_OPT etc.
  830. ! - Install local::lib by running the following commands
  831. !
  832. ! cpanm --local-lib=~/perl5 local::lib && eval \$(perl -I ~/perl5/lib/perl5/ -Mlocal::lib)
  833. !
  834. DIAG
  835. sleep 2;
  836. }
  837. sub _core_only_inc {
  838. my($self, $base) = @_;
  839. require local::lib;
  840. (
  841. local::lib->resolve_path(local::lib->install_base_perl_path($base)),
  842. local::lib->resolve_path(local::lib->install_base_arch_path($base)),
  843. @Config{qw(privlibexp archlibexp)},
  844. );
  845. }
  846. sub _diff {
  847. my($self, $old, $new) = @_;
  848. my @diff;
  849. my %old = map { $_ => 1 } @$old;
  850. for my $n (@$new) {
  851. push @diff, $n unless exists $old{$n};
  852. }
  853. @diff;
  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. sub setup_local_lib {
  861. my($self, $base) = @_;
  862. $base = undef if $base eq '_';
  863. require local::lib;
  864. {
  865. local $0 = 'cpanm'; # so curl/wget | perl works
  866. $base ||= "~/perl5";
  867. if ($self->{self_contained}) {
  868. my @inc = $self->_core_only_inc($base);
  869. $self->{search_inc} = [ @inc ];
  870. } else {
  871. $self->{search_inc} = [
  872. local::lib->resolve_path(local::lib->install_base_arch_path($base)),
  873. local::lib->resolve_path(local::lib->install_base_perl_path($base)),
  874. @INC,
  875. ];
  876. }
  877. $self->_setup_local_lib_env($base);
  878. }
  879. $self->bootstrap_local_lib_deps;
  880. }
  881. sub bootstrap_local_lib_deps {
  882. my $self = shift;
  883. push @{$self->{bootstrap_deps}},
  884. 'ExtUtils::MakeMaker' => 6.31,
  885. 'ExtUtils::Install' => 1.46;
  886. }
  887. sub prompt_bool {
  888. my($self, $mess, $def) = @_;
  889. my $val = $self->prompt($mess, $def);
  890. return lc $val eq 'y';
  891. }
  892. sub prompt {
  893. my($self, $mess, $def) = @_;
  894. my $isa_tty = -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT)) ;
  895. my $dispdef = defined $def ? "[$def] " : " ";
  896. $def = defined $def ? $def : "";
  897. if (!$self->{prompt} || (!$isa_tty && eof STDIN)) {
  898. return $def;
  899. }
  900. local $|=1;
  901. local $\;
  902. my $ans;
  903. eval {
  904. local $SIG{ALRM} = sub { undef $ans; die "alarm\n" };
  905. print STDOUT "$mess $dispdef";
  906. alarm $self->{prompt_timeout} if $self->{prompt_timeout};
  907. $ans = <STDIN>;
  908. alarm 0;
  909. };
  910. if ( defined $ans ) {
  911. chomp $ans;
  912. } else { # user hit ctrl-D or alarm timeout
  913. print STDOUT "\n";
  914. }
  915. return (!defined $ans || $ans eq '') ? $def : $ans;
  916. }
  917. sub diag_ok {
  918. my($self, $msg) = @_;
  919. chomp $msg;
  920. $msg ||= "OK";
  921. if ($self->{in_progress}) {
  922. $self->_diag("$msg\n");
  923. $self->{in_progress} = 0;
  924. }
  925. $self->log("-> $msg\n");
  926. }
  927. sub diag_fail {
  928. my($self, $msg, $always) = @_;
  929. chomp $msg;
  930. if ($self->{in_progress}) {
  931. $self->_diag("FAIL\n");
  932. $self->{in_progress} = 0;
  933. }
  934. if ($msg) {
  935. $self->_diag("! $msg\n", $always);
  936. $self->log("-> FAIL $msg\n");
  937. }
  938. }
  939. sub diag_progress {
  940. my($self, $msg) = @_;
  941. chomp $msg;
  942. $self->{in_progress} = 1;
  943. $self->_diag("$msg ... ");
  944. $self->log("$msg\n");
  945. }
  946. sub _diag {
  947. my($self, $msg, $always) = @_;
  948. print STDERR $msg if $always or $self->{verbose} or !$self->{quiet};
  949. }
  950. sub diag {
  951. my($self, $msg, $always) = @_;
  952. $self->_diag($msg, $always);
  953. $self->log($msg);
  954. }
  955. sub chat {
  956. my $self = shift;
  957. print STDERR @_ if $self->{verbose};
  958. $self->log(@_);
  959. }
  960. sub log {
  961. my $self = shift;
  962. open my $out, ">>$self->{log}";
  963. print $out @_;
  964. }
  965. sub run {
  966. my($self, $cmd) = @_;
  967. if (WIN32 && ref $cmd eq 'ARRAY') {
  968. $cmd = join q{ }, map { $self->shell_quote($_) } @$cmd;
  969. }
  970. if (ref $cmd eq 'ARRAY') {
  971. my $pid = fork;
  972. if ($pid) {
  973. waitpid $pid, 0;
  974. return !$?;
  975. } else {
  976. $self->run_exec($cmd);
  977. }
  978. } else {
  979. unless ($self->{verbose}) {
  980. $cmd .= " >> " . $self->shell_quote($self->{log}) . " 2>&1";
  981. }
  982. !system $cmd;
  983. }
  984. }
  985. sub run_exec {
  986. my($self, $cmd) = @_;
  987. if (ref $cmd eq 'ARRAY') {
  988. unless ($self->{verbose}) {
  989. open my $logfh, ">>", $self->{log};
  990. open STDERR, '>&', $logfh;
  991. open STDOUT, '>&', $logfh;
  992. close $logfh;
  993. }
  994. exec @$cmd;
  995. } else {
  996. unless ($self->{verbose}) {
  997. $cmd .= " >> " . $self->shell_quote($self->{log}) . " 2>&1";
  998. }
  999. exec $cmd;
  1000. }
  1001. }
  1002. sub run_timeout {
  1003. my($self, $cmd, $timeout) = @_;
  1004. return $self->run($cmd) if WIN32 || $self->{verbose} || !$timeout;
  1005. my $pid = fork;
  1006. if ($pid) {
  1007. eval {
  1008. local $SIG{ALRM} = sub { die "alarm\n" };
  1009. alarm $timeout;
  1010. waitpid $pid, 0;
  1011. alarm 0;
  1012. };
  1013. if ($@ && $@ eq "alarm\n") {
  1014. $self->diag_fail("Timed out (> ${timeout}s). Use --verbose to retry.");
  1015. local $SIG{TERM} = 'IGNORE';
  1016. kill TERM => 0;
  1017. waitpid $pid, 0;
  1018. return;
  1019. }
  1020. return !$?;
  1021. } elsif ($pid == 0) {
  1022. $self->run_exec($cmd);
  1023. } else {
  1024. $self->chat("! fork failed: falling back to system()\n");
  1025. $self->run($cmd);
  1026. }
  1027. }
  1028. sub configure {
  1029. my($self, $cmd) = @_;
  1030. # trick AutoInstall
  1031. local $ENV{PERL5_CPAN_IS_RUNNING} = local $ENV{PERL5_CPANPLUS_IS_RUNNING} = $$;
  1032. # e.g. skip CPAN configuration on local::lib
  1033. local $ENV{PERL5_CPANM_IS_RUNNING} = $$;
  1034. my $use_default = !$self->{interactive};
  1035. local $ENV{PERL_MM_USE_DEFAULT} = $use_default;
  1036. # skip man page generation
  1037. local $ENV{PERL_MM_OPT} = $ENV{PERL_MM_OPT};
  1038. unless ($self->{pod2man}) {
  1039. $ENV{PERL_MM_OPT} .= " INSTALLMAN1DIR=none INSTALLMAN3DIR=none";
  1040. }
  1041. local $self->{verbose} = $self->{verbose} || $self->{interactive};
  1042. $self->run_timeout($cmd, $self->{configure_timeout});
  1043. }
  1044. sub build {
  1045. my($self, $cmd, $distname) = @_;
  1046. return 1 if $self->run_timeout($cmd, $self->{build_timeout});
  1047. while (1) {
  1048. my $ans = lc $self->prompt("Building $distname failed.\nYou can s)kip, r)etry, e)xamine build log, or l)ook ?", "s");
  1049. return if $ans eq 's';
  1050. return $self->build($cmd, $distname) if $ans eq 'r';
  1051. $self->show_build_log if $ans eq 'e';
  1052. $self->look if $ans eq 'l';
  1053. }
  1054. }
  1055. sub test {
  1056. my($self, $cmd, $distname) = @_;
  1057. return 1 if $self->{notest};
  1058. # https://rt.cpan.org/Ticket/Display.html?id=48965#txn-1013385
  1059. local $ENV{PERL_MM_USE_DEFAULT} = 1;
  1060. return 1 if $self->run_timeout($cmd, $self->{test_timeout});
  1061. if ($self->{force}) {
  1062. $self->diag_fail("Testing $distname failed but installing it anyway.");
  1063. return 1;
  1064. } else {
  1065. $self->diag_fail;
  1066. while (1) {
  1067. 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");
  1068. return if $ans eq 's';
  1069. return $self->test($cmd, $distname) if $ans eq 'r';
  1070. return 1 if $ans eq 'f';
  1071. $self->show_build_log if $ans eq 'e';
  1072. $self->look if $ans eq 'l';
  1073. }
  1074. }
  1075. }
  1076. sub install {
  1077. my($self, $cmd, $uninst_opts, $depth) = @_;
  1078. if ($depth == 0 && $self->{test_only}) {
  1079. return 1;
  1080. }
  1081. if ($self->{sudo}) {
  1082. unshift @$cmd, "sudo";
  1083. }
  1084. if ($self->{uninstall_shadows} && !$ENV{PERL_MM_OPT}) {
  1085. push @$cmd, @$uninst_opts;
  1086. }
  1087. $self->run($cmd);
  1088. }
  1089. sub look {
  1090. my $self = shift;
  1091. my $shell = $ENV{SHELL};
  1092. $shell ||= $ENV{COMSPEC} if WIN32;
  1093. if ($shell) {
  1094. my $cwd = Cwd::cwd;
  1095. $self->diag("Entering $cwd with $shell\n");
  1096. system $shell;
  1097. } else {
  1098. $self->diag_fail("You don't seem to have a SHELL :/");
  1099. }
  1100. }
  1101. sub show_build_log {
  1102. my $self = shift;
  1103. my @pagers = (
  1104. $ENV{PAGER},
  1105. (WIN32 ? () : ('less')),
  1106. 'more'
  1107. );
  1108. my $pager;
  1109. while (@pagers) {
  1110. $pager = shift @pagers;
  1111. next unless $pager;
  1112. $pager = $self->which($pager);
  1113. next unless $pager;
  1114. last;
  1115. }
  1116. if ($pager) {
  1117. # win32 'more' doesn't allow "more build.log", the < is required
  1118. system("$pager < $self->{log}");
  1119. }
  1120. else {
  1121. $self->diag_fail("You don't seem to have a PAGER :/");
  1122. }
  1123. }
  1124. sub chdir {
  1125. my $self = shift;
  1126. Cwd::chdir(File::Spec->canonpath($_[0])) or die "$_[0]: $!";
  1127. }
  1128. sub configure_mirrors {
  1129. my $self = shift;
  1130. unless (@{$self->{mirrors}}) {
  1131. $self->{mirrors} = [ 'http://www.cpan.org' ];
  1132. }
  1133. for (@{$self->{mirrors}}) {
  1134. s!^/!file:///!;
  1135. s!/$!!;
  1136. }
  1137. }
  1138. sub self_upgrade {
  1139. my $self = shift;
  1140. $self->{argv} = [ 'App::cpanminus' ];
  1141. return; # continue
  1142. }
  1143. sub install_module {
  1144. my($self, $module, $depth, $version) = @_;
  1145. if ($self->{seen}{$module}++) {
  1146. $self->chat("Already tried $module. Skipping.\n");
  1147. return 1;
  1148. }
  1149. my $dist = $self->resolve_name($module, $version);
  1150. unless ($dist) {
  1151. $self->diag_fail("Couldn't find module or a distribution $module ($version)", 1);
  1152. return;
  1153. }
  1154. if ($dist->{distvname} && $self->{seen}{$dist->{distvname}}++) {
  1155. $self->chat("Already tried $dist->{distvname}. Skipping.\n");
  1156. return 1;
  1157. }
  1158. if ($self->{cmd} eq 'info') {
  1159. print $self->format_dist($dist), "\n";
  1160. return 1;
  1161. }
  1162. $self->check_libs;
  1163. $self->setup_module_build_patch unless $self->{pod2man};
  1164. if ($dist->{module}) {
  1165. unless ($self->with_version_range($version)) {
  1166. my($ok, $local) = $self->check_module($dist->{module}, $dist->{module_version} || 0);
  1167. if ($self->{skip_installed} && $ok) {
  1168. $self->diag("$dist->{module} is up to date. ($local)\n", 1);
  1169. return 1;
  1170. }
  1171. }
  1172. unless ($self->satisfy_version($dist->{module}, $dist->{module_version}, $version)) {
  1173. $self->diag("Found $dist->{module} $dist->{module_version} which doesn't satisfy $version.\n");
  1174. return;
  1175. }
  1176. }
  1177. if ($dist->{dist} eq 'perl'){
  1178. $self->diag("skipping $dist->{pathname}\n");
  1179. return 1;
  1180. }
  1181. $self->diag("--> Working on $module\n");
  1182. $dist->{dir} ||= $self->fetch_module($dist);
  1183. unless ($dist->{dir}) {
  1184. $self->diag_fail("Failed to fetch distribution $dist->{distvname}", 1);
  1185. return;
  1186. }
  1187. $self->chat("Entering $dist->{dir}\n");
  1188. $self->chdir($self->{base});
  1189. $self->chdir($dist->{dir});
  1190. if ($self->{cmd} eq 'look') {
  1191. $self->look;
  1192. return 1;
  1193. }
  1194. return $self->build_stuff($module, $dist, $depth);
  1195. }
  1196. sub format_dist {
  1197. my($self, $dist) = @_;
  1198. # TODO support --dist-format?
  1199. return "$dist->{cpanid}/$dist->{filename}";
  1200. }
  1201. sub fetch_module {
  1202. my($self, $dist) = @_;
  1203. $self->chdir($self->{base});
  1204. for my $uri (@{$dist->{uris}}) {
  1205. $self->diag_progress("Fetching $uri");
  1206. # Ugh, $dist->{filename} can contain sub directory
  1207. my $filename = $dist->{filename} || $uri;
  1208. my $name = File::Basename::basename($filename);
  1209. my $cancelled;
  1210. my $fetch = sub {
  1211. my $file;
  1212. eval {
  1213. local $SIG{INT} = sub { $cancelled = 1; die "SIGINT\n" };
  1214. $self->mirror($uri, $name);
  1215. $file = $name if -e $name;
  1216. };
  1217. $self->chat("$@") if $@ && $@ ne "SIGINT\n";
  1218. return $file;
  1219. };
  1220. my($try, $file);
  1221. while ($try++ < 3) {
  1222. $file = $fetch->();
  1223. last if $cancelled or $file;
  1224. $self->diag_fail("Download $uri failed. Retrying ... ");
  1225. }
  1226. if ($cancelled) {
  1227. $self->diag_fail("Download cancelled.");
  1228. return;
  1229. }
  1230. unless ($file) {
  1231. $self->diag_fail("Failed to download $uri");
  1232. next;
  1233. }
  1234. $self->diag_ok;
  1235. $dist->{local_path} = File::Spec->rel2abs($name);
  1236. my $dir = $self->unpack($file, $uri, $dist);
  1237. next unless $dir; # unpack failed
  1238. if (my $save = $self->{save_dists}) {
  1239. my $path = "$save/authors/id/$dist->{pathname}";
  1240. $self->chat("Copying $name to $path\n");
  1241. File::Path::mkpath([ File::Basename::dirname($path) ], 0, 0777);
  1242. File::Copy::copy($file, $path) or warn $!;
  1243. }
  1244. return $dist, $dir;
  1245. }
  1246. }
  1247. sub unpack {
  1248. my($self, $file, $uri, $dist) = @_;
  1249. if ($self->{verify}) {
  1250. $self->verify_archive($file, $uri, $dist) or return;
  1251. }
  1252. $self->chat("Unpacking $file\n");
  1253. my $dir = $file =~ /\.zip/i ? $self->unzip($file) : $self->untar($file);
  1254. unless ($dir) {
  1255. $self->diag_fail("Failed to unpack $file: no directory");
  1256. }
  1257. return $dir;
  1258. }
  1259. sub verify_checksums_signature {
  1260. my($self, $chk_file) = @_;
  1261. require Module::Signature; # no fatpack
  1262. $self->chat("Verifying the signature of CHECKSUMS\n");
  1263. my $rv = eval {
  1264. local $SIG{__WARN__} = sub {}; # suppress warnings
  1265. my $v = Module::Signature::_verify($chk_file);
  1266. $v == Module::Signature::SIGNATURE_OK();
  1267. };
  1268. if ($rv) {
  1269. $self->chat("Verified OK!\n");
  1270. } else {
  1271. $self->diag_fail("Verifying CHECKSUMS signature failed: $rv\n");
  1272. return;
  1273. }
  1274. return 1;
  1275. }
  1276. sub verify_archive {
  1277. my($self, $file, $uri, $dist) = @_;
  1278. unless ($dist->{cpanid}) {
  1279. $self->chat("Archive '$file' does not seem to be from PAUSE. Skip verification.\n");
  1280. }
  1281. (my $mirror = $uri) =~ s!/authors/id.*$!!;
  1282. (my $chksum_uri = $uri) =~ s!/[^/]*$!/CHECKSUMS!;
  1283. my $chk_file = $self->source_for($mirror) . "/$dist->{cpanid}.CHECKSUMS";
  1284. $self->diag_progress("Fetching $chksum_uri");
  1285. $self->mirror($chksum_uri, $chk_file);
  1286. unless (-e $chk_file) {
  1287. $self->diag_fail("Fetching $chksum_uri failed.\n");
  1288. return;
  1289. }
  1290. $self->diag_ok;
  1291. $self->verify_checksums_signature($chk_file) or return;
  1292. $self->verify_checksum($file, $chk_file);
  1293. }
  1294. sub verify_checksum {
  1295. my($self, $file, $chk_file) = @_;
  1296. $self->chat("Verifying the SHA1 for $file\n");
  1297. open my $fh, "<$chk_file" or die "$chk_file: $!";
  1298. my $data = join '', <$fh>;
  1299. $data =~ s/\015?\012/\n/g;
  1300. require Safe; # no fatpack
  1301. my $chksum = Safe->new->reval($data);
  1302. if (!ref $chksum or ref $chksum ne 'HASH') {
  1303. $self->diag_fail("! Checksum file downloaded from $chk_file is broken.\n");
  1304. return;
  1305. }
  1306. if (my $sha = $chksum->{$file}{sha256}) {
  1307. my $hex = $self->sha1_for($file);
  1308. if ($hex eq $sha) {
  1309. $self->chat("Checksum for $file: Verified!\n");
  1310. } else {
  1311. $self->diag_fail("Checksum mismatch for $file\n");
  1312. return;
  1313. }
  1314. } else {
  1315. $self->chat("Checksum for $file not found in CHECKSUMS.\n");
  1316. return;
  1317. }
  1318. }
  1319. sub sha1_for {
  1320. my($self, $file) = @_;
  1321. require Digest::SHA; # no fatpack
  1322. open my $fh, "<", $file or die "$file: $!";
  1323. my $dg = Digest::SHA->new(256);
  1324. my($data);
  1325. while (read($fh, $data, 4096)) {
  1326. $dg->add($data);
  1327. }
  1328. return $dg->hexdigest;
  1329. }
  1330. sub verify_signature {
  1331. my($self, $dist) = @_;
  1332. $self->diag_progress("Verifying the SIGNATURE file");
  1333. my $out = `$self->{cpansign} -v --skip 2>&1`;
  1334. $self->log($out);
  1335. if ($out =~ /Signature verified OK/) {
  1336. $self->diag_ok("Verified OK");
  1337. return 1;
  1338. } else {
  1339. $self->diag_fail("SIGNATURE verificaion for $dist->{filename} failed\n");
  1340. return;
  1341. }
  1342. }
  1343. sub resolve_name {
  1344. my($self, $module, $version) = @_;
  1345. # URL
  1346. if ($module =~ /^(ftp|https?|file):/) {
  1347. if ($module =~ m!authors/id/(.*)!) {
  1348. return $self->cpan_dist($1, $module);
  1349. } else {
  1350. return { uris => [ $module ] };
  1351. }
  1352. }
  1353. # Directory
  1354. if ($module =~ m!^[\./]! && -d $module) {
  1355. return {
  1356. source => 'local',
  1357. dir => Cwd::abs_path($module),
  1358. };
  1359. }
  1360. # File
  1361. if (-f $module) {
  1362. return {
  1363. source => 'local',
  1364. uris => [ "file://" . Cwd::abs_path($module) ],
  1365. };
  1366. }
  1367. # Git
  1368. if ($module =~ /(^git:|\.git$)/) {
  1369. return $self->git_uri($module);
  1370. }
  1371. # cpan URI
  1372. if ($module =~ s!^cpan:///distfile/!!) {
  1373. return $self->cpan_dist($module);
  1374. }
  1375. # PAUSEID/foo
  1376. if ($module =~ m!([A-Z]{3,})/!) {
  1377. return $self->cpan_dist($module);
  1378. }
  1379. # Module name
  1380. return $self->search_module($module, $version);
  1381. }
  1382. sub cpan_module {
  1383. my($self, $module, $dist, $version) = @_;
  1384. my $dist = $self->cpan_dist($dist);
  1385. $dist->{module} = $module;
  1386. $dist->{module_version} = $version if $version && $version ne 'undef';
  1387. return $dist;
  1388. }
  1389. sub cpan_dist {
  1390. my($self, $dist, $url) = @_;
  1391. $dist =~ s!^([A-Z]{3})!substr($1,0,1)."/".substr($1,0,2)."/".$1!e;
  1392. require CPAN::DistnameInfo;
  1393. my $d = CPAN::DistnameInfo->new($dist);
  1394. if ($url) {
  1395. $url = [ $url ] unless ref $url eq 'ARRAY';
  1396. } else {
  1397. my $id = $d->cpanid;
  1398. my $fn = substr($id, 0, 1) . "/" . substr($id, 0, 2) . "/" . $id . "/" . $d->filename;
  1399. my @mirrors = @{$self->{mirrors}};
  1400. my @urls = map "$_/authors/id/$fn", @mirrors;
  1401. $url = \@urls,
  1402. }
  1403. return {
  1404. $d->properties,
  1405. source => 'cpan',
  1406. uris => $url,
  1407. };
  1408. }
  1409. sub git_uri {
  1410. my ($self, $uri) = @_;
  1411. # similar to http://www.pip-installer.org/en/latest/logic.html#vcs-support
  1412. # git URL has to end with .git when you need to use pin @ commit/tag/branch
  1413. ($uri, my $commitish) = split /(?<=\.git)@/i, $uri, 2;
  1414. my $dh = File::Temp->newdir(CLEANUP => 1);
  1415. my $dir = Cwd::abs_path($dh->dirname);
  1416. $self->diag_progress("Cloning $uri");
  1417. $self->run([ 'git', 'clone', $uri, $dir ]);
  1418. unless (-e "$dir/.git") {
  1419. $self->diag_fail("Failed cloning git repository $uri");
  1420. return;
  1421. }
  1422. if ($commitish) {
  1423. require File::pushd;
  1424. my $dir = File::pushd::pushd($dir);
  1425. unless ($self->run([ 'git', 'checkout', $commitish ])) {
  1426. $self->diag_fail("Failed to checkout '$commitish' in git repository $uri\n");
  1427. return;
  1428. }
  1429. }
  1430. $self->diag_ok;
  1431. return {
  1432. source => 'local',
  1433. dir => $dir,
  1434. handle => $dh,
  1435. };
  1436. }
  1437. sub setup_module_build_patch {
  1438. my $self = shift;
  1439. open my $out, ">$self->{base}/ModuleBuildSkipMan.pm" or die $!;
  1440. print $out <<EOF;
  1441. package ModuleBuildSkipMan;
  1442. CHECK {
  1443. if (%Module::Build::) {
  1444. no warnings 'redefine';
  1445. *Module::Build::Base::ACTION_manpages = sub {};
  1446. *Module::Build::Base::ACTION_docs = sub {};
  1447. }
  1448. }
  1449. 1;
  1450. EOF
  1451. }
  1452. sub check_module {
  1453. my($self, $mod, $want_ver) = @_;
  1454. require Module::Metadata;
  1455. my $meta = Module::Metadata->new_from_module($mod, inc => $self->{search_inc})
  1456. or return 0, undef;
  1457. my $version = $meta->version;
  1458. # When -L is in use, the version loaded from 'perl' library path
  1459. # might be newer than (or actually wasn't core at) the version
  1460. # that is shipped with the current perl
  1461. if ($self->{self_contained} && $self->loaded_from_perl_lib($meta)) {
  1462. require Module::CoreList; # no fatpack
  1463. unless (exists $Module::CoreList::version{$]+0}{$mod}) {
  1464. return 0, undef;
  1465. }
  1466. $version = $Module::CoreList::version{$]+0}{$mod};
  1467. }
  1468. $self->{local_versions}{$mod} = $version;
  1469. if ($self->is_deprecated($meta)){
  1470. return 0, $version;
  1471. } elsif ($self->satisfy_version($mod, $version, $want_ver)) {
  1472. return 1, ($version || 'undef');
  1473. } else {
  1474. return 0, $version;
  1475. }
  1476. }
  1477. sub satisfy_version {
  1478. my($self, $mod, $version, $want_ver) = @_;
  1479. $want_ver = '0' unless defined($want_ver) && length($want_ver);
  1480. require CPAN::Meta::Requirements;
  1481. my $requirements = CPAN::Meta::Requirements->new;
  1482. $requirements->add_string_requirement($mod, $want_ver);
  1483. $requirements->accepts_module($mod, $version);
  1484. }
  1485. sub unsatisfy_how {
  1486. my($self, $ver, $want_ver) = @_;
  1487. if ($want_ver =~ /^[v0-9\.\_]+$/) {
  1488. return "$ver < $want_ver";
  1489. } else {
  1490. return "$ver doesn't satisfy $want_ver";
  1491. }
  1492. }
  1493. sub is_deprecated {
  1494. my($self, $meta) = @_;
  1495. my $deprecated = eval {
  1496. require Module::CoreList; # no fatpack
  1497. Module::CoreList::is_deprecated($meta->{module});
  1498. };
  1499. return $deprecated && $self->loaded_from_perl_lib($meta);
  1500. }
  1501. sub loaded_from_perl_lib {
  1502. my($self, $meta) = @_;
  1503. require Config;
  1504. for my $dir (qw(archlibexp privlibexp)) {
  1505. my $confdir = $Config{$dir};
  1506. if ($confdir eq substr($meta->filename, 0, length($confdir))) {
  1507. return 1;
  1508. }
  1509. }
  1510. return;
  1511. }
  1512. sub should_install {
  1513. my($self, $mod, $ver) = @_;
  1514. $self->chat("Checking if you have $mod $ver ... ");
  1515. my($ok, $local) = $self->check_module($mod, $ver);
  1516. if ($ok) { $self->chat("Yes ($local)\n") }
  1517. elsif ($local) { $self->chat("No (" . $self->unsatisfy_how($local, $ver) . ")\n") }
  1518. else { $self->chat("No\n") }
  1519. return $mod unless $ok;
  1520. return;
  1521. }
  1522. sub install_deps {
  1523. my($self, $dir, $depth, @deps) = @_;
  1524. my(@install, %seen);
  1525. while (my($mod, $ver) = splice @deps, 0, 2) {
  1526. next if $seen{$mod} or $mod eq 'perl' or $mod eq 'Config';
  1527. if ($self->should_install($mod, $ver)) {
  1528. push @install, [ $mod, $ver ];
  1529. $seen{$mod} = 1;
  1530. }
  1531. }
  1532. if (@install) {
  1533. $self->diag("==> Found dependencies: " . join(", ", map $_->[0], @install) . "\n");
  1534. }
  1535. my @fail;
  1536. for my $mod (@install) {
  1537. $self->install_module($mod->[0], $depth + 1, $mod->[1])
  1538. or push @fail, $mod->[0];
  1539. }
  1540. $self->chdir($self->{base});
  1541. $self->chdir($dir) if $dir;
  1542. return @fail;
  1543. }
  1544. sub install_deps_bailout {
  1545. my($self, $target, $dir, $depth, @deps) = @_;
  1546. my @fail = $self->install_deps($dir, $depth, @deps);
  1547. if (@fail) {
  1548. unless ($self->prompt_bool("Installing the following dependencies failed:\n==> " .
  1549. join(", ", @fail) . "\nDo you want to continue building $target anyway?", "n")) {
  1550. $self->diag_fail("Bailing out the installation for $target. Retry with --prompt or --force.", 1);
  1551. return;
  1552. }
  1553. }
  1554. return 1;
  1555. }
  1556. sub build_stuff {
  1557. my($self, $stuff, $dist, $depth) = @_;
  1558. if ($self->{verify} && -e 'SIGNATURE') {
  1559. $self->verify_signature($dist) or return;
  1560. }
  1561. my @config_deps;
  1562. if (-e 'META.json') {
  1563. $self->chat("Checking configure dependencies from META.json\n");
  1564. $dist->{meta} = $self->parse_meta('META.json');
  1565. } elsif (-e 'META.yml') {
  1566. $self->chat("Checking configure dependencies from META.yml\n");
  1567. $dist->{meta} = $self->parse_meta('META.yml');
  1568. }
  1569. if (!$dist->{meta} && $dist->{source} eq 'cpan') {
  1570. $self->chat("META.yml/json not found or unparsable. Fetching META.yml from search.cpan.org\n");
  1571. $dist->{meta} = $self->fetch_meta_sco($dist);
  1572. }
  1573. $dist->{meta} ||= {};
  1574. if ( $dist->{meta}->{prereqs} ) {
  1575. push @config_deps, %{$dist->{meta}{prereqs}{configure}{requires} || {}};
  1576. }
  1577. else {
  1578. push @config_deps, %{$dist->{meta}{configure_requires} || {}};
  1579. }
  1580. my $target = $dist->{meta}{name} ? "$dist->{meta}{name}-$dist->{meta}{version}" : $dist->{dir};
  1581. $self->install_deps_bailout($target, $dist->{dir}, $depth, @config_deps)
  1582. or return;
  1583. $self->diag_progress("Configuring $target");
  1584. my $configure_state = $self->configure_this($dist, $depth);
  1585. $self->diag_ok($configure_state->{configured_ok} ? "OK" : "N/A");
  1586. my @deps = $self->find_prereqs($dist);
  1587. my $module_name = $self->find_module_name($configure_state) || $dist->{meta}{name};
  1588. $module_name =~ s/-/::/g;
  1589. if ($self->{showdeps}) {
  1590. my %rootdeps = (@config_deps, @deps); # merge
  1591. for my $mod (keys %rootdeps) {
  1592. my $ver = $rootdeps{$mod};
  1593. print $mod, ($ver ? "~$ver" : ""), "\n";
  1594. }
  1595. return 1;
  1596. }
  1597. my $distname = $dist->{meta}{name} ? "$dist->{meta}{name}-$dist->{meta}{version}" : $stuff;
  1598. my $walkup;
  1599. if ($self->{scandeps}) {
  1600. $walkup = $self->scandeps_append_child($dist);
  1601. }
  1602. $self->install_deps_bailout($distname, $dist->{dir}, $depth, @deps)
  1603. or return;
  1604. if ($self->{scandeps}) {
  1605. unless ($configure_state->{configured_ok}) {
  1606. my $diag = <<DIAG;
  1607. ! Configuring $distname failed. See $self->{log} for details.
  1608. ! You might have to install the following modules first to get --scandeps working correctly.
  1609. DIAG
  1610. if (@config_deps) {
  1611. my @tree = @{$self->{scandeps_tree}};
  1612. $diag .= "!\n" . join("", map "! * $_->[0]{module}\n", @tree[0..$#tree-1]) if @tree;
  1613. }
  1614. $self->diag("!\n$diag!\n", 1);
  1615. }
  1616. $walkup->();
  1617. return 1;
  1618. }
  1619. if ($self->{installdeps} && $depth == 0) {
  1620. if ($configure_state->{configured_ok}) {
  1621. $self->diag("<== Installed dependencies for $stuff. Finishing.\n");
  1622. return 1;
  1623. } else {
  1624. $self->diag("! Configuring $distname failed. See $self->{log} for details.\n", 1);
  1625. return;
  1626. }
  1627. }
  1628. my $installed;
  1629. if ($configure_state->{use_module_build} && -e 'Build' && -f _) {
  1630. my @switches = $self->{pod2man} ? () : ("-I$self->{base}", "-MModuleBuildSkipMan");
  1631. $self->diag_progress("Building " . ($self->{notest} ? "" : "and testing ") . $distname);
  1632. $self->build([ $self->{perl}, @switches, "./Build" ], $distname) &&
  1633. $self->test([ $self->{perl}, "./Build", "test" ], $distname) &&
  1634. $self->install([ $self->{perl}, @switches, "./Build", "install" ], [ "--uninst", 1 ], $depth) &&
  1635. $installed++;
  1636. } elsif ($self->{make} && -e 'Makefile') {
  1637. $self->diag_progress("Building " . ($self->{notest} ? "" : "and testing ") . $distname);
  1638. $self->build([ $self->{make} ], $distname) &&
  1639. $self->test([ $self->{make}, "test" ], $distname) &&
  1640. $self->install([ $self->{make}, "install" ], [ "UNINST=1" ], $depth) &&
  1641. $installed++;
  1642. } else {
  1643. my $why;
  1644. my $configure_failed = $configure_state->{configured} && !$configure_state->{configured_ok};
  1645. if ($configure_failed) { $why = "Configure failed for $distname." }
  1646. elsif ($self->{make}) { $why = "The distribution doesn't have a proper Makefile.PL/Build.PL" }
  1647. else { $why = "Can't configure the distribution. You probably need to have 'make'." }
  1648. $self->diag_fail("$why See $self->{log} for details.", 1);
  1649. return;
  1650. }
  1651. if ($installed && $self->{test_only}) {
  1652. $self->diag_ok;
  1653. $self->diag("Successfully tested $distname\n", 1);
  1654. } elsif ($installed) {
  1655. my $local = $self->{local_versions}{$dist->{module} || ''};
  1656. my $version = $dist->{module_version} || $dist->{meta}{version} || $dist->{version};
  1657. my $reinstall = $local && ($local eq $version);
  1658. my $how = $reinstall ? "reinstalled $distname"
  1659. : $local ? "installed $distname (upgraded from $local)"
  1660. : "installed $distname" ;
  1661. my $msg = "Successfully $how";
  1662. $self->diag_ok;
  1663. $self->diag("$msg\n", 1);
  1664. $self->{installed_dists}++;
  1665. $self->save_meta($stuff, $dist, $module_name, \@config_deps, \@deps);
  1666. return 1;
  1667. } else {
  1668. my $what = $self->{test_only} ? "Testing" : "Installing";
  1669. $self->diag_fail("$what $stuff failed. See $self->{log} for details.", 1);
  1670. return;
  1671. }
  1672. }
  1673. sub configure_this {
  1674. my($self, $dist, $depth) = @_;
  1675. if (-e 'cpanfile' && $self->{installdeps} && $depth == 0) {
  1676. require Module::CPANfile;
  1677. $dist->{cpanfile} = eval { Module::CPANfile->load('cpanfile') };
  1678. $self->diag_fail($@, 1) if $@;
  1679. return {
  1680. configured => 1,
  1681. configured_ok => !!$dist->{cpanfile},
  1682. use_module_build => 0,
  1683. };
  1684. }
  1685. if ($self->{skip_configure}) {
  1686. my $eumm = -e 'Makefile';
  1687. my $mb = -e 'Build' && -f _;
  1688. return {
  1689. configured => 1,
  1690. configured_ok => $eumm || $mb,
  1691. use_module_build => $mb,
  1692. };
  1693. }
  1694. my @mb_switches;
  1695. unless ($self->{pod2man}) {
  1696. # it has to be push, so Module::Build is loaded from the adjusted path when -L is in use
  1697. push @mb_switches, ("-I$self->{base}", "-MModuleBuildSkipMan");
  1698. }
  1699. my $state = {};
  1700. my $try_eumm = sub {
  1701. if (-e 'Makefile.PL') {
  1702. $self->chat("Running Makefile.PL\n");
  1703. # NOTE: according to Devel::CheckLib, most XS modules exit
  1704. # with 0 even if header files are missing, to avoid receiving
  1705. # tons of FAIL reports in such cases. So exit code can't be
  1706. # trusted if it went well.
  1707. if ($self->configure([ $self->{perl}, "Makefile.PL" ])) {
  1708. $state->{configured_ok} = -e 'Makefile';
  1709. }
  1710. $state->{configured}++;
  1711. }
  1712. };
  1713. my $try_mb = sub {
  1714. if (-e 'Build.PL') {
  1715. $self->chat("Running Build.PL\n");
  1716. if ($self->configure([ $self->{perl}, @mb_switches, "Build.PL" ])) {
  1717. $state->{configured_ok} = -e 'Build' && -f _;
  1718. }
  1719. $state->{use_module_build}++;
  1720. $state->{configured}++;
  1721. }
  1722. };
  1723. # Module::Build deps should use MakeMaker because that causes circular deps and fail
  1724. # Otherwise we should prefer Build.PL
  1725. my %should_use_mm = map { $_ => 1 } qw( version ExtUtils-ParseXS ExtUtils-Install ExtUtils-Manifest );
  1726. my @try;
  1727. if ($dist->{dist} && $should_use_mm{$dist->{dist}}) {
  1728. @try = ($try_eumm, $try_mb);
  1729. } else {
  1730. @try = ($try_mb, $try_eumm);
  1731. }
  1732. for my $try (@try) {
  1733. $try->();
  1734. last if $state->{configured_ok};
  1735. }
  1736. unless ($state->{configured_ok}) {
  1737. while (1) {
  1738. my $ans = lc $self->prompt("Configuring $dist->{dist} failed.\nYou can s)kip, r)etry, e)xamine build log, or l)ook ?", "s");
  1739. last if $ans eq 's';
  1740. return $self->configure_this($dist, $depth) if $ans eq 'r';
  1741. $self->show_build_log if $ans eq 'e';
  1742. $self->look if $ans eq 'l';
  1743. }
  1744. }
  1745. return $state;
  1746. }
  1747. sub find_module_name {
  1748. my($self, $state) = @_;
  1749. return unless $state->{configured_ok};
  1750. if ($state->{use_module_build} &&
  1751. -e "_build/build_params") {
  1752. my $params = do { open my $in, "_build/build_params"; $self->safe_eval(join "", <$in>) };
  1753. return eval { $params->[2]{module_name} } || undef;
  1754. } elsif (-e "Makefile") {
  1755. open my $mf, "Makefile";
  1756. while (<$mf>) {
  1757. if (/^\#\s+NAME\s+=>\s+(.*)/) {
  1758. return $self->safe_eval($1);
  1759. }
  1760. }
  1761. }
  1762. return;
  1763. }
  1764. sub save_meta {
  1765. my($self, $module, $dist, $module_name, $config_deps, $build_deps) = @_;
  1766. return unless $dist->{distvname} && $dist->{source} eq 'cpan';
  1767. my $base = ($ENV{PERL_MM_OPT} || '') =~ /INSTALL_BASE=/
  1768. ? ($self->install_base($ENV{PERL_MM_OPT}) . "/lib/perl5") : $Config{sitelibexp};
  1769. my $provides = $self->_merge_hashref(
  1770. map Module::Metadata->package_versions_from_directory($_),
  1771. qw( blib/lib blib/arch ) # FCGI.pm :(
  1772. );
  1773. File::Path::mkpath("blib/meta", 0, 0777);
  1774. my $local = {
  1775. name => $module_name,
  1776. target => $module,
  1777. version => $provides->{$module_name}{version} || $dist->{version},
  1778. dist => $dist->{distvname},
  1779. pathname => $dist->{pathname},
  1780. provides => $provides,
  1781. };
  1782. require JSON::PP;
  1783. open my $fh, ">", "blib/meta/install.json" or die $!;
  1784. print $fh JSON::PP::encode_json($local);
  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. my @cmd = (
  1790. ($self->{sudo} ? 'sudo' : ()),
  1791. $^X,
  1792. '-MExtUtils::Install=install',
  1793. '-e',
  1794. qq[install({ 'blib/meta' => '$base/$Config{archname}/.meta/$dist->{distvname}' })],
  1795. );
  1796. $self->run(\@cmd);
  1797. }
  1798. sub _merge_hashref {
  1799. my($self, @hashrefs) = @_;
  1800. my %hash;
  1801. for my $h (@hashrefs) {
  1802. %hash = (%hash, %$h);
  1803. }
  1804. return \%hash;
  1805. }
  1806. sub install_base {
  1807. my($self, $mm_opt) = @_;
  1808. $mm_opt =~ /INSTALL_BASE=(\S+)/ and return $1;
  1809. die "Your PERL_MM_OPT doesn't contain INSTALL_BASE";
  1810. }
  1811. sub safe_eval {
  1812. my($self, $code) = @_;
  1813. eval $code;
  1814. }
  1815. sub find_prereqs {
  1816. my($self, $dist) = @_;
  1817. my @deps = $self->extract_meta_prereqs($dist);
  1818. if ($dist->{module} =~ /^Bundle::/i) {
  1819. push @deps, $self->bundle_deps($dist);
  1820. }
  1821. return @deps;
  1822. }
  1823. sub extract_meta_prereqs {
  1824. my($self, $dist) = @_;
  1825. if ($dist->{cpanfile}) {
  1826. my $prereq = $dist->{cpanfile}->prereq;
  1827. my @phase = $self->{notest} ? qw( build runtime ) : qw( build test runtime );
  1828. require CPAN::Meta::Requirements;
  1829. my $req = CPAN::Meta::Requirements->new;
  1830. $req->add_requirements($prereq->requirements_for($_, 'requires')) for @phase;
  1831. return %{$req->as_string_hash};
  1832. }
  1833. my $meta = $dist->{meta};
  1834. my @deps;
  1835. if (-e "MYMETA.json") {
  1836. require JSON::PP;
  1837. $self->chat("Checking dependencies from MYMETA.json ...\n");
  1838. my $json = do { open my $in, "<MYMETA.json"; local $/; <$in> };
  1839. my $mymeta = JSON::PP::decode_json($json);
  1840. if ($mymeta) {
  1841. $meta->{$_} = $mymeta->{$_} for qw(name version);
  1842. return $self->extract_requires($mymeta);
  1843. }
  1844. }
  1845. if (-e 'MYMETA.yml') {
  1846. $self->chat("Checking dependencies from MYMETA.yml ...\n");
  1847. my $mymeta = $self->parse_meta('MYMETA.yml');
  1848. if ($mymeta) {
  1849. $meta->{$_} = $mymeta->{$_} for qw(name version);
  1850. return $self->extract_requires($mymeta);
  1851. }
  1852. }
  1853. if (-e '_build/prereqs') {
  1854. $self->chat("Checking dependencies from _build/prereqs ...\n");
  1855. my $mymeta = do { open my $in, "_build/prereqs"; $self->safe_eval(join "", <$in>) };
  1856. @deps = $self->extract_requires($mymeta);
  1857. } elsif (-e 'Makefile') {
  1858. $self->chat("Finding PREREQ from Makefile ...\n");
  1859. open my $mf, "Makefile";
  1860. while (<$mf>) {
  1861. if (/^\#\s+PREREQ_PM => \{\s*(.*?)\s*\}/) {
  1862. my @all;
  1863. my @pairs = split ', ', $1;
  1864. for (@pairs) {
  1865. my ($pkg, $v) = split '=>', $_;
  1866. push @all, [ $pkg, $v ];
  1867. }
  1868. my $list = join ", ", map { "'$_->[0]' => $_->[1]" } @all;
  1869. my $prereq = $self->safe_eval("no strict; +{ $list }");
  1870. push @deps, %$prereq if $prereq;
  1871. last;
  1872. }
  1873. }
  1874. }
  1875. return @deps;
  1876. }
  1877. sub bundle_deps {
  1878. my($self, $dist) = @_;
  1879. my @files;
  1880. File::Find::find({
  1881. wanted => sub { push @files, File::Spec->rel2abs($_) if /\.pm/i },
  1882. no_chdir => 1,
  1883. }, '.');
  1884. my @deps;
  1885. for my $file (@files) {
  1886. open my $pod, "<", $file or next;
  1887. my $in_contents;
  1888. while (<$pod>) {
  1889. if (/^=head\d\s+CONTENTS/) {
  1890. $in_contents = 1;
  1891. } elsif (/^=/) {
  1892. $in_contents = 0;
  1893. } elsif ($in_contents) {
  1894. /^(\S+)\s*(\S+)?/
  1895. and push @deps, $1, $self->maybe_version($2);
  1896. }
  1897. }
  1898. }
  1899. return @deps;
  1900. }
  1901. sub maybe_version {
  1902. my($self, $string) = @_;
  1903. return $string && $string =~ /^\.?\d/ ? $string : undef;
  1904. }
  1905. sub extract_requires {
  1906. my($self, $meta) = @_;
  1907. if ($meta->{'meta-spec'} && $meta->{'meta-spec'}{version} == 2) {
  1908. my @phase = $self->{notest} ? qw( build runtime ) : qw( build test runtime );
  1909. my @deps = map {
  1910. my $p = $meta->{prereqs}{$_} || {};
  1911. %{$p->{requires} || {}};
  1912. } @phase;
  1913. return @deps;
  1914. }
  1915. my @deps;
  1916. push @deps, %{$meta->{build_requires}} if $meta->{build_requires};
  1917. push @deps, %{$meta->{requires}} if $meta->{requires};
  1918. return @deps;
  1919. }
  1920. sub cleanup_workdirs {
  1921. my $self = shift;
  1922. my $expire = time - 24 * 60 * 60 * $self->{auto_cleanup};
  1923. my @targets;
  1924. opendir my $dh, "$self->{home}/work";
  1925. while (my $e = readdir $dh) {
  1926. next if $e !~ /^(\d+)\.\d+$/; # {UNIX time}.{PID}
  1927. my $time = $1;
  1928. if ($time < $expire) {
  1929. push @targets, "$self->{home}/work/$e";
  1930. }
  1931. }
  1932. if (@targets) {
  1933. $self->chat("Expiring ", scalar(@targets), " work directories.\n");
  1934. File::Path::rmtree(\@targets, 0, 0); # safe = 0, since blib usually doesn't have write bits
  1935. }
  1936. }
  1937. sub scandeps_append_child {
  1938. my($self, $dist) = @_;
  1939. my $new_node = [ $dist, [] ];
  1940. my $curr_node = $self->{scandeps_current} || [ undef, $self->{scandeps_tree} ];
  1941. push @{$curr_node->[1]}, $new_node;
  1942. $self->{scandeps_current} = $new_node;
  1943. return sub { $self->{scandeps_current} = $curr_node };
  1944. }
  1945. sub dump_scandeps {
  1946. my $self = shift;
  1947. if ($self->{format} eq 'tree') {
  1948. $self->walk_down(sub {
  1949. my($dist, $depth) = @_;
  1950. if ($depth == 0) {
  1951. print "$dist->{distvname}\n";
  1952. } else {
  1953. print " " x ($depth - 1);
  1954. print "\\_ $dist->{distvname}\n";
  1955. }
  1956. }, 1);
  1957. } elsif ($self->{format} =~ /^dists?$/) {
  1958. $self->walk_down(sub {
  1959. my($dist, $depth) = @_;
  1960. print $self->format_dist($dist), "\n";
  1961. }, 0);
  1962. } elsif ($self->{format} eq 'json') {
  1963. require JSON::PP;
  1964. print JSON::PP::encode_json($self->{scandeps_tree});
  1965. } elsif ($self->{format} eq 'yaml') {
  1966. require YAML; # no fatpack
  1967. print YAML::Dump($self->{scandeps_tree});
  1968. } else {
  1969. $self->diag("Unknown format: $self->{format}\n");
  1970. }
  1971. }
  1972. sub walk_down {
  1973. my($self, $cb, $pre) = @_;
  1974. $self->_do_walk_down($self->{scandeps_tree}, $cb, 0, $pre);
  1975. }
  1976. sub _do_walk_down {
  1977. my($self, $children, $cb, $depth, $pre) = @_;
  1978. # DFS - $pre determines when we call the callback
  1979. for my $node (@$children) {
  1980. $cb->($node->[0], $depth) if $pre;
  1981. $self->_do_walk_down($node->[1], $cb, $depth + 1, $pre);
  1982. $cb->($node->[0], $depth) unless $pre;
  1983. }
  1984. }
  1985. sub DESTROY {
  1986. my $self = shift;
  1987. $self->{at_exit}->($self) if $self->{at_exit};
  1988. }
  1989. # Utils
  1990. sub shell_quote {
  1991. my($self, $stuff) = @_;
  1992. $stuff =~ /^${quote}.+${quote}$/ ? $stuff : ($quote . $stuff . $quote);
  1993. }
  1994. sub which {
  1995. my($self, $name) = @_;
  1996. my $exe_ext = $Config{_exe};
  1997. for my $dir (File::Spec->path) {
  1998. my $fullpath = File::Spec->catfile($dir, $name);
  1999. if (-x $fullpath || -x ($fullpath .= $exe_ext)) {
  2000. if ($fullpath =~ /\s/ && $fullpath !~ /^$quote/) {
  2001. $fullpath = $self->shell_quote($fullpath);
  2002. }
  2003. return $fullpath;
  2004. }
  2005. }
  2006. return;
  2007. }
  2008. sub get {
  2009. my($self, $uri) = @_;
  2010. if ($uri =~ /^file:/) {
  2011. $self->file_get($uri);
  2012. } else {
  2013. $self->{_backends}{get}->(@_);
  2014. }
  2015. }
  2016. sub mirror {
  2017. my($self, $uri, $local) = @_;
  2018. if ($uri =~ /^file:/) {
  2019. $self->file_mirror($uri, $local);
  2020. } else {
  2021. $self->{_backends}{mirror}->(@_);
  2022. }
  2023. }
  2024. sub untar { $_[0]->{_backends}{untar}->(@_) };
  2025. sub unzip { $_[0]->{_backends}{unzip}->(@_) };
  2026. sub uri_to_file {
  2027. my($self, $uri) = @_;
  2028. # file:///path/to/file -> /path/to/file
  2029. # file://C:/path -> C:/path
  2030. if ($uri =~ s!file:/+!!) {
  2031. $uri = "/$uri" unless $uri =~ m![a-zA-Z]:!;
  2032. }
  2033. return $uri;
  2034. }
  2035. sub file_get {
  2036. my($self, $uri) = @_;
  2037. my $file = $self->uri_to_file($uri);
  2038. open my $fh, "<$file" or return;
  2039. join '', <$fh>;
  2040. }
  2041. sub file_mirror {
  2042. my($self, $uri, $path) = @_;
  2043. my $file = $self->uri_to_file($uri);
  2044. File::Copy::copy($file, $path);
  2045. }
  2046. sub init_tools {
  2047. my $self = shift;
  2048. return if $self->{initialized}++;
  2049. if ($self->{make} = $self->which($Config{make})) {
  2050. $self->chat("You have make $self->{make}\n");
  2051. }
  2052. # use --no-lwp if they have a broken LWP, to upgrade LWP
  2053. if ($self->{try_lwp} && eval { require LWP::UserAgent; LWP::UserAgent->VERSION(5.802) }) {
  2054. $self->chat("You have LWP $LWP::VERSION\n");
  2055. my $ua = sub {
  2056. LWP::UserAgent->new(
  2057. parse_head => 0,
  2058. env_proxy => 1,
  2059. agent => $self->agent,
  2060. timeout => 30,
  2061. @_,
  2062. );
  2063. };
  2064. $self->{_backends}{get} = sub {
  2065. my $self = shift;
  2066. my $res = $ua->()->request(HTTP::Request->new(GET => $_[0]));
  2067. return unless $res->is_success;
  2068. return $res->decoded_content;
  2069. };
  2070. $self->{_backends}{mirror} = sub {
  2071. my $self = shift;
  2072. my $res = $ua->()->mirror(@_);
  2073. $res->code;
  2074. };
  2075. } elsif ($self->{try_wget} and my $wget = $self->which('wget')) {
  2076. $self->chat("You have $wget\n");
  2077. my @common = (
  2078. '--user-agent', $self->agent,
  2079. '--retry-connrefused',
  2080. ($self->{verbose} ? () : ('-q')),
  2081. );
  2082. $self->{_backends}{get} = sub {
  2083. my($self, $uri) = @_;
  2084. $self->safeexec( my $fh, $wget, $uri, @common, '-O', '-' ) or die "wget $uri: $!";
  2085. local $/;
  2086. <$fh>;
  2087. };
  2088. $self->{_backends}{mirror} = sub {
  2089. my($self, $uri, $path) = @_;
  2090. $self->safeexec( my $fh, $wget, $uri, @common, '-O', $path ) or die "wget $uri: $!";
  2091. local $/;
  2092. <$fh>;
  2093. };
  2094. } elsif ($self->{try_curl} and my $curl = $self->which('curl')) {
  2095. $self->chat("You have $curl\n");
  2096. my @common = (
  2097. '--location',
  2098. '--user-agent', $self->agent,
  2099. ($self->{verbose} ? () : '-s'),
  2100. );
  2101. $self->{_backends}{get} = sub {
  2102. my($self, $uri) = @_;
  2103. $self->safeexec( my $fh, $curl, @common, $uri ) or die "curl $uri: $!";
  2104. local $/;
  2105. <$fh>;
  2106. };
  2107. $self->{_backends}{mirror} = sub {
  2108. my($self, $uri, $path) = @_;
  2109. $self->safeexec( my $fh, $curl, @common, $uri, '-#', '-o', $path ) or die "curl $uri: $!";
  2110. local $/;
  2111. <$fh>;
  2112. };
  2113. } else {
  2114. require HTTP::Tiny;
  2115. $self->chat("Falling back to HTTP::Tiny $HTTP::Tiny::VERSION\n");
  2116. my %common = (
  2117. agent => $self->agent,
  2118. );
  2119. $self->{_backends}{get} = sub {
  2120. my $self = shift;
  2121. my $res = HTTP::Tiny->new(%common)->get($_[0]);
  2122. return unless $res->{success};
  2123. return $res->{content};
  2124. };
  2125. $self->{_backends}{mirror} = sub {
  2126. my $self = shift;
  2127. my $res = HTTP::Tiny->new(%common)->mirror(@_);
  2128. return $res->{status};
  2129. };
  2130. }
  2131. my $tar = $self->which('tar');
  2132. my $tar_ver;
  2133. my $maybe_bad_tar = sub { WIN32 || SUNOS || (($tar_ver = `$tar --version 2>/dev/null`) =~ /GNU.*1\.13/i) };
  2134. if ($tar && !$maybe_bad_tar->()) {
  2135. chomp $tar_ver;
  2136. $self->chat("You have $tar: $tar_ver\n");
  2137. $self->{_backends}{untar} = sub {
  2138. my($self, $tarfile) = @_;
  2139. my $xf = ($self->{verbose} ? 'v' : '')."xf";
  2140. my $ar = $tarfile =~ /bz2$/ ? 'j' : 'z';
  2141. my($root, @others) = `$tar ${ar}tf $tarfile`
  2142. or return undef;
  2143. FILE: {
  2144. chomp $root;
  2145. $root =~ s!^\./!!;
  2146. $root =~ s{^(.+?)/.*$}{$1};
  2147. if (!length($root)) {
  2148. # archive had ./ as the first entry, so try again
  2149. $root = shift(@others);
  2150. redo FILE if $root;
  2151. }
  2152. }
  2153. system "$tar $ar$xf $tarfile";
  2154. return $root if -d $root;
  2155. $self->diag_fail("Bad archive: $tarfile");
  2156. return undef;
  2157. }
  2158. } elsif ( $tar
  2159. and my $gzip = $self->which('gzip')
  2160. and my $bzip2 = $self->which('bzip2')) {
  2161. $self->chat("You have $tar, $gzip and $bzip2\n");
  2162. $self->{_backends}{untar} = sub {
  2163. my($self, $tarfile) = @_;
  2164. my $x = "x" . ($self->{verbose} ? 'v' : '') . "f -";
  2165. my $ar = $tarfile =~ /bz2$/ ? $bzip2 : $gzip;
  2166. my($root, @others) = `$ar -dc $tarfile | $tar tf -`
  2167. or return undef;
  2168. FILE: {
  2169. chomp $root;
  2170. $root =~ s!^\./!!;
  2171. $root =~ s{^(.+?)/.*$}{$1};
  2172. if (!length($root)) {
  2173. # archive had ./ as the first entry, so try again
  2174. $root = shift(@others);
  2175. redo FILE if $root;
  2176. }
  2177. }
  2178. system "$ar -dc $tarfile | $tar $x";
  2179. return $root if -d $root;
  2180. $self->diag_fail("Bad archive: $tarfile");
  2181. return undef;
  2182. }
  2183. } elsif (eval { require Archive::Tar }) { # uses too much memory!
  2184. $self->chat("Falling back to Archive::Tar $Archive::Tar::VERSION\n");
  2185. $self->{_backends}{untar} = sub {
  2186. my $self = shift;
  2187. my $t = Archive::Tar->new($_[0]);
  2188. my($root, @others) = $t->list_files;
  2189. FILE: {
  2190. $root =~ s!^\./!!;
  2191. $root =~ s{^(.+?)/.*$}{$1};
  2192. if (!length($root)) {
  2193. # archive had ./ as the first entry, so try again
  2194. $root = shift(@others);
  2195. redo FILE if $root;
  2196. }
  2197. }
  2198. $t->extract;
  2199. return -d $root ? $root : undef;
  2200. };
  2201. } else {
  2202. $self->{_backends}{untar} = sub {
  2203. die "Failed to extract $_[1] - You need to have tar or Archive::Tar installed.\n";
  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. my $opt = $self->{verbose} ? '' : '-q';
  2211. my(undef, $root, @others) = `$unzip -t $zipfile`
  2212. or return undef;
  2213. chomp $root;
  2214. $root =~ s{^\s+testing:\s+([^/]+)/.*?\s+OK$}{$1};
  2215. system "$unzip $opt $zipfile";
  2216. return $root if -d $root;
  2217. $self->diag_fail("Bad archive: [$root] $zipfile");
  2218. return undef;
  2219. }
  2220. } else {
  2221. $self->{_backends}{unzip} = sub {
  2222. eval { require Archive::Zip }
  2223. or die "Failed to extract $_[1] - You need to have unzip or Archive::Zip installed.\n";
  2224. my($self, $file) = @_;
  2225. my $zip = Archive::Zip->new();
  2226. my $status;
  2227. $status = $zip->read($file);
  2228. $self->diag_fail("Read of file[$file] failed")
  2229. if $status != Archive::Zip::AZ_OK();
  2230. my @members = $zip->members();
  2231. for my $member ( @members ) {
  2232. my $af = $member->fileName();
  2233. next if ($af =~ m!^(/|\.\./)!);
  2234. $status = $member->extractToFileNamed( $af );
  2235. $self->diag_fail("Extracting of file[$af] from zipfile[$file failed")
  2236. if $status != Archive::Zip::AZ_OK();
  2237. }
  2238. my ($root) = $zip->membersMatching( qr<^[^/]+/$> );
  2239. $root &&= $root->fileName;
  2240. return -d $root ? $root : undef;
  2241. };
  2242. }
  2243. }
  2244. sub safeexec {
  2245. my $self = shift;
  2246. my $rdr = $_[0] ||= Symbol::gensym();
  2247. if (WIN32) {
  2248. my $cmd = join q{ }, map { $self->shell_quote($_) } @_[ 1 .. $#_ ];
  2249. return open( $rdr, "$cmd |" );
  2250. }
  2251. if ( my $pid = open( $rdr, '-|' ) ) {
  2252. return $pid;
  2253. }
  2254. elsif ( defined $pid ) {
  2255. exec( @_[ 1 .. $#_ ] );
  2256. exit 1;
  2257. }
  2258. else {
  2259. return;
  2260. }
  2261. }
  2262. sub parse_meta {
  2263. my($self, $file) = @_;
  2264. return eval { Parse::CPAN::Meta->load_file($file) };
  2265. }
  2266. sub parse_meta_string {
  2267. my($self, $yaml) = @_;
  2268. return eval { Parse::CPAN::Meta->load_yaml_string($yaml) };
  2269. }
  2270. 1;
  2271. APP_CPANMINUS_SCRIPT
  2272.  
  2273. $fatpacked{"CPAN/DistnameInfo.pm"} = <<'CPAN_DISTNAMEINFO';
  2274. package CPAN::DistnameInfo;
  2275. $VERSION = "0.12";
  2276. use strict;
  2277. sub distname_info {
  2278. my $file = shift or return;
  2279. my ($dist, $version) = $file =~ /^
  2280. ((?:[-+.]*(?:[A-Za-z0-9]+|(?<=\D)_|_(?=\D))*
  2281. (?:
  2282. [A-Za-z](?=[^A-Za-z]|$)
  2283. |
  2284. \d(?=-)
  2285. )(?<![._-][vV])
  2286. )+)(.*)
  2287. $/xs or return ($file,undef,undef);
  2288. if ($dist =~ /-undef\z/ and ! length $version) {
  2289. $dist =~ s/-undef\z//;
  2290. }
  2291. # Remove potential -withoutworldwriteables suffix
  2292. $version =~ s/-withoutworldwriteables$//;
  2293. if ($version =~ /^(-[Vv].*)-(\d.*)/) {
  2294. # Catch names like Unicode-Collate-Standard-V3_1_1-0.1
  2295. # where the V3_1_1 is part of the distname
  2296. $dist .= $1;
  2297. $version = $2;
  2298. }
  2299. if ($version =~ /(.+_.*)-(\d.*)/) {
  2300. # Catch names like Task-Deprecations5_14-1.00.tar.gz where the 5_14 is
  2301. # part of the distname. However, names like libao-perl_0.03-1.tar.gz
  2302. # should still have 0.03-1 as their version.
  2303. $dist .= $1;
  2304. $version = $2;
  2305. }
  2306. # Normalize the Dist.pm-1.23 convention which CGI.pm and
  2307. # a few others use.
  2308. $dist =~ s{\.pm$}{};
  2309. $version = $1
  2310. if !length $version and $dist =~ s/-(\d+\w)$//;
  2311. $version = $1 . $version
  2312. if $version =~ /^\d+$/ and $dist =~ s/-(\w+)$//;
  2313. if ($version =~ /\d\.\d/) {
  2314. $version =~ s/^[-_.]+//;
  2315. }
  2316. else {
  2317. $version =~ s/^[-_]+//;
  2318. }
  2319. my $dev;
  2320. if (length $version) {
  2321. if ($file =~ /^perl-?\d+\.(\d+)(?:\D(\d+))?(-(?:TRIAL|RC)\d+)?$/) {
  2322. $dev = 1 if (($1 > 6 and $1 & 1) or ($2 and $2 >= 50)) or $3;
  2323. }
  2324. elsif ($version =~ /\d\D\d+_\d/ or $version =~ /-TRIAL/) {
  2325. $dev = 1;
  2326. }
  2327. }
  2328. else {
  2329. $version = undef;
  2330. }
  2331. ($dist, $version, $dev);
  2332. }
  2333. sub new {
  2334. my $class = shift;
  2335. my $distfile = shift;
  2336. $distfile =~ s,//+,/,g;
  2337. my %info = ( pathname => $distfile );
  2338. ($info{filename} = $distfile) =~ s,^(((.*?/)?authors/)?id/)?([A-Z])/(\4[A-Z])/(\5[-A-Z0-9]*)/,,
  2339. and $info{cpanid} = $6;
  2340. if ($distfile =~ m,([^/]+)\.(tar\.(?:g?z|bz2)|zip|tgz)$,i) { # support more ?
  2341. $info{distvname} = $1;
  2342. $info{extension} = $2;
  2343. }
  2344. @info{qw(dist version beta)} = distname_info($info{distvname});
  2345. $info{maturity} = delete $info{beta} ? 'developer' : 'released';
  2346. return bless \%info, $class;
  2347. }
  2348. sub dist { shift->{dist} }
  2349. sub version { shift->{version} }
  2350. sub maturity { shift->{maturity} }
  2351. sub filename { shift->{filename} }
  2352. sub cpanid { shift->{cpanid} }
  2353. sub distvname { shift->{distvname} }
  2354. sub extension { shift->{extension} }
  2355. sub pathname { shift->{pathname} }
  2356. sub properties { %{ $_[0] } }
  2357. 1;
  2358. __END__
  2359. CPAN_DISTNAMEINFO
  2360.  
  2361. $fatpacked{"CPAN/Meta.pm"} = <<'CPAN_META';
  2362. use 5.006;
  2363. use strict;
  2364. use warnings;
  2365. package CPAN::Meta;
  2366. our $VERSION = '2.120921'; # VERSION
  2367. use Carp qw(carp croak);
  2368. use CPAN::Meta::Feature;
  2369. use CPAN::Meta::Prereqs;
  2370. use CPAN::Meta::Converter;
  2371. use CPAN::Meta::Validator;
  2372. use Parse::CPAN::Meta 1.4403 ();
  2373. BEGIN { *_dclone = \&CPAN::Meta::Converter::_dclone }
  2374. BEGIN {
  2375. my @STRING_READERS = qw(
  2376. abstract
  2377. description
  2378. dynamic_config
  2379. generated_by
  2380. name
  2381. release_status
  2382. version
  2383. );
  2384. no strict 'refs';
  2385. for my $attr (@STRING_READERS) {
  2386. *$attr = sub { $_[0]{ $attr } };
  2387. }
  2388. }
  2389. BEGIN {
  2390. my @LIST_READERS = qw(
  2391. author
  2392. keywords
  2393. license
  2394. );
  2395. no strict 'refs';
  2396. for my $attr (@LIST_READERS) {
  2397. *$attr = sub {
  2398. my $value = $_[0]{ $attr };
  2399. croak "$attr must be called in list context"
  2400. unless wantarray;
  2401. return @{ _dclone($value) } if ref $value;
  2402. return $value;
  2403. };
  2404. }
  2405. }
  2406. sub authors { $_[0]->author }
  2407. sub licenses { $_[0]->license }
  2408. BEGIN {
  2409. my @MAP_READERS = qw(
  2410. meta-spec
  2411. resources
  2412. provides
  2413. no_index
  2414. prereqs
  2415. optional_features
  2416. );
  2417. no strict 'refs';
  2418. for my $attr (@MAP_READERS) {
  2419. (my $subname = $attr) =~ s/-/_/;
  2420. *$subname = sub {
  2421. my $value = $_[0]{ $attr };
  2422. return _dclone($value) if $value;
  2423. return {};
  2424. };
  2425. }
  2426. }
  2427. sub custom_keys {
  2428. return grep { /^x_/i } keys %{$_[0]};
  2429. }
  2430. sub custom {
  2431. my ($self, $attr) = @_;
  2432. my $value = $self->{$attr};
  2433. return _dclone($value) if ref $value;
  2434. return $value;
  2435. }
  2436. sub _new {
  2437. my ($class, $struct, $options) = @_;
  2438. my $self;
  2439. if ( $options->{lazy_validation} ) {
  2440. # try to convert to a valid structure; if succeeds, then return it
  2441. my $cmc = CPAN::Meta::Converter->new( $struct );
  2442. $self = $cmc->convert( version => 2 ); # valid or dies
  2443. return bless $self, $class;
  2444. }
  2445. else {
  2446. # validate original struct
  2447. my $cmv = CPAN::Meta::Validator->new( $struct );
  2448. unless ( $cmv->is_valid) {
  2449. die "Invalid metadata structure. Errors: "
  2450. . join(", ", $cmv->errors) . "\n";
  2451. }
  2452. }
  2453. # up-convert older spec versions
  2454. my $version = $struct->{'meta-spec'}{version} || '1.0';
  2455. if ( $version == 2 ) {
  2456. $self = $struct;
  2457. }
  2458. else {
  2459. my $cmc = CPAN::Meta::Converter->new( $struct );
  2460. $self = $cmc->convert( version => 2 );
  2461. }
  2462. return bless $self, $class;
  2463. }
  2464. sub new {
  2465. my ($class, $struct, $options) = @_;
  2466. my $self = eval { $class->_new($struct, $options) };
  2467. croak($@) if $@;
  2468. return $self;
  2469. }
  2470. sub create {
  2471. my ($class, $struct, $options) = @_;
  2472. my $version = __PACKAGE__->VERSION || 2;
  2473. $struct->{generated_by} ||= __PACKAGE__ . " version $version" ;
  2474. $struct->{'meta-spec'}{version} ||= int($version);
  2475. my $self = eval { $class->_new($struct, $options) };
  2476. croak ($@) if $@;
  2477. return $self;
  2478. }
  2479. sub load_file {
  2480. my ($class, $file, $options) = @_;
  2481. $options->{lazy_validation} = 1 unless exists $options->{lazy_validation};
  2482. croak "load_file() requires a valid, readable filename"
  2483. unless -r $file;
  2484. my $self;
  2485. eval {
  2486. my $struct = Parse::CPAN::Meta->load_file( $file );
  2487. $self = $class->_new($struct, $options);
  2488. };
  2489. croak($@) if $@;
  2490. return $self;
  2491. }
  2492. sub load_yaml_string {
  2493. my ($class, $yaml, $options) = @_;
  2494. $options->{lazy_validation} = 1 unless exists $options->{lazy_validation};
  2495. my $self;
  2496. eval {
  2497. my ($struct) = Parse::CPAN::Meta->load_yaml_string( $yaml );
  2498. $self = $class->_new($struct, $options);
  2499. };
  2500. croak($@) if $@;
  2501. return $self;
  2502. }
  2503. sub load_json_string {
  2504. my ($class, $json, $options) = @_;
  2505. $options->{lazy_validation} = 1 unless exists $options->{lazy_validation};
  2506. my $self;
  2507. eval {
  2508. my $struct = Parse::CPAN::Meta->load_json_string( $json );
  2509. $self = $class->_new($struct, $options);
  2510. };
  2511. croak($@) if $@;
  2512. return $self;
  2513. }
  2514. sub save {
  2515. my ($self, $file, $options) = @_;
  2516. my $version = $options->{version} || '2';
  2517. my $layer = $] ge '5.008001' ? ':utf8' : '';
  2518. if ( $version ge '2' ) {
  2519. carp "'$file' should end in '.json'"
  2520. unless $file =~ m{\.json$};
  2521. }
  2522. else {
  2523. carp "'$file' should end in '.yml'"
  2524. unless $file =~ m{\.yml$};
  2525. }
  2526. my $data = $self->as_string( $options );
  2527. open my $fh, ">$layer", $file
  2528. or die "Error opening '$file' for writing: $!\n";
  2529. print {$fh} $data;
  2530. close $fh
  2531. or die "Error closing '$file': $!\n";
  2532. return 1;
  2533. }
  2534. sub meta_spec_version {
  2535. my ($self) = @_;
  2536. return $self->meta_spec->{version};
  2537. }
  2538. sub effective_prereqs {
  2539. my ($self, $features) = @_;
  2540. $features ||= [];
  2541. my $prereq = CPAN::Meta::Prereqs->new($self->prereqs);
  2542. return $prereq unless @$features;
  2543. my @other = map {; $self->feature($_)->prereqs } @$features;
  2544. return $prereq->with_merged_prereqs(\@other);
  2545. }
  2546. sub should_index_file {
  2547. my ($self, $filename) = @_;
  2548. for my $no_index_file (@{ $self->no_index->{file} || [] }) {
  2549. return if $filename eq $no_index_file;
  2550. }
  2551. for my $no_index_dir (@{ $self->no_index->{directory} }) {
  2552. $no_index_dir =~ s{$}{/} unless $no_index_dir =~ m{/\z};
  2553. return if index($filename, $no_index_dir) == 0;
  2554. }
  2555. return 1;
  2556. }
  2557. sub should_index_package {
  2558. my ($self, $package) = @_;
  2559. for my $no_index_pkg (@{ $self->no_index->{package} || [] }) {
  2560. return if $package eq $no_index_pkg;
  2561. }
  2562. for my $no_index_ns (@{ $self->no_index->{namespace} }) {
  2563. return if index($package, "${no_index_ns}::") == 0;
  2564. }
  2565. return 1;
  2566. }
  2567. sub features {
  2568. my ($self) = @_;
  2569. my $opt_f = $self->optional_features;
  2570. my @features = map {; CPAN::Meta::Feature->new($_ => $opt_f->{ $_ }) }
  2571. keys %$opt_f;
  2572. return @features;
  2573. }
  2574. sub feature {
  2575. my ($self, $ident) = @_;
  2576. croak "no feature named $ident"
  2577. unless my $f = $self->optional_features->{ $ident };
  2578. return CPAN::Meta::Feature->new($ident, $f);
  2579. }
  2580. sub as_struct {
  2581. my ($self, $options) = @_;
  2582. my $struct = _dclone($self);
  2583. if ( $options->{version} ) {
  2584. my $cmc = CPAN::Meta::Converter->new( $struct );
  2585. $struct = $cmc->convert( version => $options->{version} );
  2586. }
  2587. return $struct;
  2588. }
  2589. sub as_string {
  2590. my ($self, $options) = @_;
  2591. my $version = $options->{version} || '2';
  2592. my $struct;
  2593. if ( $self->meta_spec_version ne $version ) {
  2594. my $cmc = CPAN::Meta::Converter->new( $self->as_struct );
  2595. $struct = $cmc->convert( version => $version );
  2596. }
  2597. else {
  2598. $struct = $self->as_struct;
  2599. }
  2600. my ($data, $backend);
  2601. if ( $version ge '2' ) {
  2602. $backend = Parse::CPAN::Meta->json_backend();
  2603. $data = $backend->new->pretty->canonical->encode($struct);
  2604. }
  2605. else {
  2606. $backend = Parse::CPAN::Meta->yaml_backend();
  2607. $data = eval { no strict 'refs'; &{"$backend\::Dump"}($struct) };
  2608. if ( $@ ) {
  2609. croak $backend->can('errstr') ? $backend->errstr : $@
  2610. }
  2611. }
  2612. return $data;
  2613. }
  2614. # Used by JSON::PP, etc. for "convert_blessed"
  2615. sub TO_JSON {
  2616. return { %{ $_[0] } };
  2617. }
  2618. 1;
  2619. # ABSTRACT: the distribution metadata for a CPAN dist
  2620. __END__
  2621. CPAN_META
  2622.  
  2623. $fatpacked{"CPAN/Meta/Converter.pm"} = <<'CPAN_META_CONVERTER';
  2624. use 5.006;
  2625. use strict;
  2626. use warnings;
  2627. package CPAN::Meta::Converter;
  2628. our $VERSION = '2.120921'; # VERSION
  2629. use CPAN::Meta::Validator;
  2630. use CPAN::Meta::Requirements;
  2631. use version 0.88 ();
  2632. use Parse::CPAN::Meta 1.4400 ();
  2633. sub _dclone {
  2634. my $ref = shift;
  2635. # if an object is in the data structure and doesn't specify how to
  2636. # turn itself into JSON, we just stringify the object. That does the
  2637. # right thing for typical things that might be there, like version objects,
  2638. # Path::Class objects, etc.
  2639. no warnings 'once';
  2640. local *UNIVERSAL::TO_JSON = sub { return "$_[0]" };
  2641. my $backend = Parse::CPAN::Meta->json_backend();
  2642. return $backend->new->utf8->decode(
  2643. $backend->new->utf8->allow_blessed->convert_blessed->encode($ref)
  2644. );
  2645. }
  2646. my %known_specs = (
  2647. '2' => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec',
  2648. '1.4' => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
  2649. '1.3' => 'http://module-build.sourceforge.net/META-spec-v1.3.html',
  2650. '1.2' => 'http://module-build.sourceforge.net/META-spec-v1.2.html',
  2651. '1.1' => 'http://module-build.sourceforge.net/META-spec-v1.1.html',
  2652. '1.0' => 'http://module-build.sourceforge.net/META-spec-v1.0.html'
  2653. );
  2654. my @spec_list = sort { $a <=> $b } keys %known_specs;
  2655. my ($LOWEST, $HIGHEST) = @spec_list[0,-1];
  2656. #--------------------------------------------------------------------------#
  2657. # converters
  2658. #
  2659. # called as $converter->($element, $field_name, $full_meta, $to_version)
  2660. #
  2661. # defined return value used for field
  2662. # undef return value means field is skipped
  2663. #--------------------------------------------------------------------------#
  2664. sub _keep { $_[0] }
  2665. sub _keep_or_one { defined($_[0]) ? $_[0] : 1 }
  2666. sub _keep_or_zero { defined($_[0]) ? $_[0] : 0 }
  2667. sub _keep_or_unknown { defined($_[0]) && length($_[0]) ? $_[0] : "unknown" }
  2668. sub _generated_by {
  2669. my $gen = shift;
  2670. my $sig = __PACKAGE__ . " version " . (__PACKAGE__->VERSION || "<dev>");
  2671. return $sig unless defined $gen and length $gen;
  2672. return $gen if $gen =~ /(, )\Q$sig/;
  2673. return "$gen, $sig";
  2674. }
  2675. sub _listify { ! defined $_[0] ? undef : ref $_[0] eq 'ARRAY' ? $_[0] : [$_[0]] }
  2676. sub _prefix_custom {
  2677. my $key = shift;
  2678. $key =~ s/^(?!x_) # Unless it already starts with x_
  2679. (?:x-?)? # Remove leading x- or x (if present)
  2680. /x_/ix; # and prepend x_
  2681. return $key;
  2682. }
  2683. sub _ucfirst_custom {
  2684. my $key = shift;
  2685. $key = ucfirst $key unless $key =~ /[A-Z]/;
  2686. return $key;
  2687. }
  2688. sub _change_meta_spec {
  2689. my ($element, undef, undef, $version) = @_;
  2690. $element->{version} = $version;
  2691. $element->{url} = $known_specs{$version};
  2692. return $element;
  2693. }
  2694. my @valid_licenses_1 = (
  2695. 'perl',
  2696. 'gpl',
  2697. 'apache',
  2698. 'artistic',
  2699. 'artistic_2',
  2700. 'lgpl',
  2701. 'bsd',
  2702. 'gpl',
  2703. 'mit',
  2704. 'mozilla',
  2705. 'open_source',
  2706. 'unrestricted',
  2707. 'restrictive',
  2708. 'unknown',
  2709. );
  2710. my %license_map_1 = (
  2711. ( map { $_ => $_ } @valid_licenses_1 ),
  2712. artistic2 => 'artistic_2',
  2713. );
  2714. sub _license_1 {
  2715. my ($element) = @_;
  2716. return 'unknown' unless defined $element;
  2717. if ( $license_map_1{lc $element} ) {
  2718. return $license_map_1{lc $element};
  2719. }
  2720. return 'unknown';
  2721. }
  2722. my @valid_licenses_2 = qw(
  2723. agpl_3
  2724. apache_1_1
  2725. apache_2_0
  2726. artistic_1
  2727. artistic_2
  2728. bsd
  2729. freebsd
  2730. gfdl_1_2
  2731. gfdl_1_3
  2732. gpl_1
  2733. gpl_2
  2734. gpl_3
  2735. lgpl_2_1
  2736. lgpl_3_0
  2737. mit
  2738. mozilla_1_0
  2739. mozilla_1_1
  2740. openssl
  2741. perl_5
  2742. qpl_1_0
  2743. ssleay
  2744. sun
  2745. zlib
  2746. open_source
  2747. restricted
  2748. unrestricted
  2749. unknown
  2750. );
  2751. # The "old" values were defined by Module::Build, and were often vague. I have
  2752. # made the decisions below based on reading Module::Build::API and how clearly
  2753. # it specifies the version of the license.
  2754. my %license_map_2 = (
  2755. (map { $_ => $_ } @valid_licenses_2),
  2756. apache => 'apache_2_0', # clearly stated as 2.0
  2757. artistic => 'artistic_1', # clearly stated as 1
  2758. artistic2 => 'artistic_2', # clearly stated as 2
  2759. gpl => 'open_source', # we don't know which GPL; punt
  2760. lgpl => 'open_source', # we don't know which LGPL; punt
  2761. mozilla => 'open_source', # we don't know which MPL; punt
  2762. perl => 'perl_5', # clearly Perl 5
  2763. restrictive => 'restricted',
  2764. );
  2765. sub _license_2 {
  2766. my ($element) = @_;
  2767. return [ 'unknown' ] unless defined $element;
  2768. $element = [ $element ] unless ref $element eq 'ARRAY';
  2769. my @new_list;
  2770. for my $lic ( @$element ) {
  2771. next unless defined $lic;
  2772. if ( my $new = $license_map_2{lc $lic} ) {
  2773. push @new_list, $new;
  2774. }
  2775. }
  2776. return @new_list ? \@new_list : [ 'unknown' ];
  2777. }
  2778. my %license_downgrade_map = qw(
  2779. agpl_3 open_source
  2780. apache_1_1 apache
  2781. apache_2_0 apache
  2782. artistic_1 artistic
  2783. artistic_2 artistic_2
  2784. bsd bsd
  2785. freebsd open_source
  2786. gfdl_1_2 open_source
  2787. gfdl_1_3 open_source
  2788. gpl_1 gpl
  2789. gpl_2 gpl
  2790. gpl_3 gpl
  2791. lgpl_2_1 lgpl
  2792. lgpl_3_0 lgpl
  2793. mit mit
  2794. mozilla_1_0 mozilla
  2795. mozilla_1_1 mozilla
  2796. openssl open_source
  2797. perl_5 perl
  2798. qpl_1_0 open_source
  2799. ssleay open_source
  2800. sun open_source
  2801. zlib open_source
  2802. open_source open_source
  2803. restricted restrictive
  2804. unrestricted unrestricted
  2805. unknown unknown
  2806. );
  2807. sub _downgrade_license {
  2808. my ($element) = @_;
  2809. if ( ! defined $element ) {
  2810. return "unknown";
  2811. }
  2812. elsif( ref $element eq 'ARRAY' ) {
  2813. if ( @$element == 1 ) {
  2814. return $license_downgrade_map{$element->[0]} || "unknown";
  2815. }
  2816. }
  2817. elsif ( ! ref $element ) {
  2818. return $license_downgrade_map{$element} || "unknown";
  2819. }
  2820. return "unknown";
  2821. }
  2822. my $no_index_spec_1_2 = {
  2823. 'file' => \&_listify,
  2824. 'dir' => \&_listify,
  2825. 'package' => \&_listify,
  2826. 'namespace' => \&_listify,
  2827. };
  2828. my $no_index_spec_1_3 = {
  2829. 'file' => \&_listify,
  2830. 'directory' => \&_listify,
  2831. 'package' => \&_listify,
  2832. 'namespace' => \&_listify,
  2833. };
  2834. my $no_index_spec_2 = {
  2835. 'file' => \&_listify,
  2836. 'directory' => \&_listify,
  2837. 'package' => \&_listify,
  2838. 'namespace' => \&_listify,
  2839. ':custom' => \&_prefix_custom,
  2840. };
  2841. sub _no_index_1_2 {
  2842. my (undef, undef, $meta) = @_;
  2843. my $no_index = $meta->{no_index} || $meta->{private};
  2844. return unless $no_index;
  2845. # cleanup wrong format
  2846. if ( ! ref $no_index ) {
  2847. my $item = $no_index;
  2848. $no_index = { dir => [ $item ], file => [ $item ] };
  2849. }
  2850. elsif ( ref $no_index eq 'ARRAY' ) {
  2851. my $list = $no_index;
  2852. $no_index = { dir => [ @$list ], file => [ @$list ] };
  2853. }
  2854. # common mistake: files -> file
  2855. if ( exists $no_index->{files} ) {
  2856. $no_index->{file} = delete $no_index->{file};
  2857. }
  2858. # common mistake: modules -> module
  2859. if ( exists $no_index->{modules} ) {
  2860. $no_index->{module} = delete $no_index->{module};
  2861. }
  2862. return _convert($no_index, $no_index_spec_1_2);
  2863. }
  2864. sub _no_index_directory {
  2865. my ($element, $key, $meta, $version) = @_;
  2866. return unless $element;
  2867. # cleanup wrong format
  2868. if ( ! ref $element ) {
  2869. my $item = $element;
  2870. $element = { directory => [ $item ], file => [ $item ] };
  2871. }
  2872. elsif ( ref $element eq 'ARRAY' ) {
  2873. my $list = $element;
  2874. $element = { directory => [ @$list ], file => [ @$list ] };
  2875. }
  2876. if ( exists $element->{dir} ) {
  2877. $element->{directory} = delete $element->{dir};
  2878. }
  2879. # common mistake: files -> file
  2880. if ( exists $element->{files} ) {
  2881. $element->{file} = delete $element->{file};
  2882. }
  2883. # common mistake: modules -> module
  2884. if ( exists $element->{modules} ) {
  2885. $element->{module} = delete $element->{module};
  2886. }
  2887. my $spec = $version == 2 ? $no_index_spec_2 : $no_index_spec_1_3;
  2888. return _convert($element, $spec);
  2889. }
  2890. sub _is_module_name {
  2891. my $mod = shift;
  2892. return unless defined $mod && length $mod;
  2893. return $mod =~ m{^[A-Za-z][A-Za-z0-9_]*(?:::[A-Za-z0-9_]+)*$};
  2894. }
  2895. sub _clean_version {
  2896. my ($element, $key, $meta, $to_version) = @_;
  2897. return 0 if ! defined $element;
  2898. $element =~ s{^\s*}{};
  2899. $element =~ s{\s*$}{};
  2900. $element =~ s{^\.}{0.};
  2901. return 0 if ! length $element;
  2902. return 0 if ( $element eq 'undef' || $element eq '<undef>' );
  2903. my $v = eval { version->new($element) };
  2904. # XXX check defined $v and not just $v because version objects leak memory
  2905. # in boolean context -- dagolden, 2012-02-03
  2906. if ( defined $v ) {
  2907. return $v->is_qv ? $v->normal : $element;
  2908. }
  2909. else {
  2910. return 0;
  2911. }
  2912. }
  2913. sub _bad_version_hook {
  2914. my ($v) = @_;
  2915. $v =~ s{[a-z]+$}{}; # strip trailing alphabetics
  2916. my $vobj = eval { version->parse($v) };
  2917. return defined($vobj) ? $vobj : version->parse(0); # or give up
  2918. }
  2919. sub _version_map {
  2920. my ($element) = @_;
  2921. return unless defined $element;
  2922. if ( ref $element eq 'HASH' ) {
  2923. # XXX turn this into CPAN::Meta::Requirements with bad version hook
  2924. # and then turn it back into a hash
  2925. my $new_map = CPAN::Meta::Requirements->new(
  2926. { bad_version_hook => sub { version->new(0) } } # punt
  2927. );
  2928. while ( my ($k,$v) = each %$element ) {
  2929. next unless _is_module_name($k);
  2930. if ( !defined($v) || !length($v) || $v eq 'undef' || $v eq '<undef>' ) {
  2931. $v = 0;
  2932. }
  2933. # some weird, old META have bad yml with module => module
  2934. # so check if value is like a module name and not like a version
  2935. if ( _is_module_name($v) && ! version::is_lax($v) ) {
  2936. $new_map->add_minimum($k => 0);
  2937. $new_map->add_minimum($v => 0);
  2938. }
  2939. $new_map->add_string_requirement($k => $v);
  2940. }
  2941. return $new_map->as_string_hash;
  2942. }
  2943. elsif ( ref $element eq 'ARRAY' ) {
  2944. my $hashref = { map { $_ => 0 } @$element };
  2945. return _version_map($hashref); # cleanup any weird stuff
  2946. }
  2947. elsif ( ref $element eq '' && length $element ) {
  2948. return { $element => 0 }
  2949. }
  2950. return;
  2951. }
  2952. sub _prereqs_from_1 {
  2953. my (undef, undef, $meta) = @_;
  2954. my $prereqs = {};
  2955. for my $phase ( qw/build configure/ ) {
  2956. my $key = "${phase}_requires";
  2957. $prereqs->{$phase}{requires} = _version_map($meta->{$key})
  2958. if $meta->{$key};
  2959. }
  2960. for my $rel ( qw/requires recommends conflicts/ ) {
  2961. $prereqs->{runtime}{$rel} = _version_map($meta->{$rel})
  2962. if $meta->{$rel};
  2963. }
  2964. return $prereqs;
  2965. }
  2966. my $prereqs_spec = {
  2967. configure => \&_prereqs_rel,
  2968. build => \&_prereqs_rel,
  2969. test => \&_prereqs_rel,
  2970. runtime => \&_prereqs_rel,
  2971. develop => \&_prereqs_rel,
  2972. ':custom' => \&_prefix_custom,
  2973. };
  2974. my $relation_spec = {
  2975. requires => \&_version_map,
  2976. recommends => \&_version_map,
  2977. suggests => \&_version_map,
  2978. conflicts => \&_version_map,
  2979. ':custom' => \&_prefix_custom,
  2980. };
  2981. sub _cleanup_prereqs {
  2982. my ($prereqs, $key, $meta, $to_version) = @_;
  2983. return unless $prereqs && ref $prereqs eq 'HASH';
  2984. return _convert( $prereqs, $prereqs_spec, $to_version );
  2985. }
  2986. sub _prereqs_rel {
  2987. my ($relation, $key, $meta, $to_version) = @_;
  2988. return unless $relation && ref $relation eq 'HASH';
  2989. return _convert( $relation, $relation_spec, $to_version );
  2990. }
  2991. BEGIN {
  2992. my @old_prereqs = qw(
  2993. requires
  2994. configure_requires
  2995. recommends
  2996. conflicts
  2997. );
  2998. for ( @old_prereqs ) {
  2999. my $sub = "_get_$_";
  3000. my ($phase,$type) = split qr/_/, $_;
  3001. if ( ! defined $type ) {
  3002. $type = $phase;
  3003. $phase = 'runtime';
  3004. }
  3005. no strict 'refs';
  3006. *{$sub} = sub { _extract_prereqs($_[2]->{prereqs},$phase,$type) };
  3007. }
  3008. }
  3009. sub _get_build_requires {
  3010. my ($data, $key, $meta) = @_;
  3011. my $test_h = _extract_prereqs($_[2]->{prereqs}, qw(test requires)) || {};
  3012. my $build_h = _extract_prereqs($_[2]->{prereqs}, qw(build requires)) || {};
  3013. my $test_req = CPAN::Meta::Requirements->from_string_hash($test_h);
  3014. my $build_req = CPAN::Meta::Requirements->from_string_hash($build_h);
  3015. $test_req->add_requirements($build_req)->as_string_hash;
  3016. }
  3017. sub _extract_prereqs {
  3018. my ($prereqs, $phase, $type) = @_;
  3019. return unless ref $prereqs eq 'HASH';
  3020. return scalar _version_map($prereqs->{$phase}{$type});
  3021. }
  3022. sub _downgrade_optional_features {
  3023. my (undef, undef, $meta) = @_;
  3024. return unless exists $meta->{optional_features};
  3025. my $origin = $meta->{optional_features};
  3026. my $features = {};
  3027. for my $name ( keys %$origin ) {
  3028. $features->{$name} = {
  3029. description => $origin->{$name}{description},
  3030. requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','requires'),
  3031. configure_requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','configure_requires'),
  3032. build_requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','build_requires'),
  3033. recommends => _extract_prereqs($origin->{$name}{prereqs},'runtime','recommends'),
  3034. conflicts => _extract_prereqs($origin->{$name}{prereqs},'runtime','conflicts'),
  3035. };
  3036. for my $k (keys %{$features->{$name}} ) {
  3037. delete $features->{$name}{$k} unless defined $features->{$name}{$k};
  3038. }
  3039. }
  3040. return $features;
  3041. }
  3042. sub _upgrade_optional_features {
  3043. my (undef, undef, $meta) = @_;
  3044. return unless exists $meta->{optional_features};
  3045. my $origin = $meta->{optional_features};
  3046. my $features = {};
  3047. for my $name ( keys %$origin ) {
  3048. $features->{$name} = {
  3049. description => $origin->{$name}{description},
  3050. prereqs => _prereqs_from_1(undef, undef, $origin->{$name}),
  3051. };
  3052. delete $features->{$name}{prereqs}{configure};
  3053. }
  3054. return $features;
  3055. }
  3056. my $optional_features_2_spec = {
  3057. description => \&_keep,
  3058. prereqs => \&_cleanup_prereqs,
  3059. ':custom' => \&_prefix_custom,
  3060. };
  3061. sub _feature_2 {
  3062. my ($element, $key, $meta, $to_version) = @_;
  3063. return unless $element && ref $element eq 'HASH';
  3064. _convert( $element, $optional_features_2_spec, $to_version );
  3065. }
  3066. sub _cleanup_optional_features_2 {
  3067. my ($element, $key, $meta, $to_version) = @_;
  3068. return unless $element && ref $element eq 'HASH';
  3069. my $new_data = {};
  3070. for my $k ( keys %$element ) {
  3071. $new_data->{$k} = _feature_2( $element->{$k}, $k, $meta, $to_version );
  3072. }
  3073. return unless keys %$new_data;
  3074. return $new_data;
  3075. }
  3076. sub _optional_features_1_4 {
  3077. my ($element) = @_;
  3078. return unless $element;
  3079. $element = _optional_features_as_map($element);
  3080. for my $name ( keys %$element ) {
  3081. for my $drop ( qw/requires_packages requires_os excluded_os/ ) {
  3082. delete $element->{$name}{$drop};
  3083. }
  3084. }
  3085. return $element;
  3086. }
  3087. sub _optional_features_as_map {
  3088. my ($element) = @_;
  3089. return unless $element;
  3090. if ( ref $element eq 'ARRAY' ) {
  3091. my %map;
  3092. for my $feature ( @$element ) {
  3093. my (@parts) = %$feature;
  3094. $map{$parts[0]} = $parts[1];
  3095. }
  3096. $element = \%map;
  3097. }
  3098. return $element;
  3099. }
  3100. sub _is_urlish { defined $_[0] && $_[0] =~ m{\A[-+.a-z0-9]+:.+}i }
  3101. sub _url_or_drop {
  3102. my ($element) = @_;
  3103. return $element if _is_urlish($element);
  3104. return;
  3105. }
  3106. sub _url_list {
  3107. my ($element) = @_;
  3108. return unless $element;
  3109. $element = _listify( $element );
  3110. $element = [ grep { _is_urlish($_) } @$element ];
  3111. return unless @$element;
  3112. return $element;
  3113. }
  3114. sub _author_list {
  3115. my ($element) = @_;
  3116. return [ 'unknown' ] unless $element;
  3117. $element = _listify( $element );
  3118. $element = [ map { defined $_ && length $_ ? $_ : 'unknown' } @$element ];
  3119. return [ 'unknown' ] unless @$element;
  3120. return $element;
  3121. }
  3122. my $resource2_upgrade = {
  3123. license => sub { return _is_urlish($_[0]) ? _listify( $_[0] ) : undef },
  3124. homepage => \&_url_or_drop,
  3125. bugtracker => sub {
  3126. my ($item) = @_;
  3127. return unless $item;
  3128. if ( $item =~ m{^mailto:(.*)$} ) { return { mailto => $1 } }
  3129. elsif( _is_urlish($item) ) { return { web => $item } }
  3130. else { return }
  3131. },
  3132. repository => sub { return _is_urlish($_[0]) ? { url => $_[0] } : undef },
  3133. ':custom' => \&_prefix_custom,
  3134. };
  3135. sub _upgrade_resources_2 {
  3136. my (undef, undef, $meta, $version) = @_;
  3137. return unless exists $meta->{resources};
  3138. return _convert($meta->{resources}, $resource2_upgrade);
  3139. }
  3140. my $bugtracker2_spec = {
  3141. web => \&_url_or_drop,
  3142. mailto => \&_keep,
  3143. ':custom' => \&_prefix_custom,
  3144. };
  3145. sub _repo_type {
  3146. my ($element, $key, $meta, $to_version) = @_;
  3147. return $element if defined $element;
  3148. return unless exists $meta->{url};
  3149. my $repo_url = $meta->{url};
  3150. for my $type ( qw/git svn/ ) {
  3151. return $type if $repo_url =~ m{\A$type};
  3152. }
  3153. return;
  3154. }
  3155. my $repository2_spec = {
  3156. web => \&_url_or_drop,
  3157. url => \&_url_or_drop,
  3158. type => \&_repo_type,
  3159. ':custom' => \&_prefix_custom,
  3160. };
  3161. my $resources2_cleanup = {
  3162. license => \&_url_list,
  3163. homepage => \&_url_or_drop,
  3164. bugtracker => sub { ref $_[0] ? _convert( $_[0], $bugtracker2_spec ) : undef },
  3165. repository => sub { my $data = shift; ref $data ? _convert( $data, $repository2_spec ) : undef },
  3166. ':custom' => \&_prefix_custom,
  3167. };
  3168. sub _cleanup_resources_2 {
  3169. my ($resources, $key, $meta, $to_version) = @_;
  3170. return unless $resources && ref $resources eq 'HASH';
  3171. return _convert($resources, $resources2_cleanup, $to_version);
  3172. }
  3173. my $resource1_spec = {
  3174. license => \&_url_or_drop,
  3175. homepage => \&_url_or_drop,
  3176. bugtracker => \&_url_or_drop,
  3177. repository => \&_url_or_drop,
  3178. ':custom' => \&_keep,
  3179. };
  3180. sub _resources_1_3 {
  3181. my (undef, undef, $meta, $version) = @_;
  3182. return unless exists $meta->{resources};
  3183. return _convert($meta->{resources}, $resource1_spec);
  3184. }
  3185. *_resources_1_4 = *_resources_1_3;
  3186. sub _resources_1_2 {
  3187. my (undef, undef, $meta) = @_;
  3188. my $resources = $meta->{resources} || {};
  3189. if ( $meta->{license_url} && ! $resources->{license} ) {
  3190. $resources->{license} = $meta->license_url
  3191. if _is_urlish($meta->{license_url});
  3192. }
  3193. return unless keys %$resources;
  3194. return _convert($resources, $resource1_spec);
  3195. }
  3196. my $resource_downgrade_spec = {
  3197. license => sub { return ref $_[0] ? $_[0]->[0] : $_[0] },
  3198. homepage => \&_url_or_drop,
  3199. bugtracker => sub { return $_[0]->{web} },
  3200. repository => sub { return $_[0]->{url} || $_[0]->{web} },
  3201. ':custom' => \&_ucfirst_custom,
  3202. };
  3203. sub _downgrade_resources {
  3204. my (undef, undef, $meta, $version) = @_;
  3205. return unless exists $meta->{resources};
  3206. return _convert($meta->{resources}, $resource_downgrade_spec);
  3207. }
  3208. sub _release_status {
  3209. my ($element, undef, $meta) = @_;
  3210. return $element if $element && $element =~ m{\A(?:stable|testing|unstable)\z};
  3211. return _release_status_from_version(undef, undef, $meta);
  3212. }
  3213. sub _release_status_from_version {
  3214. my (undef, undef, $meta) = @_;
  3215. my $version = $meta->{version} || '';
  3216. return ( $version =~ /_/ ) ? 'testing' : 'stable';
  3217. }
  3218. my $provides_spec = {
  3219. file => \&_keep,
  3220. version => \&_clean_version,
  3221. };
  3222. my $provides_spec_2 = {
  3223. file => \&_keep,
  3224. version => \&_clean_version,
  3225. ':custom' => \&_prefix_custom,
  3226. };
  3227. sub _provides {
  3228. my ($element, $key, $meta, $to_version) = @_;
  3229. return unless defined $element && ref $element eq 'HASH';
  3230. my $spec = $to_version == 2 ? $provides_spec_2 : $provides_spec;
  3231. my $new_data = {};
  3232. for my $k ( keys %$element ) {
  3233. $new_data->{$k} = _convert($element->{$k}, $spec, $to_version);
  3234. }
  3235. return $new_data;
  3236. }
  3237. sub _convert {
  3238. my ($data, $spec, $to_version) = @_;
  3239. my $new_data = {};
  3240. for my $key ( keys %$spec ) {
  3241. next if $key eq ':custom' || $key eq ':drop';
  3242. next unless my $fcn = $spec->{$key};
  3243. die "spec for '$key' is not a coderef"
  3244. unless ref $fcn && ref $fcn eq 'CODE';
  3245. my $new_value = $fcn->($data->{$key}, $key, $data, $to_version);
  3246. $new_data->{$key} = $new_value if defined $new_value;
  3247. }
  3248. my $drop_list = $spec->{':drop'};
  3249. my $customizer = $spec->{':custom'} || \&_keep;
  3250. for my $key ( keys %$data ) {
  3251. next if $drop_list && grep { $key eq $_ } @$drop_list;
  3252. next if exists $spec->{$key}; # we handled it
  3253. $new_data->{ $customizer->($key) } = $data->{$key};
  3254. }
  3255. return $new_data;
  3256. }
  3257. #--------------------------------------------------------------------------#
  3258. # define converters for each conversion
  3259. #--------------------------------------------------------------------------#
  3260. # each converts from prior version
  3261. # special ":custom" field is used for keys not recognized in spec
  3262. my %up_convert = (
  3263. '2-from-1.4' => {
  3264. # PRIOR MANDATORY
  3265. 'abstract' => \&_keep_or_unknown,
  3266. 'author' => \&_author_list,
  3267. 'generated_by' => \&_generated_by,
  3268. 'license' => \&_license_2,
  3269. 'meta-spec' => \&_change_meta_spec,
  3270. 'name' => \&_keep,
  3271. 'version' => \&_keep,
  3272. # CHANGED TO MANDATORY
  3273. 'dynamic_config' => \&_keep_or_one,
  3274. # ADDED MANDATORY
  3275. 'release_status' => \&_release_status_from_version,
  3276. # PRIOR OPTIONAL
  3277. 'keywords' => \&_keep,
  3278. 'no_index' => \&_no_index_directory,
  3279. 'optional_features' => \&_upgrade_optional_features,
  3280. 'provides' => \&_provides,
  3281. 'resources' => \&_upgrade_resources_2,
  3282. # ADDED OPTIONAL
  3283. 'description' => \&_keep,
  3284. 'prereqs' => \&_prereqs_from_1,
  3285. # drop these deprecated fields, but only after we convert
  3286. ':drop' => [ qw(
  3287. build_requires
  3288. configure_requires
  3289. conflicts
  3290. distribution_type
  3291. license_url
  3292. private
  3293. recommends
  3294. requires
  3295. ) ],
  3296. # other random keys need x_ prefixing
  3297. ':custom' => \&_prefix_custom,
  3298. },
  3299. '1.4-from-1.3' => {
  3300. # PRIOR MANDATORY
  3301. 'abstract' => \&_keep_or_unknown,
  3302. 'author' => \&_author_list,
  3303. 'generated_by' => \&_generated_by,
  3304. 'license' => \&_license_1,
  3305. 'meta-spec' => \&_change_meta_spec,
  3306. 'name' => \&_keep,
  3307. 'version' => \&_keep,
  3308. # PRIOR OPTIONAL
  3309. 'build_requires' => \&_version_map,
  3310. 'conflicts' => \&_version_map,
  3311. 'distribution_type' => \&_keep,
  3312. 'dynamic_config' => \&_keep_or_one,
  3313. 'keywords' => \&_keep,
  3314. 'no_index' => \&_no_index_directory,
  3315. 'optional_features' => \&_optional_features_1_4,
  3316. 'provides' => \&_provides,
  3317. 'recommends' => \&_version_map,
  3318. 'requires' => \&_version_map,
  3319. 'resources' => \&_resources_1_4,
  3320. # ADDED OPTIONAL
  3321. 'configure_requires' => \&_keep,
  3322. # drop these deprecated fields, but only after we convert
  3323. ':drop' => [ qw(
  3324. license_url
  3325. private
  3326. )],
  3327. # other random keys are OK if already valid
  3328. ':custom' => \&_keep
  3329. },
  3330. '1.3-from-1.2' => {
  3331. # PRIOR MANDATORY
  3332. 'abstract' => \&_keep_or_unknown,
  3333. 'author' => \&_author_list,
  3334. 'generated_by' => \&_generated_by,
  3335. 'license' => \&_license_1,
  3336. 'meta-spec' => \&_change_meta_spec,
  3337. 'name' => \&_keep,
  3338. 'version' => \&_keep,
  3339. # PRIOR OPTIONAL
  3340. 'build_requires' => \&_version_map,
  3341. 'conflicts' => \&_version_map,
  3342. 'distribution_type' => \&_keep,
  3343. 'dynamic_config' => \&_keep_or_one,
  3344. 'keywords' => \&_keep,
  3345. 'no_index' => \&_no_index_directory,
  3346. 'optional_features' => \&_optional_features_as_map,
  3347. 'provides' => \&_provides,
  3348. 'recommends' => \&_version_map,
  3349. 'requires' => \&_version_map,
  3350. 'resources' => \&_resources_1_3,
  3351. # drop these deprecated fields, but only after we convert
  3352. ':drop' => [ qw(
  3353. license_url
  3354. private
  3355. )],
  3356. # other random keys are OK if already valid
  3357. ':custom' => \&_keep
  3358. },
  3359. '1.2-from-1.1' => {
  3360. # PRIOR MANDATORY
  3361. 'version' => \&_keep,
  3362. # CHANGED TO MANDATORY
  3363. 'license' => \&_license_1,
  3364. 'name' => \&_keep,
  3365. 'generated_by' => \&_generated_by,
  3366. # ADDED MANDATORY
  3367. 'abstract' => \&_keep_or_unknown,
  3368. 'author' => \&_author_list,
  3369. 'meta-spec' => \&_change_meta_spec,
  3370. # PRIOR OPTIONAL
  3371. 'build_requires' => \&_version_map,
  3372. 'conflicts' => \&_version_map,
  3373. 'distribution_type' => \&_keep,
  3374. 'dynamic_config' => \&_keep_or_one,
  3375. 'recommends' => \&_version_map,
  3376. 'requires' => \&_version_map,
  3377. # ADDED OPTIONAL
  3378. 'keywords' => \&_keep,
  3379. 'no_index' => \&_no_index_1_2,
  3380. 'optional_features' => \&_optional_features_as_map,
  3381. 'provides' => \&_provides,
  3382. 'resources' => \&_resources_1_2,
  3383. # drop these deprecated fields, but only after we convert
  3384. ':drop' => [ qw(
  3385. license_url
  3386. private
  3387. )],
  3388. # other random keys are OK if already valid
  3389. ':custom' => \&_keep
  3390. },
  3391. '1.1-from-1.0' => {
  3392. # CHANGED TO MANDATORY
  3393. 'version' => \&_keep,
  3394. # IMPLIED MANDATORY
  3395. 'name' => \&_keep,
  3396. # PRIOR OPTIONAL
  3397. 'build_requires' => \&_version_map,
  3398. 'conflicts' => \&_version_map,
  3399. 'distribution_type' => \&_keep,
  3400. 'dynamic_config' => \&_keep_or_one,
  3401. 'generated_by' => \&_generated_by,
  3402. 'license' => \&_license_1,
  3403. 'recommends' => \&_version_map,
  3404. 'requires' => \&_version_map,
  3405. # ADDED OPTIONAL
  3406. 'license_url' => \&_url_or_drop,
  3407. 'private' => \&_keep,
  3408. # other random keys are OK if already valid
  3409. ':custom' => \&_keep
  3410. },
  3411. );
  3412. my %down_convert = (
  3413. '1.4-from-2' => {
  3414. # MANDATORY
  3415. 'abstract' => \&_keep_or_unknown,
  3416. 'author' => \&_author_list,
  3417. 'generated_by' => \&_generated_by,
  3418. 'license' => \&_downgrade_license,
  3419. 'meta-spec' => \&_change_meta_spec,
  3420. 'name' => \&_keep,
  3421. 'version' => \&_keep,
  3422. # OPTIONAL
  3423. 'build_requires' => \&_get_build_requires,
  3424. 'configure_requires' => \&_get_configure_requires,
  3425. 'conflicts' => \&_get_conflicts,
  3426. 'distribution_type' => \&_keep,
  3427. 'dynamic_config' => \&_keep_or_one,
  3428. 'keywords' => \&_keep,
  3429. 'no_index' => \&_no_index_directory,
  3430. 'optional_features' => \&_downgrade_optional_features,
  3431. 'provides' => \&_provides,
  3432. 'recommends' => \&_get_recommends,
  3433. 'requires' => \&_get_requires,
  3434. 'resources' => \&_downgrade_resources,
  3435. # drop these unsupported fields (after conversion)
  3436. ':drop' => [ qw(
  3437. description
  3438. prereqs
  3439. release_status
  3440. )],
  3441. # custom keys will be left unchanged
  3442. ':custom' => \&_keep
  3443. },
  3444. '1.3-from-1.4' => {
  3445. # MANDATORY
  3446. 'abstract' => \&_keep_or_unknown,
  3447. 'author' => \&_author_list,
  3448. 'generated_by' => \&_generated_by,
  3449. 'license' => \&_license_1,
  3450. 'meta-spec' => \&_change_meta_spec,
  3451. 'name' => \&_keep,
  3452. 'version' => \&_keep,
  3453. # OPTIONAL
  3454. 'build_requires' => \&_version_map,
  3455. 'conflicts' => \&_version_map,
  3456. 'distribution_type' => \&_keep,
  3457. 'dynamic_config' => \&_keep_or_one,
  3458. 'keywords' => \&_keep,
  3459. 'no_index' => \&_no_index_directory,
  3460. 'optional_features' => \&_optional_features_as_map,
  3461. 'provides' => \&_provides,
  3462. 'recommends' => \&_version_map,
  3463. 'requires' => \&_version_map,
  3464. 'resources' => \&_resources_1_3,
  3465. # drop these unsupported fields, but only after we convert
  3466. ':drop' => [ qw(
  3467. configure_requires
  3468. )],
  3469. # other random keys are OK if already valid
  3470. ':custom' => \&_keep,
  3471. },
  3472. '1.2-from-1.3' => {
  3473. # MANDATORY
  3474. 'abstract' => \&_keep_or_unknown,
  3475. 'author' => \&_author_list,
  3476. 'generated_by' => \&_generated_by,
  3477. 'license' => \&_license_1,
  3478. 'meta-spec' => \&_change_meta_spec,
  3479. 'name' => \&_keep,
  3480. 'version' => \&_keep,
  3481. # OPTIONAL
  3482. 'build_requires' => \&_version_map,
  3483. 'conflicts' => \&_version_map,
  3484. 'distribution_type' => \&_keep,
  3485. 'dynamic_config' => \&_keep_or_one,
  3486. 'keywords' => \&_keep,
  3487. 'no_index' => \&_no_index_1_2,
  3488. 'optional_features' => \&_optional_features_as_map,
  3489. 'provides' => \&_provides,
  3490. 'recommends' => \&_version_map,
  3491. 'requires' => \&_version_map,
  3492. 'resources' => \&_resources_1_3,
  3493. # other random keys are OK if already valid
  3494. ':custom' => \&_keep,
  3495. },
  3496. '1.1-from-1.2' => {
  3497. # MANDATORY
  3498. 'version' => \&_keep,
  3499. # IMPLIED MANDATORY
  3500. 'name' => \&_keep,
  3501. 'meta-spec' => \&_change_meta_spec,
  3502. # OPTIONAL
  3503. 'build_requires' => \&_version_map,
  3504. 'conflicts' => \&_version_map,
  3505. 'distribution_type' => \&_keep,
  3506. 'dynamic_config' => \&_keep_or_one,
  3507. 'generated_by' => \&_generated_by,
  3508. 'license' => \&_license_1,
  3509. 'private' => \&_keep,
  3510. 'recommends' => \&_version_map,
  3511. 'requires' => \&_version_map,
  3512. # drop unsupported fields
  3513. ':drop' => [ qw(
  3514. abstract
  3515. author
  3516. provides
  3517. no_index
  3518. keywords
  3519. resources
  3520. )],
  3521. # other random keys are OK if already valid
  3522. ':custom' => \&_keep,
  3523. },
  3524. '1.0-from-1.1' => {
  3525. # IMPLIED MANDATORY
  3526. 'name' => \&_keep,
  3527. 'meta-spec' => \&_change_meta_spec,
  3528. 'version' => \&_keep,
  3529. # PRIOR OPTIONAL
  3530. 'build_requires' => \&_version_map,
  3531. 'conflicts' => \&_version_map,
  3532. 'distribution_type' => \&_keep,
  3533. 'dynamic_config' => \&_keep_or_one,
  3534. 'generated_by' => \&_generated_by,
  3535. 'license' => \&_license_1,
  3536. 'recommends' => \&_version_map,
  3537. 'requires' => \&_version_map,
  3538. # other random keys are OK if already valid
  3539. ':custom' => \&_keep,
  3540. },
  3541. );
  3542. my %cleanup = (
  3543. '2' => {
  3544. # PRIOR MANDATORY
  3545. 'abstract' => \&_keep_or_unknown,
  3546. 'author' => \&_author_list,
  3547. 'generated_by' => \&_generated_by,
  3548. 'license' => \&_license_2,
  3549. 'meta-spec' => \&_change_meta_spec,
  3550. 'name' => \&_keep,
  3551. 'version' => \&_keep,
  3552. # CHANGED TO MANDATORY
  3553. 'dynamic_config' => \&_keep_or_one,
  3554. # ADDED MANDATORY
  3555. 'release_status' => \&_release_status,
  3556. # PRIOR OPTIONAL
  3557. 'keywords' => \&_keep,
  3558. 'no_index' => \&_no_index_directory,
  3559. 'optional_features' => \&_cleanup_optional_features_2,
  3560. 'provides' => \&_provides,
  3561. 'resources' => \&_cleanup_resources_2,
  3562. # ADDED OPTIONAL
  3563. 'description' => \&_keep,
  3564. 'prereqs' => \&_cleanup_prereqs,
  3565. # drop these deprecated fields, but only after we convert
  3566. ':drop' => [ qw(
  3567. build_requires
  3568. configure_requires
  3569. conflicts
  3570. distribution_type
  3571. license_url
  3572. private
  3573. recommends
  3574. requires
  3575. ) ],
  3576. # other random keys need x_ prefixing
  3577. ':custom' => \&_prefix_custom,
  3578. },
  3579. '1.4' => {
  3580. # PRIOR MANDATORY
  3581. 'abstract' => \&_keep_or_unknown,
  3582. 'author' => \&_author_list,
  3583. 'generated_by' => \&_generated_by,
  3584. 'license' => \&_license_1,
  3585. 'meta-spec' => \&_change_meta_spec,
  3586. 'name' => \&_keep,
  3587. 'version' => \&_keep,
  3588. # PRIOR OPTIONAL
  3589. 'build_requires' => \&_version_map,
  3590. 'conflicts' => \&_version_map,
  3591. 'distribution_type' => \&_keep,
  3592. 'dynamic_config' => \&_keep_or_one,
  3593. 'keywords' => \&_keep,
  3594. 'no_index' => \&_no_index_directory,
  3595. 'optional_features' => \&_optional_features_1_4,
  3596. 'provides' => \&_provides,
  3597. 'recommends' => \&_version_map,
  3598. 'requires' => \&_version_map,
  3599. 'resources' => \&_resources_1_4,
  3600. # ADDED OPTIONAL
  3601. 'configure_requires' => \&_keep,
  3602. # other random keys are OK if already valid
  3603. ':custom' => \&_keep
  3604. },
  3605. '1.3' => {
  3606. # PRIOR MANDATORY
  3607. 'abstract' => \&_keep_or_unknown,
  3608. 'author' => \&_author_list,
  3609. 'generated_by' => \&_generated_by,
  3610. 'license' => \&_license_1,
  3611. 'meta-spec' => \&_change_meta_spec,
  3612. 'name' => \&_keep,
  3613. 'version' => \&_keep,
  3614. # PRIOR OPTIONAL
  3615. 'build_requires' => \&_version_map,
  3616. 'conflicts' => \&_version_map,
  3617. 'distribution_type' => \&_keep,
  3618. 'dynamic_config' => \&_keep_or_one,
  3619. 'keywords' => \&_keep,
  3620. 'no_index' => \&_no_index_directory,
  3621. 'optional_features' => \&_optional_features_as_map,
  3622. 'provides' => \&_provides,
  3623. 'recommends' => \&_version_map,
  3624. 'requires' => \&_version_map,
  3625. 'resources' => \&_resources_1_3,
  3626. # other random keys are OK if already valid
  3627. ':custom' => \&_keep
  3628. },
  3629. '1.2' => {
  3630. # PRIOR MANDATORY
  3631. 'version' => \&_keep,
  3632. # CHANGED TO MANDATORY
  3633. 'license' => \&_license_1,
  3634. 'name' => \&_keep,
  3635. 'generated_by' => \&_generated_by,
  3636. # ADDED MANDATORY
  3637. 'abstract' => \&_keep_or_unknown,
  3638. 'author' => \&_author_list,
  3639. 'meta-spec' => \&_change_meta_spec,
  3640. # PRIOR OPTIONAL
  3641. 'build_requires' => \&_version_map,
  3642. 'conflicts' => \&_version_map,
  3643. 'distribution_type' => \&_keep,
  3644. 'dynamic_config' => \&_keep_or_one,
  3645. 'recommends' => \&_version_map,
  3646. 'requires' => \&_version_map,
  3647. # ADDED OPTIONAL
  3648. 'keywords' => \&_keep,
  3649. 'no_index' => \&_no_index_1_2,
  3650. 'optional_features' => \&_optional_features_as_map,
  3651. 'provides' => \&_provides,
  3652. 'resources' => \&_resources_1_2,
  3653. # other random keys are OK if already valid
  3654. ':custom' => \&_keep
  3655. },
  3656. '1.1' => {
  3657. # CHANGED TO MANDATORY
  3658. 'version' => \&_keep,
  3659. # IMPLIED MANDATORY
  3660. 'name' => \&_keep,
  3661. 'meta-spec' => \&_change_meta_spec,
  3662. # PRIOR OPTIONAL
  3663. 'build_requires' => \&_version_map,
  3664. 'conflicts' => \&_version_map,
  3665. 'distribution_type' => \&_keep,
  3666. 'dynamic_config' => \&_keep_or_one,
  3667. 'generated_by' => \&_generated_by,
  3668. 'license' => \&_license_1,
  3669. 'recommends' => \&_version_map,
  3670. 'requires' => \&_version_map,
  3671. # ADDED OPTIONAL
  3672. 'license_url' => \&_url_or_drop,
  3673. 'private' => \&_keep,
  3674. # other random keys are OK if already valid
  3675. ':custom' => \&_keep
  3676. },
  3677. '1.0' => {
  3678. # IMPLIED MANDATORY
  3679. 'name' => \&_keep,
  3680. 'meta-spec' => \&_change_meta_spec,
  3681. 'version' => \&_keep,
  3682. # IMPLIED OPTIONAL
  3683. 'build_requires' => \&_version_map,
  3684. 'conflicts' => \&_version_map,
  3685. 'distribution_type' => \&_keep,
  3686. 'dynamic_config' => \&_keep_or_one,
  3687. 'generated_by' => \&_generated_by,
  3688. 'license' => \&_license_1,
  3689. 'recommends' => \&_version_map,
  3690. 'requires' => \&_version_map,
  3691. # other random keys are OK if already valid
  3692. ':custom' => \&_keep,
  3693. },
  3694. );
  3695. #--------------------------------------------------------------------------#
  3696. # Code
  3697. #--------------------------------------------------------------------------#
  3698. sub new {
  3699. my ($class,$data) = @_;
  3700. # create an attributes hash
  3701. my $self = {
  3702. 'data' => $data,
  3703. 'spec' => $data->{'meta-spec'}{'version'} || "1.0",
  3704. };
  3705. # create the object
  3706. return bless $self, $class;
  3707. }
  3708. sub convert {
  3709. my ($self, %args) = @_;
  3710. my $args = { %args };
  3711. my $new_version = $args->{version} || $HIGHEST;
  3712. my ($old_version) = $self->{spec};
  3713. my $converted = _dclone($self->{data});
  3714. if ( $old_version == $new_version ) {
  3715. $converted = _convert( $converted, $cleanup{$old_version}, $old_version );
  3716. my $cmv = CPAN::Meta::Validator->new( $converted );
  3717. unless ( $cmv->is_valid ) {
  3718. my $errs = join("\n", $cmv->errors);
  3719. die "Failed to clean-up $old_version metadata. Errors:\n$errs\n";
  3720. }
  3721. return $converted;
  3722. }
  3723. elsif ( $old_version > $new_version ) {
  3724. my @vers = sort { $b <=> $a } keys %known_specs;
  3725. for my $i ( 0 .. $#vers-1 ) {
  3726. next if $vers[$i] > $old_version;
  3727. last if $vers[$i+1] < $new_version;
  3728. my $spec_string = "$vers[$i+1]-from-$vers[$i]";
  3729. $converted = _convert( $converted, $down_convert{$spec_string}, $vers[$i+1] );
  3730. my $cmv = CPAN::Meta::Validator->new( $converted );
  3731. unless ( $cmv->is_valid ) {
  3732. my $errs = join("\n", $cmv->errors);
  3733. die "Failed to downconvert metadata to $vers[$i+1]. Errors:\n$errs\n";
  3734. }
  3735. }
  3736. return $converted;
  3737. }
  3738. else {
  3739. my @vers = sort { $a <=> $b } keys %known_specs;
  3740. for my $i ( 0 .. $#vers-1 ) {
  3741. next if $vers[$i] < $old_version;
  3742. last if $vers[$i+1] > $new_version;
  3743. my $spec_string = "$vers[$i+1]-from-$vers[$i]";
  3744. $converted = _convert( $converted, $up_convert{$spec_string}, $vers[$i+1] );
  3745. my $cmv = CPAN::Meta::Validator->new( $converted );
  3746. unless ( $cmv->is_valid ) {
  3747. my $errs = join("\n", $cmv->errors);
  3748. die "Failed to upconvert metadata to $vers[$i+1]. Errors:\n$errs\n";
  3749. }
  3750. }
  3751. return $converted;
  3752. }
  3753. }
  3754. 1;
  3755. # ABSTRACT: Convert CPAN distribution metadata structures
  3756. __END__
  3757. CPAN_META_CONVERTER
  3758.  
  3759. $fatpacked{"CPAN/Meta/Feature.pm"} = <<'CPAN_META_FEATURE';
  3760. use 5.006;
  3761. use strict;
  3762. use warnings;
  3763. package CPAN::Meta::Feature;
  3764. our $VERSION = '2.120921'; # VERSION
  3765. use CPAN::Meta::Prereqs;
  3766. sub new {
  3767. my ($class, $identifier, $spec) = @_;
  3768. my %guts = (
  3769. identifier => $identifier,
  3770. description => $spec->{description},
  3771. prereqs => CPAN::Meta::Prereqs->new($spec->{prereqs}),
  3772. );
  3773. bless \%guts => $class;
  3774. }
  3775. sub identifier { $_[0]{identifier} }
  3776. sub description { $_[0]{description} }
  3777. sub prereqs { $_[0]{prereqs} }
  3778. 1;
  3779. # ABSTRACT: an optional feature provided by a CPAN distribution
  3780. __END__
  3781. CPAN_META_FEATURE
  3782.  
  3783. $fatpacked{"CPAN/Meta/History.pm"} = <<'CPAN_META_HISTORY';
  3784. # vi:tw=72
  3785. use 5.006;
  3786. use strict;
  3787. use warnings;
  3788. package CPAN::Meta::History;
  3789. our $VERSION = '2.120921'; # VERSION
  3790. 1;
  3791. # ABSTRACT: history of CPAN Meta Spec changes
  3792. __END__
  3793. =pod
  3794. CPAN_META_HISTORY
  3795.  
  3796. $fatpacked{"CPAN/Meta/Prereqs.pm"} = <<'CPAN_META_PREREQS';
  3797. use 5.006;
  3798. use strict;
  3799. use warnings;
  3800. package CPAN::Meta::Prereqs;
  3801. our $VERSION = '2.120921'; # VERSION
  3802. use Carp qw(confess);
  3803. use Scalar::Util qw(blessed);
  3804. use CPAN::Meta::Requirements 2.121;
  3805. sub __legal_phases { qw(configure build test runtime develop) }
  3806. sub __legal_types { qw(requires recommends suggests conflicts) }
  3807. # expect a prereq spec from META.json -- rjbs, 2010-04-11
  3808. sub new {
  3809. my ($class, $prereq_spec) = @_;
  3810. $prereq_spec ||= {};
  3811. my %is_legal_phase = map {; $_ => 1 } $class->__legal_phases;
  3812. my %is_legal_type = map {; $_ => 1 } $class->__legal_types;
  3813. my %guts;
  3814. PHASE: for my $phase (keys %$prereq_spec) {
  3815. next PHASE unless $phase =~ /\Ax_/i or $is_legal_phase{$phase};
  3816. my $phase_spec = $prereq_spec->{ $phase };
  3817. next PHASE unless keys %$phase_spec;
  3818. TYPE: for my $type (keys %$phase_spec) {
  3819. next TYPE unless $type =~ /\Ax_/i or $is_legal_type{$type};
  3820. my $spec = $phase_spec->{ $type };
  3821. next TYPE unless keys %$spec;
  3822. $guts{prereqs}{$phase}{$type} = CPAN::Meta::Requirements->from_string_hash(
  3823. $spec
  3824. );
  3825. }
  3826. }
  3827. return bless \%guts => $class;
  3828. }
  3829. sub requirements_for {
  3830. my ($self, $phase, $type) = @_;
  3831. confess "requirements_for called without phase" unless defined $phase;
  3832. confess "requirements_for called without type" unless defined $type;
  3833. unless ($phase =~ /\Ax_/i or grep { $phase eq $_ } $self->__legal_phases) {
  3834. confess "requested requirements for unknown phase: $phase";
  3835. }
  3836. unless ($type =~ /\Ax_/i or grep { $type eq $_ } $self->__legal_types) {
  3837. confess "requested requirements for unknown type: $type";
  3838. }
  3839. my $req = ($self->{prereqs}{$phase}{$type} ||= CPAN::Meta::Requirements->new);
  3840. $req->finalize if $self->is_finalized;
  3841. return $req;
  3842. }
  3843. sub with_merged_prereqs {
  3844. my ($self, $other) = @_;
  3845. my @other = blessed($other) ? $other : @$other;
  3846. my @prereq_objs = ($self, @other);
  3847. my %new_arg;
  3848. for my $phase ($self->__legal_phases) {
  3849. for my $type ($self->__legal_types) {
  3850. my $req = CPAN::Meta::Requirements->new;
  3851. for my $prereq (@prereq_objs) {
  3852. my $this_req = $prereq->requirements_for($phase, $type);
  3853. next unless $this_req->required_modules;
  3854. $req->add_requirements($this_req);
  3855. }
  3856. next unless $req->required_modules;
  3857. $new_arg{ $phase }{ $type } = $req->as_string_hash;
  3858. }
  3859. }
  3860. return (ref $self)->new(\%new_arg);
  3861. }
  3862. sub as_string_hash {
  3863. my ($self) = @_;
  3864. my %hash;
  3865. for my $phase ($self->__legal_phases) {
  3866. for my $type ($self->__legal_types) {
  3867. my $req = $self->requirements_for($phase, $type);
  3868. next unless $req->required_modules;
  3869. $hash{ $phase }{ $type } = $req->as_string_hash;
  3870. }
  3871. }
  3872. return \%hash;
  3873. }
  3874. sub is_finalized { $_[0]{finalized} }
  3875. sub finalize {
  3876. my ($self) = @_;
  3877. $self->{finalized} = 1;
  3878. for my $phase (keys %{ $self->{prereqs} }) {
  3879. $_->finalize for values %{ $self->{prereqs}{$phase} };
  3880. }
  3881. }
  3882. sub clone {
  3883. my ($self) = @_;
  3884. my $clone = (ref $self)->new( $self->as_string_hash );
  3885. }
  3886. 1;
  3887. # ABSTRACT: a set of distribution prerequisites by phase and type
  3888. __END__
  3889. CPAN_META_PREREQS
  3890.  
  3891. $fatpacked{"CPAN/Meta/Requirements.pm"} = <<'CPAN_META_REQUIREMENTS';
  3892. use strict;
  3893. use warnings;
  3894. package CPAN::Meta::Requirements;
  3895. our $VERSION = '2.122'; # VERSION
  3896. # ABSTRACT: a set of version requirements for a CPAN dist
  3897. use Carp ();
  3898. use Scalar::Util ();
  3899. use version 0.77 (); # the ->parse method
  3900. my @valid_options = qw( bad_version_hook );
  3901. sub new {
  3902. my ($class, $options) = @_;
  3903. $options ||= {};
  3904. Carp::croak "Argument to $class\->new() must be a hash reference"
  3905. unless ref $options eq 'HASH';
  3906. my %self = map {; $_ => $options->{$_}} @valid_options;
  3907. return bless \%self => $class;
  3908. }
  3909. sub _version_object {
  3910. my ($self, $version) = @_;
  3911. my $vobj;
  3912. eval {
  3913. $vobj = (! defined $version) ? version->parse(0)
  3914. : (! Scalar::Util::blessed($version)) ? version->parse($version)
  3915. : $version;
  3916. };
  3917. if ( my $err = $@ ) {
  3918. my $hook = $self->{bad_version_hook};
  3919. $vobj = eval { $hook->($version) }
  3920. if ref $hook eq 'CODE';
  3921. unless (Scalar::Util::blessed($vobj) && $vobj->isa("version")) {
  3922. $err =~ s{ at .* line \d+.*$}{};
  3923. die "Can't convert '$version': $err";
  3924. }
  3925. }
  3926. # ensure no leading '.'
  3927. if ( $vobj =~ m{\A\.} ) {
  3928. $vobj = version->parse("0$vobj");
  3929. }
  3930. # ensure normal v-string form
  3931. if ( $vobj->is_qv ) {
  3932. $vobj = version->parse($vobj->normal);
  3933. }
  3934. return $vobj;
  3935. }
  3936. BEGIN {
  3937. for my $type (qw(minimum maximum exclusion exact_version)) {
  3938. my $method = "with_$type";
  3939. my $to_add = $type eq 'exact_version' ? $type : "add_$type";
  3940. my $code = sub {
  3941. my ($self, $name, $version) = @_;
  3942. $version = $self->_version_object( $version );
  3943. $self->__modify_entry_for($name, $method, $version);
  3944. return $self;
  3945. };
  3946. no strict 'refs';
  3947. *$to_add = $code;
  3948. }
  3949. }
  3950. sub add_requirements {
  3951. my ($self, $req) = @_;
  3952. for my $module ($req->required_modules) {
  3953. my $modifiers = $req->__entry_for($module)->as_modifiers;
  3954. for my $modifier (@$modifiers) {
  3955. my ($method, @args) = @$modifier;
  3956. $self->$method($module => @args);
  3957. };
  3958. }
  3959. return $self;
  3960. }
  3961. sub accepts_module {
  3962. my ($self, $module, $version) = @_;
  3963. $version = $self->_version_object( $version );
  3964. return 1 unless my $range = $self->__entry_for($module);
  3965. return $range->_accepts($version);
  3966. }
  3967. sub clear_requirement {
  3968. my ($self, $module) = @_;
  3969. return $self unless $self->__entry_for($module);
  3970. Carp::confess("can't clear requirements on finalized requirements")
  3971. if $self->is_finalized;
  3972. delete $self->{requirements}{ $module };
  3973. return $self;
  3974. }
  3975. sub requirements_for_module {
  3976. my ($self, $module) = @_;
  3977. my $entry = $self->__entry_for($module);
  3978. return unless $entry;
  3979. return $entry->as_string;
  3980. }
  3981. sub required_modules { keys %{ $_[0]{requirements} } }
  3982. sub clone {
  3983. my ($self) = @_;
  3984. my $new = (ref $self)->new;
  3985. return $new->add_requirements($self);
  3986. }
  3987. sub __entry_for { $_[0]{requirements}{ $_[1] } }
  3988. sub __modify_entry_for {
  3989. my ($self, $name, $method, $version) = @_;
  3990. my $fin = $self->is_finalized;
  3991. my $old = $self->__entry_for($name);
  3992. Carp::confess("can't add new requirements to finalized requirements")
  3993. if $fin and not $old;
  3994. my $new = ($old || 'CPAN::Meta::Requirements::_Range::Range')
  3995. ->$method($version);
  3996. Carp::confess("can't modify finalized requirements")
  3997. if $fin and $old->as_string ne $new->as_string;
  3998. $self->{requirements}{ $name } = $new;
  3999. }
  4000. sub is_simple {
  4001. my ($self) = @_;
  4002. for my $module ($self->required_modules) {
  4003. # XXX: This is a complete hack, but also entirely correct.
  4004. return if $self->__entry_for($module)->as_string =~ /\s/;
  4005. }
  4006. return 1;
  4007. }
  4008. sub is_finalized { $_[0]{finalized} }
  4009. sub finalize { $_[0]{finalized} = 1 }
  4010. sub as_string_hash {
  4011. my ($self) = @_;
  4012. my %hash = map {; $_ => $self->{requirements}{$_}->as_string }
  4013. $self->required_modules;
  4014. return \%hash;
  4015. }
  4016. my %methods_for_op = (
  4017. '==' => [ qw(exact_version) ],
  4018. '!=' => [ qw(add_exclusion) ],
  4019. '>=' => [ qw(add_minimum) ],
  4020. '<=' => [ qw(add_maximum) ],
  4021. '>' => [ qw(add_minimum add_exclusion) ],
  4022. '<' => [ qw(add_maximum add_exclusion) ],
  4023. );
  4024. sub add_string_requirement {
  4025. my ($self, $module, $req) = @_;
  4026. Carp::confess("No requirement string provided for $module")
  4027. unless defined $req && length $req;
  4028. my @parts = split qr{\s*,\s*}, $req;
  4029. for my $part (@parts) {
  4030. my ($op, $ver) = $part =~ m{\A\s*(==|>=|>|<=|<|!=)\s*(.*)\z};
  4031. if (! defined $op) {
  4032. $self->add_minimum($module => $part);
  4033. } else {
  4034. Carp::confess("illegal requirement string: $req")
  4035. unless my $methods = $methods_for_op{ $op };
  4036. $self->$_($module => $ver) for @$methods;
  4037. }
  4038. }
  4039. }
  4040. sub from_string_hash {
  4041. my ($class, $hash) = @_;
  4042. my $self = $class->new;
  4043. for my $module (keys %$hash) {
  4044. my $req = $hash->{$module};
  4045. unless ( defined $req && length $req ) {
  4046. $req = 0;
  4047. Carp::carp("Undefined requirement for $module treated as '0'");
  4048. }
  4049. $self->add_string_requirement($module, $req);
  4050. }
  4051. return $self;
  4052. }
  4053. ##############################################################
  4054. {
  4055. package
  4056. CPAN::Meta::Requirements::_Range::Exact;
  4057. sub _new { bless { version => $_[1] } => $_[0] }
  4058. sub _accepts { return $_[0]{version} == $_[1] }
  4059. sub as_string { return "== $_[0]{version}" }
  4060. sub as_modifiers { return [ [ exact_version => $_[0]{version} ] ] }
  4061. sub _clone {
  4062. (ref $_[0])->_new( version->new( $_[0]{version} ) )
  4063. }
  4064. sub with_exact_version {
  4065. my ($self, $version) = @_;
  4066. return $self->_clone if $self->_accepts($version);
  4067. Carp::confess("illegal requirements: unequal exact version specified");
  4068. }
  4069. sub with_minimum {
  4070. my ($self, $minimum) = @_;
  4071. return $self->_clone if $self->{version} >= $minimum;
  4072. Carp::confess("illegal requirements: minimum above exact specification");
  4073. }
  4074. sub with_maximum {
  4075. my ($self, $maximum) = @_;
  4076. return $self->_clone if $self->{version} <= $maximum;
  4077. Carp::confess("illegal requirements: maximum below exact specification");
  4078. }
  4079. sub with_exclusion {
  4080. my ($self, $exclusion) = @_;
  4081. return $self->_clone unless $exclusion == $self->{version};
  4082. Carp::confess("illegal requirements: excluded exact specification");
  4083. }
  4084. }
  4085. ##############################################################
  4086. {
  4087. package
  4088. CPAN::Meta::Requirements::_Range::Range;
  4089. sub _self { ref($_[0]) ? $_[0] : (bless { } => $_[0]) }
  4090. sub _clone {
  4091. return (bless { } => $_[0]) unless ref $_[0];
  4092. my ($s) = @_;
  4093. my %guts = (
  4094. (exists $s->{minimum} ? (minimum => version->new($s->{minimum})) : ()),
  4095. (exists $s->{maximum} ? (maximum => version->new($s->{maximum})) : ()),
  4096. (exists $s->{exclusions}
  4097. ? (exclusions => [ map { version->new($_) } @{ $s->{exclusions} } ])
  4098. : ()),
  4099. );
  4100. bless \%guts => ref($s);
  4101. }
  4102. sub as_modifiers {
  4103. my ($self) = @_;
  4104. my @mods;
  4105. push @mods, [ add_minimum => $self->{minimum} ] if exists $self->{minimum};
  4106. push @mods, [ add_maximum => $self->{maximum} ] if exists $self->{maximum};
  4107. push @mods, map {; [ add_exclusion => $_ ] } @{$self->{exclusions} || []};
  4108. return \@mods;
  4109. }
  4110. sub as_string {
  4111. my ($self) = @_;
  4112. return 0 if ! keys %$self;
  4113. return "$self->{minimum}" if (keys %$self) == 1 and exists $self->{minimum};
  4114. my @exclusions = @{ $self->{exclusions} || [] };
  4115. my @parts;
  4116. for my $pair (
  4117. [ qw( >= > minimum ) ],
  4118. [ qw( <= < maximum ) ],
  4119. ) {
  4120. my ($op, $e_op, $k) = @$pair;
  4121. if (exists $self->{$k}) {
  4122. my @new_exclusions = grep { $_ != $self->{ $k } } @exclusions;
  4123. if (@new_exclusions == @exclusions) {
  4124. push @parts, "$op $self->{ $k }";
  4125. } else {
  4126. push @parts, "$e_op $self->{ $k }";
  4127. @exclusions = @new_exclusions;
  4128. }
  4129. }
  4130. }
  4131. push @parts, map {; "!= $_" } @exclusions;
  4132. return join q{, }, @parts;
  4133. }
  4134. sub with_exact_version {
  4135. my ($self, $version) = @_;
  4136. $self = $self->_clone;
  4137. Carp::confess("illegal requirements: exact specification outside of range")
  4138. unless $self->_accepts($version);
  4139. return CPAN::Meta::Requirements::_Range::Exact->_new($version);
  4140. }
  4141. sub _simplify {
  4142. my ($self) = @_;
  4143. if (defined $self->{minimum} and defined $self->{maximum}) {
  4144. if ($self->{minimum} == $self->{maximum}) {
  4145. Carp::confess("illegal requirements: excluded all values")
  4146. if grep { $_ == $self->{minimum} } @{ $self->{exclusions} || [] };
  4147. return CPAN::Meta::Requirements::_Range::Exact->_new($self->{minimum})
  4148. }
  4149. Carp::confess("illegal requirements: minimum exceeds maximum")
  4150. if $self->{minimum} > $self->{maximum};
  4151. }
  4152. # eliminate irrelevant exclusions
  4153. if ($self->{exclusions}) {
  4154. my %seen;
  4155. @{ $self->{exclusions} } = grep {
  4156. (! defined $self->{minimum} or $_ >= $self->{minimum})
  4157. and
  4158. (! defined $self->{maximum} or $_ <= $self->{maximum})
  4159. and
  4160. ! $seen{$_}++
  4161. } @{ $self->{exclusions} };
  4162. }
  4163. return $self;
  4164. }
  4165. sub with_minimum {
  4166. my ($self, $minimum) = @_;
  4167. $self = $self->_clone;
  4168. if (defined (my $old_min = $self->{minimum})) {
  4169. $self->{minimum} = (sort { $b cmp $a } ($minimum, $old_min))[0];
  4170. } else {
  4171. $self->{minimum} = $minimum;
  4172. }
  4173. return $self->_simplify;
  4174. }
  4175. sub with_maximum {
  4176. my ($self, $maximum) = @_;
  4177. $self = $self->_clone;
  4178. if (defined (my $old_max = $self->{maximum})) {
  4179. $self->{maximum} = (sort { $a cmp $b } ($maximum, $old_max))[0];
  4180. } else {
  4181. $self->{maximum} = $maximum;
  4182. }
  4183. return $self->_simplify;
  4184. }
  4185. sub with_exclusion {
  4186. my ($self, $exclusion) = @_;
  4187. $self = $self->_clone;
  4188. push @{ $self->{exclusions} ||= [] }, $exclusion;
  4189. return $self->_simplify;
  4190. }
  4191. sub _accepts {
  4192. my ($self, $version) = @_;
  4193. return if defined $self->{minimum} and $version < $self->{minimum};
  4194. return if defined $self->{maximum} and $version > $self->{maximum};
  4195. return if defined $self->{exclusions}
  4196. and grep { $version == $_ } @{ $self->{exclusions} };
  4197. return 1;
  4198. }
  4199. }
  4200. 1;
  4201. # vim: ts=2 sts=2 sw=2 et:
  4202. __END__
  4203. =pod
  4204. CPAN_META_REQUIREMENTS
  4205.  
  4206. $fatpacked{"CPAN/Meta/Spec.pm"} = <<'CPAN_META_SPEC';
  4207. # vi:tw=72
  4208. use 5.006;
  4209. use strict;
  4210. use warnings;
  4211. package CPAN::Meta::Spec;
  4212. our $VERSION = '2.120921'; # VERSION
  4213. 1;
  4214. # ABSTRACT: specification for CPAN distribution metadata
  4215. __END__
  4216. =pod
  4217. CPAN_META_SPEC
  4218.  
  4219. $fatpacked{"CPAN/Meta/Validator.pm"} = <<'CPAN_META_VALIDATOR';
  4220. use 5.006;
  4221. use strict;
  4222. use warnings;
  4223. package CPAN::Meta::Validator;
  4224. our $VERSION = '2.120921'; # VERSION
  4225. #--------------------------------------------------------------------------#
  4226. # This code copied and adapted from Test::CPAN::Meta
  4227. # by Barbie, <barbie@cpan.org> for Miss Barbell Productions,
  4228. # L<http://www.missbarbell.co.uk>
  4229. #--------------------------------------------------------------------------#
  4230. #--------------------------------------------------------------------------#
  4231. # Specification Definitions
  4232. #--------------------------------------------------------------------------#
  4233. my %known_specs = (
  4234. '1.4' => 'http://module-build.sourceforge.net/META-spec-v1.4.html',
  4235. '1.3' => 'http://module-build.sourceforge.net/META-spec-v1.3.html',
  4236. '1.2' => 'http://module-build.sourceforge.net/META-spec-v1.2.html',
  4237. '1.1' => 'http://module-build.sourceforge.net/META-spec-v1.1.html',
  4238. '1.0' => 'http://module-build.sourceforge.net/META-spec-v1.0.html'
  4239. );
  4240. my %known_urls = map {$known_specs{$_} => $_} keys %known_specs;
  4241. my $module_map1 = { 'map' => { ':key' => { name => \&module, value => \&exversion } } };
  4242. my $module_map2 = { 'map' => { ':key' => { name => \&module, value => \&version } } };
  4243. my $no_index_2 = {
  4244. 'map' => { file => { list => { value => \&string } },
  4245. directory => { list => { value => \&string } },
  4246. 'package' => { list => { value => \&string } },
  4247. namespace => { list => { value => \&string } },
  4248. ':key' => { name => \&custom_2, value => \&anything },
  4249. }
  4250. };
  4251. my $no_index_1_3 = {
  4252. 'map' => { file => { list => { value => \&string } },
  4253. directory => { list => { value => \&string } },
  4254. 'package' => { list => { value => \&string } },
  4255. namespace => { list => { value => \&string } },
  4256. ':key' => { name => \&string, value => \&anything },
  4257. }
  4258. };
  4259. my $no_index_1_2 = {
  4260. 'map' => { file => { list => { value => \&string } },
  4261. dir => { list => { value => \&string } },
  4262. 'package' => { list => { value => \&string } },
  4263. namespace => { list => { value => \&string } },
  4264. ':key' => { name => \&string, value => \&anything },
  4265. }
  4266. };
  4267. my $no_index_1_1 = {
  4268. 'map' => { ':key' => { name => \&string, list => { value => \&string } },
  4269. }
  4270. };
  4271. my $prereq_map = {
  4272. map => {
  4273. ':key' => {
  4274. name => \&phase,
  4275. 'map' => {
  4276. ':key' => {
  4277. name => \&relation,
  4278. %$module_map1,
  4279. },
  4280. },
  4281. }
  4282. },
  4283. };
  4284. my %definitions = (
  4285. '2' => {
  4286. # REQUIRED
  4287. 'abstract' => { mandatory => 1, value => \&string },
  4288. 'author' => { mandatory => 1, lazylist => { value => \&string } },
  4289. 'dynamic_config' => { mandatory => 1, value => \&boolean },
  4290. 'generated_by' => { mandatory => 1, value => \&string },
  4291. 'license' => { mandatory => 1, lazylist => { value => \&license } },
  4292. 'meta-spec' => {
  4293. mandatory => 1,
  4294. 'map' => {
  4295. version => { mandatory => 1, value => \&version},
  4296. url => { value => \&url },
  4297. ':key' => { name => \&custom_2, value => \&anything },
  4298. }
  4299. },
  4300. 'name' => { mandatory => 1, value => \&string },
  4301. 'release_status' => { mandatory => 1, value => \&release_status },
  4302. 'version' => { mandatory => 1, value => \&version },
  4303. # OPTIONAL
  4304. 'description' => { value => \&string },
  4305. 'keywords' => { lazylist => { value => \&string } },
  4306. 'no_index' => $no_index_2,
  4307. 'optional_features' => {
  4308. 'map' => {
  4309. ':key' => {
  4310. name => \&string,
  4311. 'map' => {
  4312. description => { value => \&string },
  4313. prereqs => $prereq_map,
  4314. ':key' => { name => \&custom_2, value => \&anything },
  4315. }
  4316. }
  4317. }
  4318. },
  4319. 'prereqs' => $prereq_map,
  4320. 'provides' => {
  4321. 'map' => {
  4322. ':key' => {
  4323. name => \&module,
  4324. 'map' => {
  4325. file => { mandatory => 1, value => \&file },
  4326. version => { value => \&version },
  4327. ':key' => { name => \&custom_2, value => \&anything },
  4328. }
  4329. }
  4330. }
  4331. },
  4332. 'resources' => {
  4333. 'map' => {
  4334. license => { lazylist => { value => \&url } },
  4335. homepage => { value => \&url },
  4336. bugtracker => {
  4337. 'map' => {
  4338. web => { value => \&url },
  4339. mailto => { value => \&string},
  4340. ':key' => { name => \&custom_2, value => \&anything },
  4341. }
  4342. },
  4343. repository => {
  4344. 'map' => {
  4345. web => { value => \&url },
  4346. url => { value => \&url },
  4347. type => { value => \&string },
  4348. ':key' => { name => \&custom_2, value => \&anything },
  4349. }
  4350. },
  4351. ':key' => { value => \&string, name => \&custom_2 },
  4352. }
  4353. },
  4354. # CUSTOM -- additional user defined key/value pairs
  4355. # note we can only validate the key name, as the structure is user defined
  4356. ':key' => { name => \&custom_2, value => \&anything },
  4357. },
  4358. '1.4' => {
  4359. 'meta-spec' => {
  4360. mandatory => 1,
  4361. 'map' => {
  4362. version => { mandatory => 1, value => \&version},
  4363. url => { mandatory => 1, value => \&urlspec },
  4364. ':key' => { name => \&string, value => \&anything },
  4365. },
  4366. },
  4367. 'name' => { mandatory => 1, value => \&string },
  4368. 'version' => { mandatory => 1, value => \&version },
  4369. 'abstract' => { mandatory => 1, value => \&string },
  4370. 'author' => { mandatory => 1, list => { value => \&string } },
  4371. 'license' => { mandatory => 1, value => \&license },
  4372. 'generated_by' => { mandatory => 1, value => \&string },
  4373. 'distribution_type' => { value => \&string },
  4374. 'dynamic_config' => { value => \&boolean },
  4375. 'requires' => $module_map1,
  4376. 'recommends' => $module_map1,
  4377. 'build_requires' => $module_map1,
  4378. 'configure_requires' => $module_map1,
  4379. 'conflicts' => $module_map2,
  4380. 'optional_features' => {
  4381. 'map' => {
  4382. ':key' => { name => \&string,
  4383. 'map' => { description => { value => \&string },
  4384. requires => $module_map1,
  4385. recommends => $module_map1,
  4386. build_requires => $module_map1,
  4387. conflicts => $module_map2,
  4388. ':key' => { name => \&string, value => \&anything },
  4389. }
  4390. }
  4391. }
  4392. },
  4393. 'provides' => {
  4394. 'map' => {
  4395. ':key' => { name => \&module,
  4396. 'map' => {
  4397. file => { mandatory => 1, value => \&file },
  4398. version => { value => \&version },
  4399. ':key' => { name => \&string, value => \&anything },
  4400. }
  4401. }
  4402. }
  4403. },
  4404. 'no_index' => $no_index_1_3,
  4405. 'private' => $no_index_1_3,
  4406. 'keywords' => { list => { value => \&string } },
  4407. 'resources' => {
  4408. 'map' => { license => { value => \&url },
  4409. homepage => { value => \&url },
  4410. bugtracker => { value => \&url },
  4411. repository => { value => \&url },
  4412. ':key' => { value => \&string, name => \&custom_1 },
  4413. }
  4414. },
  4415. # additional user defined key/value pairs
  4416. # note we can only validate the key name, as the structure is user defined
  4417. ':key' => { name => \&string, value => \&anything },
  4418. },
  4419. '1.3' => {
  4420. 'meta-spec' => {
  4421. mandatory => 1,
  4422. 'map' => {
  4423. version => { mandatory => 1, value => \&version},
  4424. url => { mandatory => 1, value => \&urlspec },
  4425. ':key' => { name => \&string, value => \&anything },
  4426. },
  4427. },
  4428. 'name' => { mandatory => 1, value => \&string },
  4429. 'version' => { mandatory => 1, value => \&version },
  4430. 'abstract' => { mandatory => 1, value => \&string },
  4431. 'author' => { mandatory => 1, list => { value => \&string } },
  4432. 'license' => { mandatory => 1, value => \&license },
  4433. 'generated_by' => { mandatory => 1, value => \&string },
  4434. 'distribution_type' => { value => \&string },
  4435. 'dynamic_config' => { value => \&boolean },
  4436. 'requires' => $module_map1,
  4437. 'recommends' => $module_map1,
  4438. 'build_requires' => $module_map1,
  4439. 'conflicts' => $module_map2,
  4440. 'optional_features' => {
  4441. 'map' => {
  4442. ':key' => { name => \&string,
  4443. 'map' => { description => { value => \&string },
  4444. requires => $module_map1,
  4445. recommends => $module_map1,
  4446. build_requires => $module_map1,
  4447. conflicts => $module_map2,
  4448. ':key' => { name => \&string, value => \&anything },
  4449. }
  4450. }
  4451. }
  4452. },
  4453. 'provides' => {
  4454. 'map' => {
  4455. ':key' => { name => \&module,
  4456. 'map' => {
  4457. file => { mandatory => 1, value => \&file },
  4458. version => { value => \&version },
  4459. ':key' => { name => \&string, value => \&anything },
  4460. }
  4461. }
  4462. }
  4463. },
  4464. 'no_index' => $no_index_1_3,
  4465. 'private' => $no_index_1_3,
  4466. 'keywords' => { list => { value => \&string } },
  4467. 'resources' => {
  4468. 'map' => { license => { value => \&url },
  4469. homepage => { value => \&url },
  4470. bugtracker => { value => \&url },
  4471. repository => { value => \&url },
  4472. ':key' => { value => \&string, name => \&custom_1 },
  4473. }
  4474. },
  4475. # additional user defined key/value pairs
  4476. # note we can only validate the key name, as the structure is user defined
  4477. ':key' => { name => \&string, value => \&anything },
  4478. },
  4479. # v1.2 is misleading, it seems to assume that a number of fields where created
  4480. # within v1.1, when they were created within v1.2. This may have been an
  4481. # original mistake, and that a v1.1 was retro fitted into the timeline, when
  4482. # v1.2 was originally slated as v1.1. But I could be wrong ;)
  4483. '1.2' => {
  4484. 'meta-spec' => {
  4485. mandatory => 1,
  4486. 'map' => {
  4487. version => { mandatory => 1, value => \&version},
  4488. url => { mandatory => 1, value => \&urlspec },
  4489. ':key' => { name => \&string, value => \&anything },
  4490. },
  4491. },
  4492. 'name' => { mandatory => 1, value => \&string },
  4493. 'version' => { mandatory => 1, value => \&version },
  4494. 'license' => { mandatory => 1, value => \&license },
  4495. 'generated_by' => { mandatory => 1, value => \&string },
  4496. 'author' => { mandatory => 1, list => { value => \&string } },
  4497. 'abstract' => { mandatory => 1, value => \&string },
  4498. 'distribution_type' => { value => \&string },
  4499. 'dynamic_config' => { value => \&boolean },
  4500. 'keywords' => { list => { value => \&string } },
  4501. 'private' => $no_index_1_2,
  4502. '$no_index' => $no_index_1_2,
  4503. 'requires' => $module_map1,
  4504. 'recommends' => $module_map1,
  4505. 'build_requires' => $module_map1,
  4506. 'conflicts' => $module_map2,
  4507. 'optional_features' => {
  4508. 'map' => {
  4509. ':key' => { name => \&string,
  4510. 'map' => { description => { value => \&string },
  4511. requires => $module_map1,
  4512. recommends => $module_map1,
  4513. build_requires => $module_map1,
  4514. conflicts => $module_map2,
  4515. ':key' => { name => \&string, value => \&anything },
  4516. }
  4517. }
  4518. }
  4519. },
  4520. 'provides' => {
  4521. 'map' => {
  4522. ':key' => { name => \&module,
  4523. 'map' => {
  4524. file => { mandatory => 1, value => \&file },
  4525. version => { value => \&version },
  4526. ':key' => { name => \&string, value => \&anything },
  4527. }
  4528. }
  4529. }
  4530. },
  4531. 'resources' => {
  4532. 'map' => { license => { value => \&url },
  4533. homepage => { value => \&url },
  4534. bugtracker => { value => \&url },
  4535. repository => { value => \&url },
  4536. ':key' => { value => \&string, name => \&custom_1 },
  4537. }
  4538. },
  4539. # additional user defined key/value pairs
  4540. # note we can only validate the key name, as the structure is user defined
  4541. ':key' => { name => \&string, value => \&anything },
  4542. },
  4543. # note that the 1.1 spec only specifies 'version' as mandatory
  4544. '1.1' => {
  4545. 'name' => { value => \&string },
  4546. 'version' => { mandatory => 1, value => \&version },
  4547. 'license' => { value => \&license },
  4548. 'generated_by' => { value => \&string },
  4549. 'license_uri' => { value => \&url },
  4550. 'distribution_type' => { value => \&string },
  4551. 'dynamic_config' => { value => \&boolean },
  4552. 'private' => $no_index_1_1,
  4553. 'requires' => $module_map1,
  4554. 'recommends' => $module_map1,
  4555. 'build_requires' => $module_map1,
  4556. 'conflicts' => $module_map2,
  4557. # additional user defined key/value pairs
  4558. # note we can only validate the key name, as the structure is user defined
  4559. ':key' => { name => \&string, value => \&anything },
  4560. },
  4561. # note that the 1.0 spec doesn't specify optional or mandatory fields
  4562. # but we will treat version as mandatory since otherwise META 1.0 is
  4563. # completely arbitrary and pointless
  4564. '1.0' => {
  4565. 'name' => { value => \&string },
  4566. 'version' => { mandatory => 1, value => \&version },
  4567. 'license' => { value => \&license },
  4568. 'generated_by' => { value => \&string },
  4569. 'license_uri' => { value => \&url },
  4570. 'distribution_type' => { value => \&string },
  4571. 'dynamic_config' => { value => \&boolean },
  4572. 'requires' => $module_map1,
  4573. 'recommends' => $module_map1,
  4574. 'build_requires' => $module_map1,
  4575. 'conflicts' => $module_map2,
  4576. # additional user defined key/value pairs
  4577. # note we can only validate the key name, as the structure is user defined
  4578. ':key' => { name => \&string, value => \&anything },
  4579. },
  4580. );
  4581. #--------------------------------------------------------------------------#
  4582. # Code
  4583. #--------------------------------------------------------------------------#
  4584. sub new {
  4585. my ($class,$data) = @_;
  4586. # create an attributes hash
  4587. my $self = {
  4588. 'data' => $data,
  4589. 'spec' => $data->{'meta-spec'}{'version'} || "1.0",
  4590. 'errors' => undef,
  4591. };
  4592. # create the object
  4593. return bless $self, $class;
  4594. }
  4595. sub is_valid {
  4596. my $self = shift;
  4597. my $data = $self->{data};
  4598. my $spec_version = $self->{spec};
  4599. $self->check_map($definitions{$spec_version},$data);
  4600. return ! $self->errors;
  4601. }
  4602. sub errors {
  4603. my $self = shift;
  4604. return () unless(defined $self->{errors});
  4605. return @{$self->{errors}};
  4606. }
  4607. my $spec_error = "Missing validation action in specification. "
  4608. . "Must be one of 'map', 'list', 'lazylist', or 'value'";
  4609. sub check_map {
  4610. my ($self,$spec,$data) = @_;
  4611. if(ref($spec) ne 'HASH') {
  4612. $self->_error( "Unknown META specification, cannot validate." );
  4613. return;
  4614. }
  4615. if(ref($data) ne 'HASH') {
  4616. $self->_error( "Expected a map structure from string or file." );
  4617. return;
  4618. }
  4619. for my $key (keys %$spec) {
  4620. next unless($spec->{$key}->{mandatory});
  4621. next if(defined $data->{$key});
  4622. push @{$self->{stack}}, $key;
  4623. $self->_error( "Missing mandatory field, '$key'" );
  4624. pop @{$self->{stack}};
  4625. }
  4626. for my $key (keys %$data) {
  4627. push @{$self->{stack}}, $key;
  4628. if($spec->{$key}) {
  4629. if($spec->{$key}{value}) {
  4630. $spec->{$key}{value}->($self,$key,$data->{$key});
  4631. } elsif($spec->{$key}{'map'}) {
  4632. $self->check_map($spec->{$key}{'map'},$data->{$key});
  4633. } elsif($spec->{$key}{'list'}) {
  4634. $self->check_list($spec->{$key}{'list'},$data->{$key});
  4635. } elsif($spec->{$key}{'lazylist'}) {
  4636. $self->check_lazylist($spec->{$key}{'lazylist'},$data->{$key});
  4637. } else {
  4638. $self->_error( "$spec_error for '$key'" );
  4639. }
  4640. } elsif ($spec->{':key'}) {
  4641. $spec->{':key'}{name}->($self,$key,$key);
  4642. if($spec->{':key'}{value}) {
  4643. $spec->{':key'}{value}->($self,$key,$data->{$key});
  4644. } elsif($spec->{':key'}{'map'}) {
  4645. $self->check_map($spec->{':key'}{'map'},$data->{$key});
  4646. } elsif($spec->{':key'}{'list'}) {
  4647. $self->check_list($spec->{':key'}{'list'},$data->{$key});
  4648. } elsif($spec->{':key'}{'lazylist'}) {
  4649. $self->check_lazylist($spec->{':key'}{'lazylist'},$data->{$key});
  4650. } else {
  4651. $self->_error( "$spec_error for ':key'" );
  4652. }
  4653. } else {
  4654. $self->_error( "Unknown key, '$key', found in map structure" );
  4655. }
  4656. pop @{$self->{stack}};
  4657. }
  4658. }
  4659. # if it's a string, make it into a list and check the list
  4660. sub check_lazylist {
  4661. my ($self,$spec,$data) = @_;
  4662. if ( defined $data && ! ref($data) ) {
  4663. $data = [ $data ];
  4664. }
  4665. $self->check_list($spec,$data);
  4666. }
  4667. sub check_list {
  4668. my ($self,$spec,$data) = @_;
  4669. if(ref($data) ne 'ARRAY') {
  4670. $self->_error( "Expected a list structure" );
  4671. return;
  4672. }
  4673. if(defined $spec->{mandatory}) {
  4674. if(!defined $data->[0]) {
  4675. $self->_error( "Missing entries from mandatory list" );
  4676. }
  4677. }
  4678. for my $value (@$data) {
  4679. push @{$self->{stack}}, $value || "<undef>";
  4680. if(defined $spec->{value}) {
  4681. $spec->{value}->($self,'list',$value);
  4682. } elsif(defined $spec->{'map'}) {
  4683. $self->check_map($spec->{'map'},$value);
  4684. } elsif(defined $spec->{'list'}) {
  4685. $self->check_list($spec->{'list'},$value);
  4686. } elsif(defined $spec->{'lazylist'}) {
  4687. $self->check_lazylist($spec->{'lazylist'},$value);
  4688. } elsif ($spec->{':key'}) {
  4689. $self->check_map($spec,$value);
  4690. } else {
  4691. $self->_error( "$spec_error associated with '$self->{stack}[-2]'" );
  4692. }
  4693. pop @{$self->{stack}};
  4694. }
  4695. }
  4696. sub header {
  4697. my ($self,$key,$value) = @_;
  4698. if(defined $value) {
  4699. return 1 if($value && $value =~ /^--- #YAML:1.0/);
  4700. }
  4701. $self->_error( "file does not have a valid YAML header." );
  4702. return 0;
  4703. }
  4704. sub release_status {
  4705. my ($self,$key,$value) = @_;
  4706. if(defined $value) {
  4707. my $version = $self->{data}{version} || '';
  4708. if ( $version =~ /_/ ) {
  4709. return 1 if ( $value =~ /\A(?:testing|unstable)\z/ );
  4710. $self->_error( "'$value' for '$key' is invalid for version '$version'" );
  4711. }
  4712. else {
  4713. return 1 if ( $value =~ /\A(?:stable|testing|unstable)\z/ );
  4714. $self->_error( "'$value' for '$key' is invalid" );
  4715. }
  4716. }
  4717. else {
  4718. $self->_error( "'$key' is not defined" );
  4719. }
  4720. return 0;
  4721. }
  4722. # _uri_split taken from URI::Split by Gisle Aas, Copyright 2003
  4723. sub _uri_split {
  4724. return $_[0] =~ m,(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?,;
  4725. }
  4726. sub url {
  4727. my ($self,$key,$value) = @_;
  4728. if(defined $value) {
  4729. my ($scheme, $auth, $path, $query, $frag) = _uri_split($value);
  4730. unless ( defined $scheme && length $scheme ) {
  4731. $self->_error( "'$value' for '$key' does not have a URL scheme" );
  4732. return 0;
  4733. }
  4734. unless ( defined $auth && length $auth ) {
  4735. $self->_error( "'$value' for '$key' does not have a URL authority" );
  4736. return 0;
  4737. }
  4738. return 1;
  4739. }
  4740. $value ||= '';
  4741. $self->_error( "'$value' for '$key' is not a valid URL." );
  4742. return 0;
  4743. }
  4744. sub urlspec {
  4745. my ($self,$key,$value) = @_;
  4746. if(defined $value) {
  4747. return 1 if($value && $known_specs{$self->{spec}} eq $value);
  4748. if($value && $known_urls{$value}) {
  4749. $self->_error( 'META specification URL does not match version' );
  4750. return 0;
  4751. }
  4752. }
  4753. $self->_error( 'Unknown META specification' );
  4754. return 0;
  4755. }
  4756. sub anything { return 1 }
  4757. sub string {
  4758. my ($self,$key,$value) = @_;
  4759. if(defined $value) {
  4760. return 1 if($value || $value =~ /^0$/);
  4761. }
  4762. $self->_error( "value is an undefined string" );
  4763. return 0;
  4764. }
  4765. sub string_or_undef {
  4766. my ($self,$key,$value) = @_;
  4767. return 1 unless(defined $value);
  4768. return 1 if($value || $value =~ /^0$/);
  4769. $self->_error( "No string defined for '$key'" );
  4770. return 0;
  4771. }
  4772. sub file {
  4773. my ($self,$key,$value) = @_;
  4774. return 1 if(defined $value);
  4775. $self->_error( "No file defined for '$key'" );
  4776. return 0;
  4777. }
  4778. sub exversion {
  4779. my ($self,$key,$value) = @_;
  4780. if(defined $value && ($value || $value =~ /0/)) {
  4781. my $pass = 1;
  4782. for(split(",",$value)) { $self->version($key,$_) or ($pass = 0); }
  4783. return $pass;
  4784. }
  4785. $value = '<undef>' unless(defined $value);
  4786. $self->_error( "'$value' for '$key' is not a valid version." );
  4787. return 0;
  4788. }
  4789. sub version {
  4790. my ($self,$key,$value) = @_;
  4791. if(defined $value) {
  4792. return 0 unless($value || $value =~ /0/);
  4793. return 1 if($value =~ /^\s*((<|<=|>=|>|!=|==)\s*)?v?\d+((\.\d+((_|\.)\d+)?)?)/);
  4794. } else {
  4795. $value = '<undef>';
  4796. }
  4797. $self->_error( "'$value' for '$key' is not a valid version." );
  4798. return 0;
  4799. }
  4800. sub boolean {
  4801. my ($self,$key,$value) = @_;
  4802. if(defined $value) {
  4803. return 1 if($value =~ /^(0|1|true|false)$/);
  4804. } else {
  4805. $value = '<undef>';
  4806. }
  4807. $self->_error( "'$value' for '$key' is not a boolean value." );
  4808. return 0;
  4809. }
  4810. my %v1_licenses = (
  4811. 'perl' => 'http://dev.perl.org/licenses/',
  4812. 'gpl' => 'http://www.opensource.org/licenses/gpl-license.php',
  4813. 'apache' => 'http://apache.org/licenses/LICENSE-2.0',
  4814. 'artistic' => 'http://opensource.org/licenses/artistic-license.php',
  4815. 'artistic_2' => 'http://opensource.org/licenses/artistic-license-2.0.php',
  4816. 'lgpl' => 'http://www.opensource.org/licenses/lgpl-license.php',
  4817. 'bsd' => 'http://www.opensource.org/licenses/bsd-license.php',
  4818. 'gpl' => 'http://www.opensource.org/licenses/gpl-license.php',
  4819. 'mit' => 'http://opensource.org/licenses/mit-license.php',
  4820. 'mozilla' => 'http://opensource.org/licenses/mozilla1.1.php',
  4821. 'open_source' => undef,
  4822. 'unrestricted' => undef,
  4823. 'restrictive' => undef,
  4824. 'unknown' => undef,
  4825. );
  4826. my %v2_licenses = map { $_ => 1 } qw(
  4827. agpl_3
  4828. apache_1_1
  4829. apache_2_0
  4830. artistic_1
  4831. artistic_2
  4832. bsd
  4833. freebsd
  4834. gfdl_1_2
  4835. gfdl_1_3
  4836. gpl_1
  4837. gpl_2
  4838. gpl_3
  4839. lgpl_2_1
  4840. lgpl_3_0
  4841. mit
  4842. mozilla_1_0
  4843. mozilla_1_1
  4844. openssl
  4845. perl_5
  4846. qpl_1_0
  4847. ssleay
  4848. sun
  4849. zlib
  4850. open_source
  4851. restricted
  4852. unrestricted
  4853. unknown
  4854. );
  4855. sub license {
  4856. my ($self,$key,$value) = @_;
  4857. my $licenses = $self->{spec} < 2 ? \%v1_licenses : \%v2_licenses;
  4858. if(defined $value) {
  4859. return 1 if($value && exists $licenses->{$value});
  4860. } else {
  4861. $value = '<undef>';
  4862. }
  4863. $self->_error( "License '$value' is invalid" );
  4864. return 0;
  4865. }
  4866. sub custom_1 {
  4867. my ($self,$key) = @_;
  4868. if(defined $key) {
  4869. # a valid user defined key should be alphabetic
  4870. # and contain at least one capital case letter.
  4871. return 1 if($key && $key =~ /^[_a-z]+$/i && $key =~ /[A-Z]/);
  4872. } else {
  4873. $key = '<undef>';
  4874. }
  4875. $self->_error( "Custom resource '$key' must be in CamelCase." );
  4876. return 0;
  4877. }
  4878. sub custom_2 {
  4879. my ($self,$key) = @_;
  4880. if(defined $key) {
  4881. return 1 if($key && $key =~ /^x_/i); # user defined
  4882. } else {
  4883. $key = '<undef>';
  4884. }
  4885. $self->_error( "Custom key '$key' must begin with 'x_' or 'X_'." );
  4886. return 0;
  4887. }
  4888. sub identifier {
  4889. my ($self,$key) = @_;
  4890. if(defined $key) {
  4891. return 1 if($key && $key =~ /^([a-z][_a-z]+)$/i); # spec 2.0 defined
  4892. } else {
  4893. $key = '<undef>';
  4894. }
  4895. $self->_error( "Key '$key' is not a legal identifier." );
  4896. return 0;
  4897. }
  4898. sub module {
  4899. my ($self,$key) = @_;
  4900. if(defined $key) {
  4901. return 1 if($key && $key =~ /^[A-Za-z0-9_]+(::[A-Za-z0-9_]+)*$/);
  4902. } else {
  4903. $key = '<undef>';
  4904. }
  4905. $self->_error( "Key '$key' is not a legal module name." );
  4906. return 0;
  4907. }
  4908. my @valid_phases = qw/ configure build test runtime develop /;
  4909. sub phase {
  4910. my ($self,$key) = @_;
  4911. if(defined $key) {
  4912. return 1 if( length $key && grep { $key eq $_ } @valid_phases );
  4913. return 1 if $key =~ /x_/i;
  4914. } else {
  4915. $key = '<undef>';
  4916. }
  4917. $self->_error( "Key '$key' is not a legal phase." );
  4918. return 0;
  4919. }
  4920. my @valid_relations = qw/ requires recommends suggests conflicts /;
  4921. sub relation {
  4922. my ($self,$key) = @_;
  4923. if(defined $key) {
  4924. return 1 if( length $key && grep { $key eq $_ } @valid_relations );
  4925. return 1 if $key =~ /x_/i;
  4926. } else {
  4927. $key = '<undef>';
  4928. }
  4929. $self->_error( "Key '$key' is not a legal prereq relationship." );
  4930. return 0;
  4931. }
  4932. sub _error {
  4933. my $self = shift;
  4934. my $mess = shift;
  4935. $mess .= ' ('.join(' -> ',@{$self->{stack}}).')' if($self->{stack});
  4936. $mess .= " [Validation: $self->{spec}]";
  4937. push @{$self->{errors}}, $mess;
  4938. }
  4939. 1;
  4940. # ABSTRACT: validate CPAN distribution metadata structures
  4941. __END__
  4942. CPAN_META_VALIDATOR
  4943.  
  4944. $fatpacked{"CPAN/Meta/YAML.pm"} = <<'CPAN_META_YAML';
  4945. package CPAN::Meta::YAML;
  4946. {
  4947. $CPAN::Meta::YAML::VERSION = '0.008';
  4948. }
  4949. use strict;
  4950. # UTF Support?
  4951. sub HAVE_UTF8 () { $] >= 5.007003 }
  4952. BEGIN {
  4953. if ( HAVE_UTF8 ) {
  4954. # The string eval helps hide this from Test::MinimumVersion
  4955. eval "require utf8;";
  4956. die "Failed to load UTF-8 support" if $@;
  4957. }
  4958. # Class structure
  4959. require 5.004;
  4960. require Exporter;
  4961. require Carp;
  4962. @CPAN::Meta::YAML::ISA = qw{ Exporter };
  4963. @CPAN::Meta::YAML::EXPORT = qw{ Load Dump };
  4964. @CPAN::Meta::YAML::EXPORT_OK = qw{ LoadFile DumpFile freeze thaw };
  4965. # Error storage
  4966. $CPAN::Meta::YAML::errstr = '';
  4967. }
  4968. # The character class of all characters we need to escape
  4969. # NOTE: Inlined, since it's only used once
  4970. # my $RE_ESCAPE = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f\"\n]';
  4971. # Printed form of the unprintable characters in the lowest range
  4972. # of ASCII characters, listed by ASCII ordinal position.
  4973. my @UNPRINTABLE = qw(
  4974. z x01 x02 x03 x04 x05 x06 a
  4975. x08 t n v f r x0e x0f
  4976. x10 x11 x12 x13 x14 x15 x16 x17
  4977. x18 x19 x1a e x1c x1d x1e x1f
  4978. );
  4979. # Printable characters for escapes
  4980. my %UNESCAPES = (
  4981. z => "\x00", a => "\x07", t => "\x09",
  4982. n => "\x0a", v => "\x0b", f => "\x0c",
  4983. r => "\x0d", e => "\x1b", '\\' => '\\',
  4984. );
  4985. # Special magic boolean words
  4986. my %QUOTE = map { $_ => 1 } qw{
  4987. null Null NULL
  4988. y Y yes Yes YES n N no No NO
  4989. true True TRUE false False FALSE
  4990. on On ON off Off OFF
  4991. };
  4992. #####################################################################
  4993. # Implementation
  4994. # Create an empty CPAN::Meta::YAML object
  4995. sub new {
  4996. my $class = shift;
  4997. bless [ @_ ], $class;
  4998. }
  4999. # Create an object from a file
  5000. sub read {
  5001. my $class = ref $_[0] ? ref shift : shift;
  5002. # Check the file
  5003. my $file = shift or return $class->_error( 'You did not specify a file name' );
  5004. return $class->_error( "File '$file' does not exist" ) unless -e $file;
  5005. return $class->_error( "'$file' is a directory, not a file" ) unless -f _;
  5006. return $class->_error( "Insufficient permissions to read '$file'" ) unless -r _;
  5007. # Slurp in the file
  5008. local $/ = undef;
  5009. local *CFG;
  5010. unless ( open(CFG, $file) ) {
  5011. return $class->_error("Failed to open file '$file': $!");
  5012. }
  5013. my $contents = <CFG>;
  5014. unless ( close(CFG) ) {
  5015. return $class->_error("Failed to close file '$file': $!");
  5016. }
  5017. $class->read_string( $contents );
  5018. }
  5019. # Create an object from a string
  5020. sub read_string {
  5021. my $class = ref $_[0] ? ref shift : shift;
  5022. my $self = bless [], $class;
  5023. my $string = $_[0];
  5024. eval {
  5025. unless ( defined $string ) {
  5026. die \"Did not provide a string to load";
  5027. }
  5028. # Byte order marks
  5029. # NOTE: Keeping this here to educate maintainers
  5030. # my %BOM = (
  5031. # "\357\273\277" => 'UTF-8',
  5032. # "\376\377" => 'UTF-16BE',
  5033. # "\377\376" => 'UTF-16LE',
  5034. # "\377\376\0\0" => 'UTF-32LE'
  5035. # "\0\0\376\377" => 'UTF-32BE',
  5036. # );
  5037. if ( $string =~ /^(?:\376\377|\377\376|\377\376\0\0|\0\0\376\377)/ ) {
  5038. die \"Stream has a non UTF-8 BOM";
  5039. } else {
  5040. # Strip UTF-8 bom if found, we'll just ignore it
  5041. $string =~ s/^\357\273\277//;
  5042. }
  5043. # Try to decode as utf8
  5044. utf8::decode($string) if HAVE_UTF8;
  5045. # Check for some special cases
  5046. return $self unless length $string;
  5047. unless ( $string =~ /[\012\015]+\z/ ) {
  5048. die \"Stream does not end with newline character";
  5049. }
  5050. # Split the file into lines
  5051. my @lines = grep { ! /^\s*(?:\#.*)?\z/ }
  5052. split /(?:\015{1,2}\012|\015|\012)/, $string;
  5053. # Strip the initial YAML header
  5054. @lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines;
  5055. # A nibbling parser
  5056. while ( @lines ) {
  5057. # Do we have a document header?
  5058. if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) {
  5059. # Handle scalar documents
  5060. shift @lines;
  5061. if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) {
  5062. push @$self, $self->_read_scalar( "$1", [ undef ], \@lines );
  5063. next;
  5064. }
  5065. }
  5066. if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) {
  5067. # A naked document
  5068. push @$self, undef;
  5069. while ( @lines and $lines[0] !~ /^---/ ) {
  5070. shift @lines;
  5071. }
  5072. } elsif ( $lines[0] =~ /^\s*\-/ ) {
  5073. # An array at the root
  5074. my $document = [ ];
  5075. push @$self, $document;
  5076. $self->_read_array( $document, [ 0 ], \@lines );
  5077. } elsif ( $lines[0] =~ /^(\s*)\S/ ) {
  5078. # A hash at the root
  5079. my $document = { };
  5080. push @$self, $document;
  5081. $self->_read_hash( $document, [ length($1) ], \@lines );
  5082. } else {
  5083. die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'";
  5084. }
  5085. }
  5086. };
  5087. if ( ref $@ eq 'SCALAR' ) {
  5088. return $self->_error(${$@});
  5089. } elsif ( $@ ) {
  5090. require Carp;
  5091. Carp::croak($@);
  5092. }
  5093. return $self;
  5094. }
  5095. # Deparse a scalar string to the actual scalar
  5096. sub _read_scalar {
  5097. my ($self, $string, $indent, $lines) = @_;
  5098. # Trim trailing whitespace
  5099. $string =~ s/\s*\z//;
  5100. # Explitic null/undef
  5101. return undef if $string eq '~';
  5102. # Single quote
  5103. if ( $string =~ /^\'(.*?)\'(?:\s+\#.*)?\z/ ) {
  5104. return '' unless defined $1;
  5105. $string = $1;
  5106. $string =~ s/\'\'/\'/g;
  5107. return $string;
  5108. }
  5109. # Double quote.
  5110. # The commented out form is simpler, but overloaded the Perl regex
  5111. # engine due to recursion and backtracking problems on strings
  5112. # larger than 32,000ish characters. Keep it for reference purposes.
  5113. # if ( $string =~ /^\"((?:\\.|[^\"])*)\"\z/ ) {
  5114. if ( $string =~ /^\"([^\\"]*(?:\\.[^\\"]*)*)\"(?:\s+\#.*)?\z/ ) {
  5115. # Reusing the variable is a little ugly,
  5116. # but avoids a new variable and a string copy.
  5117. $string = $1;
  5118. $string =~ s/\\"/"/g;
  5119. $string =~ s/\\([never\\fartz]|x([0-9a-fA-F]{2}))/(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}/gex;
  5120. return $string;
  5121. }
  5122. # Special cases
  5123. if ( $string =~ /^[\'\"!&]/ ) {
  5124. die \"CPAN::Meta::YAML does not support a feature in line '$string'";
  5125. }
  5126. return {} if $string =~ /^{}(?:\s+\#.*)?\z/;
  5127. return [] if $string =~ /^\[\](?:\s+\#.*)?\z/;
  5128. # Regular unquoted string
  5129. if ( $string !~ /^[>|]/ ) {
  5130. if (
  5131. $string =~ /^(?:-(?:\s|$)|[\@\%\`])/
  5132. or
  5133. $string =~ /:(?:\s|$)/
  5134. ) {
  5135. die \"CPAN::Meta::YAML found illegal characters in plain scalar: '$string'";
  5136. }
  5137. $string =~ s/\s+#.*\z//;
  5138. return $string;
  5139. }
  5140. # Error
  5141. die \"CPAN::Meta::YAML failed to find multi-line scalar content" unless @$lines;
  5142. # Check the indent depth
  5143. $lines->[0] =~ /^(\s*)/;
  5144. $indent->[-1] = length("$1");
  5145. if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) {
  5146. die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
  5147. }
  5148. # Pull the lines
  5149. my @multiline = ();
  5150. while ( @$lines ) {
  5151. $lines->[0] =~ /^(\s*)/;
  5152. last unless length($1) >= $indent->[-1];
  5153. push @multiline, substr(shift(@$lines), length($1));
  5154. }
  5155. my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n";
  5156. my $t = (substr($string, 1, 1) eq '-') ? '' : "\n";
  5157. return join( $j, @multiline ) . $t;
  5158. }
  5159. # Parse an array
  5160. sub _read_array {
  5161. my ($self, $array, $indent, $lines) = @_;
  5162. while ( @$lines ) {
  5163. # Check for a new document
  5164. if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
  5165. while ( @$lines and $lines->[0] !~ /^---/ ) {
  5166. shift @$lines;
  5167. }
  5168. return 1;
  5169. }
  5170. # Check the indent level
  5171. $lines->[0] =~ /^(\s*)/;
  5172. if ( length($1) < $indent->[-1] ) {
  5173. return 1;
  5174. } elsif ( length($1) > $indent->[-1] ) {
  5175. die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
  5176. }
  5177. if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) {
  5178. # Inline nested hash
  5179. my $indent2 = length("$1");
  5180. $lines->[0] =~ s/-/ /;
  5181. push @$array, { };
  5182. $self->_read_hash( $array->[-1], [ @$indent, $indent2 ], $lines );
  5183. } elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) {
  5184. # Array entry with a value
  5185. shift @$lines;
  5186. push @$array, $self->_read_scalar( "$2", [ @$indent, undef ], $lines );
  5187. } elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) {
  5188. shift @$lines;
  5189. unless ( @$lines ) {
  5190. push @$array, undef;
  5191. return 1;
  5192. }
  5193. if ( $lines->[0] =~ /^(\s*)\-/ ) {
  5194. my $indent2 = length("$1");
  5195. if ( $indent->[-1] == $indent2 ) {
  5196. # Null array entry
  5197. push @$array, undef;
  5198. } else {
  5199. # Naked indenter
  5200. push @$array, [ ];
  5201. $self->_read_array( $array->[-1], [ @$indent, $indent2 ], $lines );
  5202. }
  5203. } elsif ( $lines->[0] =~ /^(\s*)\S/ ) {
  5204. push @$array, { };
  5205. $self->_read_hash( $array->[-1], [ @$indent, length("$1") ], $lines );
  5206. } else {
  5207. die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
  5208. }
  5209. } elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) {
  5210. # This is probably a structure like the following...
  5211. # ---
  5212. # foo:
  5213. # - list
  5214. # bar: value
  5215. #
  5216. # ... so lets return and let the hash parser handle it
  5217. return 1;
  5218. } else {
  5219. die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
  5220. }
  5221. }
  5222. return 1;
  5223. }
  5224. # Parse an array
  5225. sub _read_hash {
  5226. my ($self, $hash, $indent, $lines) = @_;
  5227. while ( @$lines ) {
  5228. # Check for a new document
  5229. if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
  5230. while ( @$lines and $lines->[0] !~ /^---/ ) {
  5231. shift @$lines;
  5232. }
  5233. return 1;
  5234. }
  5235. # Check the indent level
  5236. $lines->[0] =~ /^(\s*)/;
  5237. if ( length($1) < $indent->[-1] ) {
  5238. return 1;
  5239. } elsif ( length($1) > $indent->[-1] ) {
  5240. die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
  5241. }
  5242. # Get the key
  5243. unless ( $lines->[0] =~ s/^\s*([^\'\" ][^\n]*?)\s*:(\s+(?:\#.*)?|$)// ) {
  5244. if ( $lines->[0] =~ /^\s*[?\'\"]/ ) {
  5245. die \"CPAN::Meta::YAML does not support a feature in line '$lines->[0]'";
  5246. }
  5247. die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
  5248. }
  5249. my $key = $1;
  5250. # Do we have a value?
  5251. if ( length $lines->[0] ) {
  5252. # Yes
  5253. $hash->{$key} = $self->_read_scalar( shift(@$lines), [ @$indent, undef ], $lines );
  5254. } else {
  5255. # An indent
  5256. shift @$lines;
  5257. unless ( @$lines ) {
  5258. $hash->{$key} = undef;
  5259. return 1;
  5260. }
  5261. if ( $lines->[0] =~ /^(\s*)-/ ) {
  5262. $hash->{$key} = [];
  5263. $self->_read_array( $hash->{$key}, [ @$indent, length($1) ], $lines );
  5264. } elsif ( $lines->[0] =~ /^(\s*)./ ) {
  5265. my $indent2 = length("$1");
  5266. if ( $indent->[-1] >= $indent2 ) {
  5267. # Null hash entry
  5268. $hash->{$key} = undef;
  5269. } else {
  5270. $hash->{$key} = {};
  5271. $self->_read_hash( $hash->{$key}, [ @$indent, length($1) ], $lines );
  5272. }
  5273. }
  5274. }
  5275. }
  5276. return 1;
  5277. }
  5278. # Save an object to a file
  5279. sub write {
  5280. my $self = shift;
  5281. my $file = shift or return $self->_error('No file name provided');
  5282. # Write it to the file
  5283. open( CFG, '>' . $file ) or return $self->_error(
  5284. "Failed to open file '$file' for writing: $!"
  5285. );
  5286. print CFG $self->write_string;
  5287. close CFG;
  5288. return 1;
  5289. }
  5290. # Save an object to a string
  5291. sub write_string {
  5292. my $self = shift;
  5293. return '' unless @$self;
  5294. # Iterate over the documents
  5295. my $indent = 0;
  5296. my @lines = ();
  5297. foreach my $cursor ( @$self ) {
  5298. push @lines, '---';
  5299. # An empty document
  5300. if ( ! defined $cursor ) {
  5301. # Do nothing
  5302. # A scalar document
  5303. } elsif ( ! ref $cursor ) {
  5304. $lines[-1] .= ' ' . $self->_write_scalar( $cursor, $indent );
  5305. # A list at the root
  5306. } elsif ( ref $cursor eq 'ARRAY' ) {
  5307. unless ( @$cursor ) {
  5308. $lines[-1] .= ' []';
  5309. next;
  5310. }
  5311. push @lines, $self->_write_array( $cursor, $indent, {} );
  5312. # A hash at the root
  5313. } elsif ( ref $cursor eq 'HASH' ) {
  5314. unless ( %$cursor ) {
  5315. $lines[-1] .= ' {}';
  5316. next;
  5317. }
  5318. push @lines, $self->_write_hash( $cursor, $indent, {} );
  5319. } else {
  5320. Carp::croak("Cannot serialize " . ref($cursor));
  5321. }
  5322. }
  5323. join '', map { "$_\n" } @lines;
  5324. }
  5325. sub _write_scalar {
  5326. my $string = $_[1];
  5327. return '~' unless defined $string;
  5328. return "''" unless length $string;
  5329. if ( $string =~ /[\x00-\x08\x0b-\x0d\x0e-\x1f\"\'\n]/ ) {
  5330. $string =~ s/\\/\\\\/g;
  5331. $string =~ s/"/\\"/g;
  5332. $string =~ s/\n/\\n/g;
  5333. $string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g;
  5334. return qq|"$string"|;
  5335. }
  5336. if ( $string =~ /(?:^\W|\s|:\z)/ or $QUOTE{$string} ) {
  5337. return "'$string'";
  5338. }
  5339. return $string;
  5340. }
  5341. sub _write_array {
  5342. my ($self, $array, $indent, $seen) = @_;
  5343. if ( $seen->{refaddr($array)}++ ) {
  5344. die "CPAN::Meta::YAML does not support circular references";
  5345. }
  5346. my @lines = ();
  5347. foreach my $el ( @$array ) {
  5348. my $line = (' ' x $indent) . '-';
  5349. my $type = ref $el;
  5350. if ( ! $type ) {
  5351. $line .= ' ' . $self->_write_scalar( $el, $indent + 1 );
  5352. push @lines, $line;
  5353. } elsif ( $type eq 'ARRAY' ) {
  5354. if ( @$el ) {
  5355. push @lines, $line;
  5356. push @lines, $self->_write_array( $el, $indent + 1, $seen );
  5357. } else {
  5358. $line .= ' []';
  5359. push @lines, $line;
  5360. }
  5361. } elsif ( $type eq 'HASH' ) {
  5362. if ( keys %$el ) {
  5363. push @lines, $line;
  5364. push @lines, $self->_write_hash( $el, $indent + 1, $seen );
  5365. } else {
  5366. $line .= ' {}';
  5367. push @lines, $line;
  5368. }
  5369. } else {
  5370. die "CPAN::Meta::YAML does not support $type references";
  5371. }
  5372. }
  5373. @lines;
  5374. }
  5375. sub _write_hash {
  5376. my ($self, $hash, $indent, $seen) = @_;
  5377. if ( $seen->{refaddr($hash)}++ ) {
  5378. die "CPAN::Meta::YAML does not support circular references";
  5379. }
  5380. my @lines = ();
  5381. foreach my $name ( sort keys %$hash ) {
  5382. my $el = $hash->{$name};
  5383. my $line = (' ' x $indent) . "$name:";
  5384. my $type = ref $el;
  5385. if ( ! $type ) {
  5386. $line .= ' ' . $self->_write_scalar( $el, $indent + 1 );
  5387. push @lines, $line;
  5388. } elsif ( $type eq 'ARRAY' ) {
  5389. if ( @$el ) {
  5390. push @lines, $line;
  5391. push @lines, $self->_write_array( $el, $indent + 1, $seen );
  5392. } else {
  5393. $line .= ' []';
  5394. push @lines, $line;
  5395. }
  5396. } elsif ( $type eq 'HASH' ) {
  5397. if ( keys %$el ) {
  5398. push @lines, $line;
  5399. push @lines, $self->_write_hash( $el, $indent + 1, $seen );
  5400. } else {
  5401. $line .= ' {}';
  5402. push @lines, $line;
  5403. }
  5404. } else {
  5405. die "CPAN::Meta::YAML does not support $type references";
  5406. }
  5407. }
  5408. @lines;
  5409. }
  5410. # Set error
  5411. sub _error {
  5412. $CPAN::Meta::YAML::errstr = $_[1];
  5413. undef;
  5414. }
  5415. # Retrieve error
  5416. sub errstr {
  5417. $CPAN::Meta::YAML::errstr;
  5418. }
  5419. #####################################################################
  5420. # YAML Compatibility
  5421. sub Dump {
  5422. CPAN::Meta::YAML->new(@_)->write_string;
  5423. }
  5424. sub Load {
  5425. my $self = CPAN::Meta::YAML->read_string(@_);
  5426. unless ( $self ) {
  5427. Carp::croak("Failed to load YAML document from string");
  5428. }
  5429. if ( wantarray ) {
  5430. return @$self;
  5431. } else {
  5432. # To match YAML.pm, return the last document
  5433. return $self->[-1];
  5434. }
  5435. }
  5436. BEGIN {
  5437. *freeze = *Dump;
  5438. *thaw = *Load;
  5439. }
  5440. sub DumpFile {
  5441. my $file = shift;
  5442. CPAN::Meta::YAML->new(@_)->write($file);
  5443. }
  5444. sub LoadFile {
  5445. my $self = CPAN::Meta::YAML->read($_[0]);
  5446. unless ( $self ) {
  5447. Carp::croak("Failed to load YAML document from '" . ($_[0] || '') . "'");
  5448. }
  5449. if ( wantarray ) {
  5450. return @$self;
  5451. } else {
  5452. # Return only the last document to match YAML.pm,
  5453. return $self->[-1];
  5454. }
  5455. }
  5456. #####################################################################
  5457. # Use Scalar::Util if possible, otherwise emulate it
  5458. BEGIN {
  5459. local $@;
  5460. eval {
  5461. require Scalar::Util;
  5462. };
  5463. my $v = eval("$Scalar::Util::VERSION") || 0;
  5464. if ( $@ or $v < 1.18 ) {
  5465. eval <<'END_PERL';
  5466. # Scalar::Util failed to load or too old
  5467. sub refaddr {
  5468. my $pkg = ref($_[0]) or return undef;
  5469. if ( !! UNIVERSAL::can($_[0], 'can') ) {
  5470. bless $_[0], 'Scalar::Util::Fake';
  5471. } else {
  5472. $pkg = undef;
  5473. }
  5474. "$_[0]" =~ /0x(\w+)/;
  5475. my $i = do { local $^W; hex $1 };
  5476. bless $_[0], $pkg if defined $pkg;
  5477. $i;
  5478. }
  5479. END_PERL
  5480. } else {
  5481. *refaddr = *Scalar::Util::refaddr;
  5482. }
  5483. }
  5484. 1;
  5485. __END__
  5486. # ABSTRACT: Read and write a subset of YAML for CPAN Meta files
  5487. CPAN_META_YAML
  5488.  
  5489. $fatpacked{"File/pushd.pm"} = <<'FILE_PUSHD';
  5490. use strict;
  5491. use warnings;
  5492. package File::pushd;
  5493. # ABSTRACT: change directory temporarily for a limited scope
  5494. our $VERSION = '1.004'; # VERSION
  5495. our @EXPORT = qw( pushd tempd );
  5496. our @ISA = qw( Exporter );
  5497. use Exporter;
  5498. use Carp;
  5499. use Cwd qw( cwd abs_path );
  5500. use File::Path qw( rmtree );
  5501. use File::Temp qw();
  5502. use File::Spec;
  5503. use overload
  5504. q{""} => sub { File::Spec->canonpath( $_[0]->{_pushd} ) },
  5505. fallback => 1;
  5506. #--------------------------------------------------------------------------#
  5507. # pushd()
  5508. #--------------------------------------------------------------------------#
  5509. sub pushd {
  5510. my ($target_dir, $options) = @_;
  5511. $options->{untaint_pattern} ||= qr{^([-+@\w./]+)$};
  5512. my $tainted_orig = cwd;
  5513. my $orig;
  5514. if ( $tainted_orig =~ $options->{untaint_pattern} ) {
  5515. $orig = $1;
  5516. }
  5517. else {
  5518. $orig = $tainted_orig;
  5519. }
  5520. my $tainted_dest;
  5521. eval { $tainted_dest = $target_dir ? abs_path( $target_dir ) : $orig };
  5522. croak "Can't locate directory $target_dir: $@" if $@;
  5523. my $dest;
  5524. if ( $tainted_dest =~ $options->{untaint_pattern} ) {
  5525. $dest = $1;
  5526. }
  5527. else {
  5528. $dest = $tainted_dest;
  5529. }
  5530. if ($dest ne $orig) {
  5531. chdir $dest or croak "Can't chdir to $dest\: $!";
  5532. }
  5533. my $self = bless {
  5534. _pushd => $dest,
  5535. _original => $orig
  5536. }, __PACKAGE__;
  5537. return $self;
  5538. }
  5539. #--------------------------------------------------------------------------#
  5540. # tempd()
  5541. #--------------------------------------------------------------------------#
  5542. sub tempd {
  5543. my ($options) = @_;
  5544. my $dir;
  5545. eval { $dir = pushd( File::Temp::tempdir( CLEANUP => 0 ), $options ) };
  5546. croak $@ if $@;
  5547. $dir->{_tempd} = 1;
  5548. return $dir;
  5549. }
  5550. #--------------------------------------------------------------------------#
  5551. # preserve()
  5552. #--------------------------------------------------------------------------#
  5553. sub preserve {
  5554. my $self = shift;
  5555. return 1 if ! $self->{"_tempd"};
  5556. if ( @_ == 0 ) {
  5557. return $self->{_preserve} = 1;
  5558. }
  5559. else {
  5560. return $self->{_preserve} = $_[0] ? 1 : 0;
  5561. }
  5562. }
  5563. #--------------------------------------------------------------------------#
  5564. # DESTROY()
  5565. # Revert to original directory as object is destroyed and cleanup
  5566. # if necessary
  5567. #--------------------------------------------------------------------------#
  5568. sub DESTROY {
  5569. my ($self) = @_;
  5570. my $orig = $self->{_original};
  5571. chdir $orig if $orig; # should always be so, but just in case...
  5572. if ( $self->{_tempd} &&
  5573. !$self->{_preserve} ) {
  5574. # don't destroy existing $@ if there is no error.
  5575. my $err = do {
  5576. local $@;
  5577. eval { rmtree( $self->{_pushd} ) };
  5578. $@;
  5579. };
  5580. carp $err if $err;
  5581. }
  5582. }
  5583. 1;
  5584. __END__
  5585. FILE_PUSHD
  5586.  
  5587. $fatpacked{"HTTP/Tiny.pm"} = <<'HTTP_TINY';
  5588. # vim: ts=4 sts=4 sw=4 et:
  5589. package HTTP::Tiny;
  5590. use strict;
  5591. use warnings;
  5592. # ABSTRACT: A small, simple, correct HTTP/1.1 client
  5593. our $VERSION = '0.028'; # VERSION
  5594. use Carp ();
  5595. my @attributes;
  5596. BEGIN {
  5597. @attributes = qw(agent cookie_jar default_headers local_address max_redirect max_size proxy timeout SSL_options verify_SSL);
  5598. no strict 'refs';
  5599. for my $accessor ( @attributes ) {
  5600. *{$accessor} = sub {
  5601. @_ > 1 ? $_[0]->{$accessor} = $_[1] : $_[0]->{$accessor};
  5602. };
  5603. }
  5604. }
  5605. sub new {
  5606. my($class, %args) = @_;
  5607. (my $default_agent = $class) =~ s{::}{-}g;
  5608. $default_agent .= "/" . ($class->VERSION || 0);
  5609. my $self = {
  5610. agent => $default_agent,
  5611. max_redirect => 5,
  5612. timeout => 60,
  5613. verify_SSL => $args{verify_SSL} || $args{verify_ssl} || 0, # no verification by default
  5614. };
  5615. $args{agent} .= $default_agent
  5616. if defined $args{agent} && $args{agent} =~ / $/;
  5617. $class->_validate_cookie_jar( $args{cookie_jar} ) if $args{cookie_jar};
  5618. for my $key ( @attributes ) {
  5619. $self->{$key} = $args{$key} if exists $args{$key}
  5620. }
  5621. # Never override proxy argument as this breaks backwards compat.
  5622. if (!exists $self->{proxy} && (my $http_proxy = $ENV{http_proxy})) {
  5623. if ($http_proxy =~ m{\Ahttp://[^/?#:@]+:\d+/?\z}) {
  5624. $self->{proxy} = $http_proxy;
  5625. }
  5626. else {
  5627. Carp::croak(qq{Environment 'http_proxy' must be in format http://<host>:<port>/\n});
  5628. }
  5629. }
  5630. return bless $self, $class;
  5631. }
  5632. for my $sub_name ( qw/get head put post delete/ ) {
  5633. my $req_method = uc $sub_name;
  5634. no strict 'refs';
  5635. eval <<"HERE"; ## no critic
  5636. sub $sub_name {
  5637. my (\$self, \$url, \$args) = \@_;
  5638. \@_ == 2 || (\@_ == 3 && ref \$args eq 'HASH')
  5639. or Carp::croak(q/Usage: \$http->$sub_name(URL, [HASHREF])/ . "\n");
  5640. return \$self->request('$req_method', \$url, \$args || {});
  5641. }
  5642. HERE
  5643. }
  5644. sub post_form {
  5645. my ($self, $url, $data, $args) = @_;
  5646. (@_ == 3 || @_ == 4 && ref $args eq 'HASH')
  5647. or Carp::croak(q/Usage: $http->post_form(URL, DATAREF, [HASHREF])/ . "\n");
  5648. my $headers = {};
  5649. while ( my ($key, $value) = each %{$args->{headers} || {}} ) {
  5650. $headers->{lc $key} = $value;
  5651. }
  5652. delete $args->{headers};
  5653. return $self->request('POST', $url, {
  5654. %$args,
  5655. content => $self->www_form_urlencode($data),
  5656. headers => {
  5657. %$headers,
  5658. 'content-type' => 'application/x-www-form-urlencoded'
  5659. },
  5660. }
  5661. );
  5662. }
  5663. sub mirror {
  5664. my ($self, $url, $file, $args) = @_;
  5665. @_ == 3 || (@_ == 4 && ref $args eq 'HASH')
  5666. or Carp::croak(q/Usage: $http->mirror(URL, FILE, [HASHREF])/ . "\n");
  5667. if ( -e $file and my $mtime = (stat($file))[9] ) {
  5668. $args->{headers}{'if-modified-since'} ||= $self->_http_date($mtime);
  5669. }
  5670. my $tempfile = $file . int(rand(2**31));
  5671. open my $fh, ">", $tempfile
  5672. or Carp::croak(qq/Error: Could not open temporary file $tempfile for downloading: $!\n/);
  5673. binmode $fh;
  5674. $args->{data_callback} = sub { print {$fh} $_[0] };
  5675. my $response = $self->request('GET', $url, $args);
  5676. close $fh
  5677. or Carp::croak(qq/Error: Could not close temporary file $tempfile: $!\n/);
  5678. if ( $response->{success} ) {
  5679. rename $tempfile, $file
  5680. or Carp::croak(qq/Error replacing $file with $tempfile: $!\n/);
  5681. my $lm = $response->{headers}{'last-modified'};
  5682. if ( $lm and my $mtime = $self->_parse_http_date($lm) ) {
  5683. utime $mtime, $mtime, $file;
  5684. }
  5685. }
  5686. $response->{success} ||= $response->{status} eq '304';
  5687. unlink $tempfile;
  5688. return $response;
  5689. }
  5690. my %idempotent = map { $_ => 1 } qw/GET HEAD PUT DELETE OPTIONS TRACE/;
  5691. sub request {
  5692. my ($self, $method, $url, $args) = @_;
  5693. @_ == 3 || (@_ == 4 && ref $args eq 'HASH')
  5694. or Carp::croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/ . "\n");
  5695. $args ||= {}; # we keep some state in this during _request
  5696. # RFC 2616 Section 8.1.4 mandates a single retry on broken socket
  5697. my $response;
  5698. for ( 0 .. 1 ) {
  5699. $response = eval { $self->_request($method, $url, $args) };
  5700. last unless $@ && $idempotent{$method}
  5701. && $@ =~ m{^(?:Socket closed|Unexpected end)};
  5702. }
  5703. if (my $e = "$@") {
  5704. $response = {
  5705. url => $url,
  5706. success => q{},
  5707. status => 599,
  5708. reason => 'Internal Exception',
  5709. content => $e,
  5710. headers => {
  5711. 'content-type' => 'text/plain',
  5712. 'content-length' => length $e,
  5713. }
  5714. };
  5715. }
  5716. return $response;
  5717. }
  5718. sub www_form_urlencode {
  5719. my ($self, $data) = @_;
  5720. (@_ == 2 && ref $data)
  5721. or Carp::croak(q/Usage: $http->www_form_urlencode(DATAREF)/ . "\n");
  5722. (ref $data eq 'HASH' || ref $data eq 'ARRAY')
  5723. or Carp::croak("form data must be a hash or array reference\n");
  5724. my @params = ref $data eq 'HASH' ? %$data : @$data;
  5725. @params % 2 == 0
  5726. or Carp::croak("form data reference must have an even number of terms\n");
  5727. my @terms;
  5728. while( @params ) {
  5729. my ($key, $value) = splice(@params, 0, 2);
  5730. if ( ref $value eq 'ARRAY' ) {
  5731. unshift @params, map { $key => $_ } @$value;
  5732. }
  5733. else {
  5734. push @terms, join("=", map { $self->_uri_escape($_) } $key, $value);
  5735. }
  5736. }
  5737. return join("&", sort @terms);
  5738. }
  5739. #--------------------------------------------------------------------------#
  5740. # private methods
  5741. #--------------------------------------------------------------------------#
  5742. my %DefaultPort = (
  5743. http => 80,
  5744. https => 443,
  5745. );
  5746. sub _request {
  5747. my ($self, $method, $url, $args) = @_;
  5748. my ($scheme, $host, $port, $path_query) = $self->_split_url($url);
  5749. my $request = {
  5750. method => $method,
  5751. scheme => $scheme,
  5752. host_port => ($port == $DefaultPort{$scheme} ? $host : "$host:$port"),
  5753. uri => $path_query,
  5754. headers => {},
  5755. };
  5756. my $handle = HTTP::Tiny::Handle->new(
  5757. timeout => $self->{timeout},
  5758. SSL_options => $self->{SSL_options},
  5759. verify_SSL => $self->{verify_SSL},
  5760. local_address => $self->{local_address},
  5761. );
  5762. if ($self->{proxy}) {
  5763. $request->{uri} = "$scheme://$request->{host_port}$path_query";
  5764. die(qq/HTTPS via proxy is not supported\n/)
  5765. if $request->{scheme} eq 'https';
  5766. $handle->connect(($self->_split_url($self->{proxy}))[0..2]);
  5767. }
  5768. else {
  5769. $handle->connect($scheme, $host, $port);
  5770. }
  5771. $self->_prepare_headers_and_cb($request, $args, $url);
  5772. $handle->write_request($request);
  5773. my $response;
  5774. do { $response = $handle->read_response_header }
  5775. until (substr($response->{status},0,1) ne '1');
  5776. $self->_update_cookie_jar( $url, $response ) if $self->{cookie_jar};
  5777. if ( my @redir_args = $self->_maybe_redirect($request, $response, $args) ) {
  5778. $handle->close;
  5779. return $self->_request(@redir_args, $args);
  5780. }
  5781. if ($method eq 'HEAD' || $response->{status} =~ /^[23]04/) {
  5782. # response has no message body
  5783. }
  5784. else {
  5785. my $data_cb = $self->_prepare_data_cb($response, $args);
  5786. $handle->read_body($data_cb, $response);
  5787. }
  5788. $handle->close;
  5789. $response->{success} = substr($response->{status},0,1) eq '2';
  5790. $response->{url} = $url;
  5791. return $response;
  5792. }
  5793. sub _prepare_headers_and_cb {
  5794. my ($self, $request, $args, $url) = @_;
  5795. for ($self->{default_headers}, $args->{headers}) {
  5796. next unless defined;
  5797. while (my ($k, $v) = each %$_) {
  5798. $request->{headers}{lc $k} = $v;
  5799. }
  5800. }
  5801. $request->{headers}{'host'} = $request->{host_port};
  5802. $request->{headers}{'connection'} = "close";
  5803. $request->{headers}{'user-agent'} ||= $self->{agent};
  5804. if (defined $args->{content}) {
  5805. $request->{headers}{'content-type'} ||= "application/octet-stream";
  5806. if (ref $args->{content} eq 'CODE') {
  5807. $request->{headers}{'transfer-encoding'} = 'chunked'
  5808. unless $request->{headers}{'content-length'}
  5809. || $request->{headers}{'transfer-encoding'};
  5810. $request->{cb} = $args->{content};
  5811. }
  5812. else {
  5813. my $content = $args->{content};
  5814. if ( $] ge '5.008' ) {
  5815. utf8::downgrade($content, 1)
  5816. or die(qq/Wide character in request message body\n/);
  5817. }
  5818. $request->{headers}{'content-length'} = length $content
  5819. unless $request->{headers}{'content-length'}
  5820. || $request->{headers}{'transfer-encoding'};
  5821. $request->{cb} = sub { substr $content, 0, length $content, '' };
  5822. }
  5823. $request->{trailer_cb} = $args->{trailer_callback}
  5824. if ref $args->{trailer_callback} eq 'CODE';
  5825. }
  5826. ### If we have a cookie jar, then maybe add relevant cookies
  5827. if ( $self->{cookie_jar} ) {
  5828. my $cookies = $self->cookie_jar->cookie_header( $url );
  5829. $request->{headers}{cookie} = $cookies if length $cookies;
  5830. }
  5831. return;
  5832. }
  5833. sub _prepare_data_cb {
  5834. my ($self, $response, $args) = @_;
  5835. my $data_cb = $args->{data_callback};
  5836. $response->{content} = '';
  5837. if (!$data_cb || $response->{status} !~ /^2/) {
  5838. if (defined $self->{max_size}) {
  5839. $data_cb = sub {
  5840. $_[1]->{content} .= $_[0];
  5841. die(qq/Size of response body exceeds the maximum allowed of $self->{max_size}\n/)
  5842. if length $_[1]->{content} > $self->{max_size};
  5843. };
  5844. }
  5845. else {
  5846. $data_cb = sub { $_[1]->{content} .= $_[0] };
  5847. }
  5848. }
  5849. return $data_cb;
  5850. }
  5851. sub _update_cookie_jar {
  5852. my ($self, $url, $response) = @_;
  5853. my $cookies = $response->{headers}->{'set-cookie'};
  5854. return unless defined $cookies;
  5855. my @cookies = ref $cookies ? @$cookies : $cookies;
  5856. $self->cookie_jar->add( $url, $_ ) for @cookies;
  5857. return;
  5858. }
  5859. sub _validate_cookie_jar {
  5860. my ($class, $jar) = @_;
  5861. # duck typing
  5862. for my $method ( qw/add cookie_header/ ) {
  5863. Carp::croak(qq/Cookie jar must provide the '$method' method\n/)
  5864. unless ref($jar) && ref($jar)->can($method);
  5865. }
  5866. return;
  5867. }
  5868. sub _maybe_redirect {
  5869. my ($self, $request, $response, $args) = @_;
  5870. my $headers = $response->{headers};
  5871. my ($status, $method) = ($response->{status}, $request->{method});
  5872. if (($status eq '303' or ($status =~ /^30[127]/ && $method =~ /^GET|HEAD$/))
  5873. and $headers->{location}
  5874. and ++$args->{redirects} <= $self->{max_redirect}
  5875. ) {
  5876. my $location = ($headers->{location} =~ /^\//)
  5877. ? "$request->{scheme}://$request->{host_port}$headers->{location}"
  5878. : $headers->{location} ;
  5879. return (($status eq '303' ? 'GET' : $method), $location);
  5880. }
  5881. return;
  5882. }
  5883. sub _split_url {
  5884. my $url = pop;
  5885. # URI regex adapted from the URI module
  5886. my ($scheme, $authority, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)>
  5887. or die(qq/Cannot parse URL: '$url'\n/);
  5888. $scheme = lc $scheme;
  5889. $path_query = "/$path_query" unless $path_query =~ m<\A/>;
  5890. my $host = (length($authority)) ? lc $authority : 'localhost';
  5891. $host =~ s/\A[^@]*@//; # userinfo
  5892. my $port = do {
  5893. $host =~ s/:([0-9]*)\z// && length $1
  5894. ? $1
  5895. : ($scheme eq 'http' ? 80 : $scheme eq 'https' ? 443 : undef);
  5896. };
  5897. return ($scheme, $host, $port, $path_query);
  5898. }
  5899. # Date conversions adapted from HTTP::Date
  5900. my $DoW = "Sun|Mon|Tue|Wed|Thu|Fri|Sat";
  5901. my $MoY = "Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec";
  5902. sub _http_date {
  5903. my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($_[1]);
  5904. return sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT",
  5905. substr($DoW,$wday*4,3),
  5906. $mday, substr($MoY,$mon*4,3), $year+1900,
  5907. $hour, $min, $sec
  5908. );
  5909. }
  5910. sub _parse_http_date {
  5911. my ($self, $str) = @_;
  5912. require Time::Local;
  5913. my @tl_parts;
  5914. if ($str =~ /^[SMTWF][a-z]+, +(\d{1,2}) ($MoY) +(\d\d\d\d) +(\d\d):(\d\d):(\d\d) +GMT$/) {
  5915. @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3);
  5916. }
  5917. elsif ($str =~ /^[SMTWF][a-z]+, +(\d\d)-($MoY)-(\d{2,4}) +(\d\d):(\d\d):(\d\d) +GMT$/ ) {
  5918. @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3);
  5919. }
  5920. elsif ($str =~ /^[SMTWF][a-z]+ +($MoY) +(\d{1,2}) +(\d\d):(\d\d):(\d\d) +(?:[^0-9]+ +)?(\d\d\d\d)$/ ) {
  5921. @tl_parts = ($5, $4, $3, $2, (index($MoY,$1)/4), $6);
  5922. }
  5923. return eval {
  5924. my $t = @tl_parts ? Time::Local::timegm(@tl_parts) : -1;
  5925. $t < 0 ? undef : $t;
  5926. };
  5927. }
  5928. # URI escaping adapted from URI::Escape
  5929. # c.f. http://www.w3.org/TR/html4/interact/forms.html#h-17.13.4.1
  5930. # perl 5.6 ready UTF-8 encoding adapted from JSON::PP
  5931. my %escapes = map { chr($_) => sprintf("%%%02X", $_) } 0..255;
  5932. $escapes{' '}="+";
  5933. my $unsafe_char = qr/[^A-Za-z0-9\-\._~]/;
  5934. sub _uri_escape {
  5935. my ($self, $str) = @_;
  5936. if ( $] ge '5.008' ) {
  5937. utf8::encode($str);
  5938. }
  5939. else {
  5940. $str = pack("U*", unpack("C*", $str)) # UTF-8 encode a byte string
  5941. if ( length $str == do { use bytes; length $str } );
  5942. $str = pack("C*", unpack("C*", $str)); # clear UTF-8 flag
  5943. }
  5944. $str =~ s/($unsafe_char)/$escapes{$1}/ge;
  5945. return $str;
  5946. }
  5947. package
  5948. HTTP::Tiny::Handle; # hide from PAUSE/indexers
  5949. use strict;
  5950. use warnings;
  5951. use Errno qw[EINTR EPIPE];
  5952. use IO::Socket qw[SOCK_STREAM];
  5953. sub BUFSIZE () { 32768 } ## no critic
  5954. my $Printable = sub {
  5955. local $_ = shift;
  5956. s/\r/\\r/g;
  5957. s/\n/\\n/g;
  5958. s/\t/\\t/g;
  5959. s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;
  5960. $_;
  5961. };
  5962. my $Token = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;
  5963. sub new {
  5964. my ($class, %args) = @_;
  5965. return bless {
  5966. rbuf => '',
  5967. timeout => 60,
  5968. max_line_size => 16384,
  5969. max_header_lines => 64,
  5970. verify_SSL => 0,
  5971. SSL_options => {},
  5972. %args
  5973. }, $class;
  5974. }
  5975. sub connect {
  5976. @_ == 4 || die(q/Usage: $handle->connect(scheme, host, port)/ . "\n");
  5977. my ($self, $scheme, $host, $port) = @_;
  5978. if ( $scheme eq 'https' ) {
  5979. die(qq/IO::Socket::SSL 1.56 must be installed for https support\n/)
  5980. unless eval {require IO::Socket::SSL; IO::Socket::SSL->VERSION(1.56)};
  5981. die(qq/Net::SSLeay 1.49 must be installed for https support\n/)
  5982. unless eval {require Net::SSLeay; Net::SSLeay->VERSION(1.49)};
  5983. }
  5984. elsif ( $scheme ne 'http' ) {
  5985. die(qq/Unsupported URL scheme '$scheme'\n/);
  5986. }
  5987. $self->{fh} = 'IO::Socket::INET'->new(
  5988. PeerHost => $host,
  5989. PeerPort => $port,
  5990. $self->{local_address} ?
  5991. ( LocalAddr => $self->{local_address} ) : (),
  5992. Proto => 'tcp',
  5993. Type => SOCK_STREAM,
  5994. Timeout => $self->{timeout}
  5995. ) or die(qq/Could not connect to '$host:$port': $@\n/);
  5996. binmode($self->{fh})
  5997. or die(qq/Could not binmode() socket: '$!'\n/);
  5998. if ( $scheme eq 'https') {
  5999. my $ssl_args = $self->_ssl_args($host);
  6000. IO::Socket::SSL->start_SSL(
  6001. $self->{fh},
  6002. %$ssl_args,
  6003. SSL_create_ctx_callback => sub {
  6004. my $ctx = shift;
  6005. Net::SSLeay::CTX_set_mode($ctx, Net::SSLeay::MODE_AUTO_RETRY());
  6006. },
  6007. );
  6008. unless ( ref($self->{fh}) eq 'IO::Socket::SSL' ) {
  6009. my $ssl_err = IO::Socket::SSL->errstr;
  6010. die(qq/SSL connection failed for $host: $ssl_err\n/);
  6011. }
  6012. }
  6013. $self->{host} = $host;
  6014. $self->{port} = $port;
  6015. return $self;
  6016. }
  6017. sub close {
  6018. @_ == 1 || die(q/Usage: $handle->close()/ . "\n");
  6019. my ($self) = @_;
  6020. CORE::close($self->{fh})
  6021. or die(qq/Could not close socket: '$!'\n/);
  6022. }
  6023. sub write {
  6024. @_ == 2 || die(q/Usage: $handle->write(buf)/ . "\n");
  6025. my ($self, $buf) = @_;
  6026. if ( $] ge '5.008' ) {
  6027. utf8::downgrade($buf, 1)
  6028. or die(qq/Wide character in write()\n/);
  6029. }
  6030. my $len = length $buf;
  6031. my $off = 0;
  6032. local $SIG{PIPE} = 'IGNORE';
  6033. while () {
  6034. $self->can_write
  6035. or die(qq/Timed out while waiting for socket to become ready for writing\n/);
  6036. my $r = syswrite($self->{fh}, $buf, $len, $off);
  6037. if (defined $r) {
  6038. $len -= $r;
  6039. $off += $r;
  6040. last unless $len > 0;
  6041. }
  6042. elsif ($! == EPIPE) {
  6043. die(qq/Socket closed by remote server: $!\n/);
  6044. }
  6045. elsif ($! != EINTR) {
  6046. if ($self->{fh}->can('errstr')){
  6047. my $err = $self->{fh}->errstr();
  6048. die (qq/Could not write to SSL socket: '$err'\n /);
  6049. }
  6050. else {
  6051. die(qq/Could not write to socket: '$!'\n/);
  6052. }
  6053. }
  6054. }
  6055. return $off;
  6056. }
  6057. sub read {
  6058. @_ == 2 || @_ == 3 || die(q/Usage: $handle->read(len [, allow_partial])/ . "\n");
  6059. my ($self, $len, $allow_partial) = @_;
  6060. my $buf = '';
  6061. my $got = length $self->{rbuf};
  6062. if ($got) {
  6063. my $take = ($got < $len) ? $got : $len;
  6064. $buf = substr($self->{rbuf}, 0, $take, '');
  6065. $len -= $take;
  6066. }
  6067. while ($len > 0) {
  6068. $self->can_read
  6069. or die(q/Timed out while waiting for socket to become ready for reading/ . "\n");
  6070. my $r = sysread($self->{fh}, $buf, $len, length $buf);
  6071. if (defined $r) {
  6072. last unless $r;
  6073. $len -= $r;
  6074. }
  6075. elsif ($! != EINTR) {
  6076. if ($self->{fh}->can('errstr')){
  6077. my $err = $self->{fh}->errstr();
  6078. die (qq/Could not read from SSL socket: '$err'\n /);
  6079. }
  6080. else {
  6081. die(qq/Could not read from socket: '$!'\n/);
  6082. }
  6083. }
  6084. }
  6085. if ($len && !$allow_partial) {
  6086. die(qq/Unexpected end of stream\n/);
  6087. }
  6088. return $buf;
  6089. }
  6090. sub readline {
  6091. @_ == 1 || die(q/Usage: $handle->readline()/ . "\n");
  6092. my ($self) = @_;
  6093. while () {
  6094. if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) {
  6095. return $1;
  6096. }
  6097. if (length $self->{rbuf} >= $self->{max_line_size}) {
  6098. die(qq/Line size exceeds the maximum allowed size of $self->{max_line_size}\n/);
  6099. }
  6100. $self->can_read
  6101. or die(qq/Timed out while waiting for socket to become ready for reading\n/);
  6102. my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf});
  6103. if (defined $r) {
  6104. last unless $r;
  6105. }
  6106. elsif ($! != EINTR) {
  6107. if ($self->{fh}->can('errstr')){
  6108. my $err = $self->{fh}->errstr();
  6109. die (qq/Could not read from SSL socket: '$err'\n /);
  6110. }
  6111. else {
  6112. die(qq/Could not read from socket: '$!'\n/);
  6113. }
  6114. }
  6115. }
  6116. die(qq/Unexpected end of stream while looking for line\n/);
  6117. }
  6118. sub read_header_lines {
  6119. @_ == 1 || @_ == 2 || die(q/Usage: $handle->read_header_lines([headers])/ . "\n");
  6120. my ($self, $headers) = @_;
  6121. $headers ||= {};
  6122. my $lines = 0;
  6123. my $val;
  6124. while () {
  6125. my $line = $self->readline;
  6126. if (++$lines >= $self->{max_header_lines}) {
  6127. die(qq/Header lines exceeds maximum number allowed of $self->{max_header_lines}\n/);
  6128. }
  6129. elsif ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) {
  6130. my ($field_name) = lc $1;
  6131. if (exists $headers->{$field_name}) {
  6132. for ($headers->{$field_name}) {
  6133. $_ = [$_] unless ref $_ eq "ARRAY";
  6134. push @$_, $2;
  6135. $val = \$_->[-1];
  6136. }
  6137. }
  6138. else {
  6139. $val = \($headers->{$field_name} = $2);
  6140. }
  6141. }
  6142. elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) {
  6143. $val
  6144. or die(qq/Unexpected header continuation line\n/);
  6145. next unless length $1;
  6146. $$val .= ' ' if length $$val;
  6147. $$val .= $1;
  6148. }
  6149. elsif ($line =~ /\A \x0D?\x0A \z/x) {
  6150. last;
  6151. }
  6152. else {
  6153. die(q/Malformed header line: / . $Printable->($line) . "\n");
  6154. }
  6155. }
  6156. return $headers;
  6157. }
  6158. sub write_request {
  6159. @_ == 2 || die(q/Usage: $handle->write_request(request)/ . "\n");
  6160. my($self, $request) = @_;
  6161. $self->write_request_header(@{$request}{qw/method uri headers/});
  6162. $self->write_body($request) if $request->{cb};
  6163. return;
  6164. }
  6165. my %HeaderCase = (
  6166. 'content-md5' => 'Content-MD5',
  6167. 'etag' => 'ETag',
  6168. 'te' => 'TE',
  6169. 'www-authenticate' => 'WWW-Authenticate',
  6170. 'x-xss-protection' => 'X-XSS-Protection',
  6171. );
  6172. sub write_header_lines {
  6173. (@_ == 2 && ref $_[1] eq 'HASH') || die(q/Usage: $handle->write_header_lines(headers)/ . "\n");
  6174. my($self, $headers) = @_;
  6175. my $buf = '';
  6176. while (my ($k, $v) = each %$headers) {
  6177. my $field_name = lc $k;
  6178. if (exists $HeaderCase{$field_name}) {
  6179. $field_name = $HeaderCase{$field_name};
  6180. }
  6181. else {
  6182. $field_name =~ /\A $Token+ \z/xo
  6183. or die(q/Invalid HTTP header field name: / . $Printable->($field_name) . "\n");
  6184. $field_name =~ s/\b(\w)/\u$1/g;
  6185. $HeaderCase{lc $field_name} = $field_name;
  6186. }
  6187. for (ref $v eq 'ARRAY' ? @$v : $v) {
  6188. /[^\x0D\x0A]/
  6189. or die(qq/Invalid HTTP header field value ($field_name): / . $Printable->($_). "\n");
  6190. $buf .= "$field_name: $_\x0D\x0A";
  6191. }
  6192. }
  6193. $buf .= "\x0D\x0A";
  6194. return $self->write($buf);
  6195. }
  6196. sub read_body {
  6197. @_ == 3 || die(q/Usage: $handle->read_body(callback, response)/ . "\n");
  6198. my ($self, $cb, $response) = @_;
  6199. my $te = $response->{headers}{'transfer-encoding'} || '';
  6200. if ( grep { /chunked/i } ( ref $te eq 'ARRAY' ? @$te : $te ) ) {
  6201. $self->read_chunked_body($cb, $response);
  6202. }
  6203. else {
  6204. $self->read_content_body($cb, $response);
  6205. }
  6206. return;
  6207. }
  6208. sub write_body {
  6209. @_ == 2 || die(q/Usage: $handle->write_body(request)/ . "\n");
  6210. my ($self, $request) = @_;
  6211. if ($request->{headers}{'content-length'}) {
  6212. return $self->write_content_body($request);
  6213. }
  6214. else {
  6215. return $self->write_chunked_body($request);
  6216. }
  6217. }
  6218. sub read_content_body {
  6219. @_ == 3 || @_ == 4 || die(q/Usage: $handle->read_content_body(callback, response, [read_length])/ . "\n");
  6220. my ($self, $cb, $response, $content_length) = @_;
  6221. $content_length ||= $response->{headers}{'content-length'};
  6222. if ( $content_length ) {
  6223. my $len = $content_length;
  6224. while ($len > 0) {
  6225. my $read = ($len > BUFSIZE) ? BUFSIZE : $len;
  6226. $cb->($self->read($read, 0), $response);
  6227. $len -= $read;
  6228. }
  6229. }
  6230. else {
  6231. my $chunk;
  6232. $cb->($chunk, $response) while length( $chunk = $self->read(BUFSIZE, 1) );
  6233. }
  6234. return;
  6235. }
  6236. sub write_content_body {
  6237. @_ == 2 || die(q/Usage: $handle->write_content_body(request)/ . "\n");
  6238. my ($self, $request) = @_;
  6239. my ($len, $content_length) = (0, $request->{headers}{'content-length'});
  6240. while () {
  6241. my $data = $request->{cb}->();
  6242. defined $data && length $data
  6243. or last;
  6244. if ( $] ge '5.008' ) {
  6245. utf8::downgrade($data, 1)
  6246. or die(qq/Wide character in write_content()\n/);
  6247. }
  6248. $len += $self->write($data);
  6249. }
  6250. $len == $content_length
  6251. or die(qq/Content-Length missmatch (got: $len expected: $content_length)\n/);
  6252. return $len;
  6253. }
  6254. sub read_chunked_body {
  6255. @_ == 3 || die(q/Usage: $handle->read_chunked_body(callback, $response)/ . "\n");
  6256. my ($self, $cb, $response) = @_;
  6257. while () {
  6258. my $head = $self->readline;
  6259. $head =~ /\A ([A-Fa-f0-9]+)/x
  6260. or die(q/Malformed chunk head: / . $Printable->($head) . "\n");
  6261. my $len = hex($1)
  6262. or last;
  6263. $self->read_content_body($cb, $response, $len);
  6264. $self->read(2) eq "\x0D\x0A"
  6265. or die(qq/Malformed chunk: missing CRLF after chunk data\n/);
  6266. }
  6267. $self->read_header_lines($response->{headers});
  6268. return;
  6269. }
  6270. sub write_chunked_body {
  6271. @_ == 2 || die(q/Usage: $handle->write_chunked_body(request)/ . "\n");
  6272. my ($self, $request) = @_;
  6273. my $len = 0;
  6274. while () {
  6275. my $data = $request->{cb}->();
  6276. defined $data && length $data
  6277. or last;
  6278. if ( $] ge '5.008' ) {
  6279. utf8::downgrade($data, 1)
  6280. or die(qq/Wide character in write_chunked_body()\n/);
  6281. }
  6282. $len += length $data;
  6283. my $chunk = sprintf '%X', length $data;
  6284. $chunk .= "\x0D\x0A";
  6285. $chunk .= $data;
  6286. $chunk .= "\x0D\x0A";
  6287. $self->write($chunk);
  6288. }
  6289. $self->write("0\x0D\x0A");
  6290. $self->write_header_lines($request->{trailer_cb}->())
  6291. if ref $request->{trailer_cb} eq 'CODE';
  6292. return $len;
  6293. }
  6294. sub read_response_header {
  6295. @_ == 1 || die(q/Usage: $handle->read_response_header()/ . "\n");
  6296. my ($self) = @_;
  6297. my $line = $self->readline;
  6298. $line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x
  6299. or die(q/Malformed Status-Line: / . $Printable->($line). "\n");
  6300. my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
  6301. die (qq/Unsupported HTTP protocol: $protocol\n/)
  6302. unless $version =~ /0*1\.0*[01]/;
  6303. return {
  6304. status => $status,
  6305. reason => $reason,
  6306. headers => $self->read_header_lines,
  6307. protocol => $protocol,
  6308. };
  6309. }
  6310. sub write_request_header {
  6311. @_ == 4 || die(q/Usage: $handle->write_request_header(method, request_uri, headers)/ . "\n");
  6312. my ($self, $method, $request_uri, $headers) = @_;
  6313. return $self->write("$method $request_uri HTTP/1.1\x0D\x0A")
  6314. + $self->write_header_lines($headers);
  6315. }
  6316. sub _do_timeout {
  6317. my ($self, $type, $timeout) = @_;
  6318. $timeout = $self->{timeout}
  6319. unless defined $timeout && $timeout >= 0;
  6320. my $fd = fileno $self->{fh};
  6321. defined $fd && $fd >= 0
  6322. or die(qq/select(2): 'Bad file descriptor'\n/);
  6323. my $initial = time;
  6324. my $pending = $timeout;
  6325. my $nfound;
  6326. vec(my $fdset = '', $fd, 1) = 1;
  6327. while () {
  6328. $nfound = ($type eq 'read')
  6329. ? select($fdset, undef, undef, $pending)
  6330. : select(undef, $fdset, undef, $pending) ;
  6331. if ($nfound == -1) {
  6332. $! == EINTR
  6333. or die(qq/select(2): '$!'\n/);
  6334. redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0;
  6335. $nfound = 0;
  6336. }
  6337. last;
  6338. }
  6339. $! = 0;
  6340. return $nfound;
  6341. }
  6342. sub can_read {
  6343. @_ == 1 || @_ == 2 || die(q/Usage: $handle->can_read([timeout])/ . "\n");
  6344. my $self = shift;
  6345. return $self->_do_timeout('read', @_)
  6346. }
  6347. sub can_write {
  6348. @_ == 1 || @_ == 2 || die(q/Usage: $handle->can_write([timeout])/ . "\n");
  6349. my $self = shift;
  6350. return $self->_do_timeout('write', @_)
  6351. }
  6352. # Try to find a CA bundle to validate the SSL cert,
  6353. # prefer Mozilla::CA or fallback to a system file
  6354. sub _find_CA_file {
  6355. my $self = shift();
  6356. return $self->{SSL_options}->{SSL_ca_file}
  6357. if $self->{SSL_options}->{SSL_ca_file} and -e $self->{SSL_options}->{SSL_ca_file};
  6358. return Mozilla::CA::SSL_ca_file()
  6359. if eval { require Mozilla::CA };
  6360. foreach my $ca_bundle (qw{
  6361. /etc/ssl/certs/ca-certificates.crt
  6362. /etc/pki/tls/certs/ca-bundle.crt
  6363. /etc/ssl/ca-bundle.pem
  6364. }
  6365. ) {
  6366. return $ca_bundle if -e $ca_bundle;
  6367. }
  6368. die qq/Couldn't find a CA bundle with which to verify the SSL certificate.\n/
  6369. . qq/Try installing Mozilla::CA from CPAN\n/;
  6370. }
  6371. sub _ssl_args {
  6372. my ($self, $host) = @_;
  6373. my %ssl_args = (
  6374. SSL_hostname => $host, # SNI
  6375. );
  6376. if ($self->{verify_SSL}) {
  6377. $ssl_args{SSL_verifycn_scheme} = 'http'; # enable CN validation
  6378. $ssl_args{SSL_verifycn_name} = $host; # set validation hostname
  6379. $ssl_args{SSL_verify_mode} = 0x01; # enable cert validation
  6380. $ssl_args{SSL_ca_file} = $self->_find_CA_file;
  6381. }
  6382. else {
  6383. $ssl_args{SSL_verifycn_scheme} = 'none'; # disable CN validation
  6384. $ssl_args{SSL_verify_mode} = 0x00; # disable cert validation
  6385. }
  6386. # user options override settings from verify_SSL
  6387. for my $k ( keys %{$self->{SSL_options}} ) {
  6388. $ssl_args{$k} = $self->{SSL_options}{$k} if $k =~ m/^SSL_/;
  6389. }
  6390. return \%ssl_args;
  6391. }
  6392. 1;
  6393. __END__
  6394. HTTP_TINY
  6395.  
  6396. $fatpacked{"JSON/PP.pm"} = <<'JSON_PP';
  6397. package JSON::PP;
  6398. # JSON-2.0
  6399. use 5.005;
  6400. use strict;
  6401. use base qw(Exporter);
  6402. use overload ();
  6403. use Carp ();
  6404. use B ();
  6405. #use Devel::Peek;
  6406. $JSON::PP::VERSION = '2.27200';
  6407. @JSON::PP::EXPORT = qw(encode_json decode_json from_json to_json);
  6408. # instead of hash-access, i tried index-access for speed.
  6409. # but this method is not faster than what i expected. so it will be changed.
  6410. use constant P_ASCII => 0;
  6411. use constant P_LATIN1 => 1;
  6412. use constant P_UTF8 => 2;
  6413. use constant P_INDENT => 3;
  6414. use constant P_CANONICAL => 4;
  6415. use constant P_SPACE_BEFORE => 5;
  6416. use constant P_SPACE_AFTER => 6;
  6417. use constant P_ALLOW_NONREF => 7;
  6418. use constant P_SHRINK => 8;
  6419. use constant P_ALLOW_BLESSED => 9;
  6420. use constant P_CONVERT_BLESSED => 10;
  6421. use constant P_RELAXED => 11;
  6422. use constant P_LOOSE => 12;
  6423. use constant P_ALLOW_BIGNUM => 13;
  6424. use constant P_ALLOW_BAREKEY => 14;
  6425. use constant P_ALLOW_SINGLEQUOTE => 15;
  6426. use constant P_ESCAPE_SLASH => 16;
  6427. use constant P_AS_NONBLESSED => 17;
  6428. use constant P_ALLOW_UNKNOWN => 18;
  6429. use constant OLD_PERL => $] < 5.008 ? 1 : 0;
  6430. BEGIN {
  6431. my @xs_compati_bit_properties = qw(
  6432. latin1 ascii utf8 indent canonical space_before space_after allow_nonref shrink
  6433. allow_blessed convert_blessed relaxed allow_unknown
  6434. );
  6435. my @pp_bit_properties = qw(
  6436. allow_singlequote allow_bignum loose
  6437. allow_barekey escape_slash as_nonblessed
  6438. );
  6439. # Perl version check, Unicode handling is enable?
  6440. # Helper module sets @JSON::PP::_properties.
  6441. if ($] < 5.008 ) {
  6442. my $helper = $] >= 5.006 ? 'JSON::PP::Compat5006' : 'JSON::PP::Compat5005';
  6443. eval qq| require $helper |;
  6444. if ($@) { Carp::croak $@; }
  6445. }
  6446. for my $name (@xs_compati_bit_properties, @pp_bit_properties) {
  6447. my $flag_name = 'P_' . uc($name);
  6448. eval qq/
  6449. sub $name {
  6450. my \$enable = defined \$_[1] ? \$_[1] : 1;
  6451. if (\$enable) {
  6452. \$_[0]->{PROPS}->[$flag_name] = 1;
  6453. }
  6454. else {
  6455. \$_[0]->{PROPS}->[$flag_name] = 0;
  6456. }
  6457. \$_[0];
  6458. }
  6459. sub get_$name {
  6460. \$_[0]->{PROPS}->[$flag_name] ? 1 : '';
  6461. }
  6462. /;
  6463. }
  6464. }
  6465. # Functions
  6466. my %encode_allow_method
  6467. = map {($_ => 1)} qw/utf8 pretty allow_nonref latin1 self_encode escape_slash
  6468. allow_blessed convert_blessed indent indent_length allow_bignum
  6469. as_nonblessed
  6470. /;
  6471. my %decode_allow_method
  6472. = map {($_ => 1)} qw/utf8 allow_nonref loose allow_singlequote allow_bignum
  6473. allow_barekey max_size relaxed/;
  6474. my $JSON; # cache
  6475. sub encode_json ($) { # encode
  6476. ($JSON ||= __PACKAGE__->new->utf8)->encode(@_);
  6477. }
  6478. sub decode_json { # decode
  6479. ($JSON ||= __PACKAGE__->new->utf8)->decode(@_);
  6480. }
  6481. # Obsoleted
  6482. sub to_json($) {
  6483. Carp::croak ("JSON::PP::to_json has been renamed to encode_json.");
  6484. }
  6485. sub from_json($) {
  6486. Carp::croak ("JSON::PP::from_json has been renamed to decode_json.");
  6487. }
  6488. # Methods
  6489. sub new {
  6490. my $class = shift;
  6491. my $self = {
  6492. max_depth => 512,
  6493. max_size => 0,
  6494. indent => 0,
  6495. FLAGS => 0,
  6496. fallback => sub { encode_error('Invalid value. JSON can only reference.') },
  6497. indent_length => 3,
  6498. };
  6499. bless $self, $class;
  6500. }
  6501. sub encode {
  6502. return $_[0]->PP_encode_json($_[1]);
  6503. }
  6504. sub decode {
  6505. return $_[0]->PP_decode_json($_[1], 0x00000000);
  6506. }
  6507. sub decode_prefix {
  6508. return $_[0]->PP_decode_json($_[1], 0x00000001);
  6509. }
  6510. # accessor
  6511. # pretty printing
  6512. sub pretty {
  6513. my ($self, $v) = @_;
  6514. my $enable = defined $v ? $v : 1;
  6515. if ($enable) { # indent_length(3) for JSON::XS compatibility
  6516. $self->indent(1)->indent_length(3)->space_before(1)->space_after(1);
  6517. }
  6518. else {
  6519. $self->indent(0)->space_before(0)->space_after(0);
  6520. }
  6521. $self;
  6522. }
  6523. # etc
  6524. sub max_depth {
  6525. my $max = defined $_[1] ? $_[1] : 0x80000000;
  6526. $_[0]->{max_depth} = $max;
  6527. $_[0];
  6528. }
  6529. sub get_max_depth { $_[0]->{max_depth}; }
  6530. sub max_size {
  6531. my $max = defined $_[1] ? $_[1] : 0;
  6532. $_[0]->{max_size} = $max;
  6533. $_[0];
  6534. }
  6535. sub get_max_size { $_[0]->{max_size}; }
  6536. sub filter_json_object {
  6537. $_[0]->{cb_object} = defined $_[1] ? $_[1] : 0;
  6538. $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
  6539. $_[0];
  6540. }
  6541. sub filter_json_single_key_object {
  6542. if (@_ > 1) {
  6543. $_[0]->{cb_sk_object}->{$_[1]} = $_[2];
  6544. }
  6545. $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
  6546. $_[0];
  6547. }
  6548. sub indent_length {
  6549. if (!defined $_[1] or $_[1] > 15 or $_[1] < 0) {
  6550. Carp::carp "The acceptable range of indent_length() is 0 to 15.";
  6551. }
  6552. else {
  6553. $_[0]->{indent_length} = $_[1];
  6554. }
  6555. $_[0];
  6556. }
  6557. sub get_indent_length {
  6558. $_[0]->{indent_length};
  6559. }
  6560. sub sort_by {
  6561. $_[0]->{sort_by} = defined $_[1] ? $_[1] : 1;
  6562. $_[0];
  6563. }
  6564. sub allow_bigint {
  6565. Carp::carp("allow_bigint() is obsoleted. use allow_bignum() insted.");
  6566. }
  6567. ###############################
  6568. ###
  6569. ### Perl => JSON
  6570. ###
  6571. { # Convert
  6572. my $max_depth;
  6573. my $indent;
  6574. my $ascii;
  6575. my $latin1;
  6576. my $utf8;
  6577. my $space_before;
  6578. my $space_after;
  6579. my $canonical;
  6580. my $allow_blessed;
  6581. my $convert_blessed;
  6582. my $indent_length;
  6583. my $escape_slash;
  6584. my $bignum;
  6585. my $as_nonblessed;
  6586. my $depth;
  6587. my $indent_count;
  6588. my $keysort;
  6589. sub PP_encode_json {
  6590. my $self = shift;
  6591. my $obj = shift;
  6592. $indent_count = 0;
  6593. $depth = 0;
  6594. my $idx = $self->{PROPS};
  6595. ($ascii, $latin1, $utf8, $indent, $canonical, $space_before, $space_after, $allow_blessed,
  6596. $convert_blessed, $escape_slash, $bignum, $as_nonblessed)
  6597. = @{$idx}[P_ASCII .. P_SPACE_AFTER, P_ALLOW_BLESSED, P_CONVERT_BLESSED,
  6598. P_ESCAPE_SLASH, P_ALLOW_BIGNUM, P_AS_NONBLESSED];
  6599. ($max_depth, $indent_length) = @{$self}{qw/max_depth indent_length/};
  6600. $keysort = $canonical ? sub { $a cmp $b } : undef;
  6601. if ($self->{sort_by}) {
  6602. $keysort = ref($self->{sort_by}) eq 'CODE' ? $self->{sort_by}
  6603. : $self->{sort_by} =~ /\D+/ ? $self->{sort_by}
  6604. : sub { $a cmp $b };
  6605. }
  6606. encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)")
  6607. if(!ref $obj and !$idx->[ P_ALLOW_NONREF ]);
  6608. my $str = $self->object_to_json($obj);
  6609. $str .= "\n" if ( $indent ); # JSON::XS 2.26 compatible
  6610. unless ($ascii or $latin1 or $utf8) {
  6611. utf8::upgrade($str);
  6612. }
  6613. if ($idx->[ P_SHRINK ]) {
  6614. utf8::downgrade($str, 1);
  6615. }
  6616. return $str;
  6617. }
  6618. sub object_to_json {
  6619. my ($self, $obj) = @_;
  6620. my $type = ref($obj);
  6621. if($type eq 'HASH'){
  6622. return $self->hash_to_json($obj);
  6623. }
  6624. elsif($type eq 'ARRAY'){
  6625. return $self->array_to_json($obj);
  6626. }
  6627. elsif ($type) { # blessed object?
  6628. if (blessed($obj)) {
  6629. return $self->value_to_json($obj) if ( $obj->isa('JSON::PP::Boolean') );
  6630. if ( $convert_blessed and $obj->can('TO_JSON') ) {
  6631. my $result = $obj->TO_JSON();
  6632. if ( defined $result and ref( $result ) ) {
  6633. if ( refaddr( $obj ) eq refaddr( $result ) ) {
  6634. encode_error( sprintf(
  6635. "%s::TO_JSON method returned same object as was passed instead of a new one",
  6636. ref $obj
  6637. ) );
  6638. }
  6639. }
  6640. return $self->object_to_json( $result );
  6641. }
  6642. return "$obj" if ( $bignum and _is_bignum($obj) );
  6643. return $self->blessed_to_json($obj) if ($allow_blessed and $as_nonblessed); # will be removed.
  6644. encode_error( sprintf("encountered object '%s', but neither allow_blessed "
  6645. . "nor convert_blessed settings are enabled", $obj)
  6646. ) unless ($allow_blessed);
  6647. return 'null';
  6648. }
  6649. else {
  6650. return $self->value_to_json($obj);
  6651. }
  6652. }
  6653. else{
  6654. return $self->value_to_json($obj);
  6655. }
  6656. }
  6657. sub hash_to_json {
  6658. my ($self, $obj) = @_;
  6659. my @res;
  6660. encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")
  6661. if (++$depth > $max_depth);
  6662. my ($pre, $post) = $indent ? $self->_up_indent() : ('', '');
  6663. my $del = ($space_before ? ' ' : '') . ':' . ($space_after ? ' ' : '');
  6664. for my $k ( _sort( $obj ) ) {
  6665. if ( OLD_PERL ) { utf8::decode($k) } # key for Perl 5.6 / be optimized
  6666. push @res, string_to_json( $self, $k )
  6667. . $del
  6668. . ( $self->object_to_json( $obj->{$k} ) || $self->value_to_json( $obj->{$k} ) );
  6669. }
  6670. --$depth;
  6671. $self->_down_indent() if ($indent);
  6672. return '{' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . '}';
  6673. }
  6674. sub array_to_json {
  6675. my ($self, $obj) = @_;
  6676. my @res;
  6677. encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")
  6678. if (++$depth > $max_depth);
  6679. my ($pre, $post) = $indent ? $self->_up_indent() : ('', '');
  6680. for my $v (@$obj){
  6681. push @res, $self->object_to_json($v) || $self->value_to_json($v);
  6682. }
  6683. --$depth;
  6684. $self->_down_indent() if ($indent);
  6685. return '[' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . ']';
  6686. }
  6687. sub value_to_json {
  6688. my ($self, $value) = @_;
  6689. return 'null' if(!defined $value);
  6690. my $b_obj = B::svref_2object(\$value); # for round trip problem
  6691. my $flags = $b_obj->FLAGS;
  6692. return $value # as is
  6693. if $flags & ( B::SVp_IOK | B::SVp_NOK ) and !( $flags & B::SVp_POK ); # SvTYPE is IV or NV?
  6694. my $type = ref($value);
  6695. if(!$type){
  6696. return string_to_json($self, $value);
  6697. }
  6698. elsif( blessed($value) and $value->isa('JSON::PP::Boolean') ){
  6699. return $$value == 1 ? 'true' : 'false';
  6700. }
  6701. elsif ($type) {
  6702. if ((overload::StrVal($value) =~ /=(\w+)/)[0]) {
  6703. return $self->value_to_json("$value");
  6704. }
  6705. if ($type eq 'SCALAR' and defined $$value) {
  6706. return $$value eq '1' ? 'true'
  6707. : $$value eq '0' ? 'false'
  6708. : $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ? 'null'
  6709. : encode_error("cannot encode reference to scalar");
  6710. }
  6711. if ( $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ) {
  6712. return 'null';
  6713. }
  6714. else {
  6715. if ( $type eq 'SCALAR' or $type eq 'REF' ) {
  6716. encode_error("cannot encode reference to scalar");
  6717. }
  6718. else {
  6719. encode_error("encountered $value, but JSON can only represent references to arrays or hashes");
  6720. }
  6721. }
  6722. }
  6723. else {
  6724. return $self->{fallback}->($value)
  6725. if ($self->{fallback} and ref($self->{fallback}) eq 'CODE');
  6726. return 'null';
  6727. }
  6728. }
  6729. my %esc = (
  6730. "\n" => '\n',
  6731. "\r" => '\r',
  6732. "\t" => '\t',
  6733. "\f" => '\f',
  6734. "\b" => '\b',
  6735. "\"" => '\"',
  6736. "\\" => '\\\\',
  6737. "\'" => '\\\'',
  6738. );
  6739. sub string_to_json {
  6740. my ($self, $arg) = @_;
  6741. $arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g;
  6742. $arg =~ s/\//\\\//g if ($escape_slash);
  6743. $arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg;
  6744. if ($ascii) {
  6745. $arg = JSON_PP_encode_ascii($arg);
  6746. }
  6747. if ($latin1) {
  6748. $arg = JSON_PP_encode_latin1($arg);
  6749. }
  6750. if ($utf8) {
  6751. utf8::encode($arg);
  6752. }
  6753. return '"' . $arg . '"';
  6754. }
  6755. sub blessed_to_json {
  6756. my $reftype = reftype($_[1]) || '';
  6757. if ($reftype eq 'HASH') {
  6758. return $_[0]->hash_to_json($_[1]);
  6759. }
  6760. elsif ($reftype eq 'ARRAY') {
  6761. return $_[0]->array_to_json($_[1]);
  6762. }
  6763. else {
  6764. return 'null';
  6765. }
  6766. }
  6767. sub encode_error {
  6768. my $error = shift;
  6769. Carp::croak "$error";
  6770. }
  6771. sub _sort {
  6772. defined $keysort ? (sort $keysort (keys %{$_[0]})) : keys %{$_[0]};
  6773. }
  6774. sub _up_indent {
  6775. my $self = shift;
  6776. my $space = ' ' x $indent_length;
  6777. my ($pre,$post) = ('','');
  6778. $post = "\n" . $space x $indent_count;
  6779. $indent_count++;
  6780. $pre = "\n" . $space x $indent_count;
  6781. return ($pre,$post);
  6782. }
  6783. sub _down_indent { $indent_count--; }
  6784. sub PP_encode_box {
  6785. {
  6786. depth => $depth,
  6787. indent_count => $indent_count,
  6788. };
  6789. }
  6790. } # Convert
  6791. sub _encode_ascii {
  6792. join('',
  6793. map {
  6794. $_ <= 127 ?
  6795. chr($_) :
  6796. $_ <= 65535 ?
  6797. sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
  6798. } unpack('U*', $_[0])
  6799. );
  6800. }
  6801. sub _encode_latin1 {
  6802. join('',
  6803. map {
  6804. $_ <= 255 ?
  6805. chr($_) :
  6806. $_ <= 65535 ?
  6807. sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
  6808. } unpack('U*', $_[0])
  6809. );
  6810. }
  6811. sub _encode_surrogates { # from perlunicode
  6812. my $uni = $_[0] - 0x10000;
  6813. return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00);
  6814. }
  6815. sub _is_bignum {
  6816. $_[0]->isa('Math::BigInt') or $_[0]->isa('Math::BigFloat');
  6817. }
  6818. #
  6819. # JSON => Perl
  6820. #
  6821. my $max_intsize;
  6822. BEGIN {
  6823. my $checkint = 1111;
  6824. for my $d (5..64) {
  6825. $checkint .= 1;
  6826. my $int = eval qq| $checkint |;
  6827. if ($int =~ /[eE]/) {
  6828. $max_intsize = $d - 1;
  6829. last;
  6830. }
  6831. }
  6832. }
  6833. { # PARSE
  6834. my %escapes = ( # by Jeremy Muhlich <jmuhlich [at] bitflood.org>
  6835. b => "\x8",
  6836. t => "\x9",
  6837. n => "\xA",
  6838. f => "\xC",
  6839. r => "\xD",
  6840. '\\' => '\\',
  6841. '"' => '"',
  6842. '/' => '/',
  6843. );
  6844. my $text; # json data
  6845. my $at; # offset
  6846. my $ch; # 1chracter
  6847. my $len; # text length (changed according to UTF8 or NON UTF8)
  6848. # INTERNAL
  6849. my $depth; # nest counter
  6850. my $encoding; # json text encoding
  6851. my $is_valid_utf8; # temp variable
  6852. my $utf8_len; # utf8 byte length
  6853. # FLAGS
  6854. my $utf8; # must be utf8
  6855. my $max_depth; # max nest nubmer of objects and arrays
  6856. my $max_size;
  6857. my $relaxed;
  6858. my $cb_object;
  6859. my $cb_sk_object;
  6860. my $F_HOOK;
  6861. my $allow_bigint; # using Math::BigInt
  6862. my $singlequote; # loosely quoting
  6863. my $loose; #
  6864. my $allow_barekey; # bareKey
  6865. # $opt flag
  6866. # 0x00000001 .... decode_prefix
  6867. # 0x10000000 .... incr_parse
  6868. sub PP_decode_json {
  6869. my ($self, $opt); # $opt is an effective flag during this decode_json.
  6870. ($self, $text, $opt) = @_;
  6871. ($at, $ch, $depth) = (0, '', 0);
  6872. if ( !defined $text or ref $text ) {
  6873. decode_error("malformed JSON string, neither array, object, number, string or atom");
  6874. }
  6875. my $idx = $self->{PROPS};
  6876. ($utf8, $relaxed, $loose, $allow_bigint, $allow_barekey, $singlequote)
  6877. = @{$idx}[P_UTF8, P_RELAXED, P_LOOSE .. P_ALLOW_SINGLEQUOTE];
  6878. if ( $utf8 ) {
  6879. utf8::downgrade( $text, 1 ) or Carp::croak("Wide character in subroutine entry");
  6880. }
  6881. else {
  6882. utf8::upgrade( $text );
  6883. }
  6884. $len = length $text;
  6885. ($max_depth, $max_size, $cb_object, $cb_sk_object, $F_HOOK)
  6886. = @{$self}{qw/max_depth max_size cb_object cb_sk_object F_HOOK/};
  6887. if ($max_size > 1) {
  6888. use bytes;
  6889. my $bytes = length $text;
  6890. decode_error(
  6891. sprintf("attempted decode of JSON text of %s bytes size, but max_size is set to %s"
  6892. , $bytes, $max_size), 1
  6893. ) if ($bytes > $max_size);
  6894. }
  6895. # Currently no effect
  6896. # should use regexp
  6897. my @octets = unpack('C4', $text);
  6898. $encoding = ( $octets[0] and $octets[1]) ? 'UTF-8'
  6899. : (!$octets[0] and $octets[1]) ? 'UTF-16BE'
  6900. : (!$octets[0] and !$octets[1]) ? 'UTF-32BE'
  6901. : ( $octets[2] ) ? 'UTF-16LE'
  6902. : (!$octets[2] ) ? 'UTF-32LE'
  6903. : 'unknown';
  6904. white(); # remove head white space
  6905. my $valid_start = defined $ch; # Is there a first character for JSON structure?
  6906. my $result = value();
  6907. return undef if ( !$result && ( $opt & 0x10000000 ) ); # for incr_parse
  6908. decode_error("malformed JSON string, neither array, object, number, string or atom") unless $valid_start;
  6909. if ( !$idx->[ P_ALLOW_NONREF ] and !ref $result ) {
  6910. decode_error(
  6911. 'JSON text must be an object or array (but found number, string, true, false or null,'
  6912. . ' use allow_nonref to allow this)', 1);
  6913. }
  6914. Carp::croak('something wrong.') if $len < $at; # we won't arrive here.
  6915. my $consumed = defined $ch ? $at - 1 : $at; # consumed JSON text length
  6916. white(); # remove tail white space
  6917. if ( $ch ) {
  6918. return ( $result, $consumed ) if ($opt & 0x00000001); # all right if decode_prefix
  6919. decode_error("garbage after JSON object");
  6920. }
  6921. ( $opt & 0x00000001 ) ? ( $result, $consumed ) : $result;
  6922. }
  6923. sub next_chr {
  6924. return $ch = undef if($at >= $len);
  6925. $ch = substr($text, $at++, 1);
  6926. }
  6927. sub value {
  6928. white();
  6929. return if(!defined $ch);
  6930. return object() if($ch eq '{');
  6931. return array() if($ch eq '[');
  6932. return string() if($ch eq '"' or ($singlequote and $ch eq "'"));
  6933. return number() if($ch =~ /[0-9]/ or $ch eq '-');
  6934. return word();
  6935. }
  6936. sub string {
  6937. my ($i, $s, $t, $u);
  6938. my $utf16;
  6939. my $is_utf8;
  6940. ($is_valid_utf8, $utf8_len) = ('', 0);
  6941. $s = ''; # basically UTF8 flag on
  6942. if($ch eq '"' or ($singlequote and $ch eq "'")){
  6943. my $boundChar = $ch;
  6944. OUTER: while( defined(next_chr()) ){
  6945. if($ch eq $boundChar){
  6946. next_chr();
  6947. if ($utf16) {
  6948. decode_error("missing low surrogate character in surrogate pair");
  6949. }
  6950. utf8::decode($s) if($is_utf8);
  6951. return $s;
  6952. }
  6953. elsif($ch eq '\\'){
  6954. next_chr();
  6955. if(exists $escapes{$ch}){
  6956. $s .= $escapes{$ch};
  6957. }
  6958. elsif($ch eq 'u'){ # UNICODE handling
  6959. my $u = '';
  6960. for(1..4){
  6961. $ch = next_chr();
  6962. last OUTER if($ch !~ /[0-9a-fA-F]/);
  6963. $u .= $ch;
  6964. }
  6965. # U+D800 - U+DBFF
  6966. if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/) { # UTF-16 high surrogate?
  6967. $utf16 = $u;
  6968. }
  6969. # U+DC00 - U+DFFF
  6970. elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/) { # UTF-16 low surrogate?
  6971. unless (defined $utf16) {
  6972. decode_error("missing high surrogate character in surrogate pair");
  6973. }
  6974. $is_utf8 = 1;
  6975. $s .= JSON_PP_decode_surrogates($utf16, $u) || next;
  6976. $utf16 = undef;
  6977. }
  6978. else {
  6979. if (defined $utf16) {
  6980. decode_error("surrogate pair expected");
  6981. }
  6982. if ( ( my $hex = hex( $u ) ) > 127 ) {
  6983. $is_utf8 = 1;
  6984. $s .= JSON_PP_decode_unicode($u) || next;
  6985. }
  6986. else {
  6987. $s .= chr $hex;
  6988. }
  6989. }
  6990. }
  6991. else{
  6992. unless ($loose) {
  6993. $at -= 2;
  6994. decode_error('illegal backslash escape sequence in string');
  6995. }
  6996. $s .= $ch;
  6997. }
  6998. }
  6999. else{
  7000. if ( ord $ch > 127 ) {
  7001. if ( $utf8 ) {
  7002. unless( $ch = is_valid_utf8($ch) ) {
  7003. $at -= 1;
  7004. decode_error("malformed UTF-8 character in JSON string");
  7005. }
  7006. else {
  7007. $at += $utf8_len - 1;
  7008. }
  7009. }
  7010. else {
  7011. utf8::encode( $ch );
  7012. }
  7013. $is_utf8 = 1;
  7014. }
  7015. if (!$loose) {
  7016. if ($ch =~ /[\x00-\x1f\x22\x5c]/) { # '/' ok
  7017. $at--;
  7018. decode_error('invalid character encountered while parsing JSON string');
  7019. }
  7020. }
  7021. $s .= $ch;
  7022. }
  7023. }
  7024. }
  7025. decode_error("unexpected end of string while parsing JSON string");
  7026. }
  7027. sub white {
  7028. while( defined $ch ){
  7029. if($ch le ' '){
  7030. next_chr();
  7031. }
  7032. elsif($ch eq '/'){
  7033. next_chr();
  7034. if(defined $ch and $ch eq '/'){
  7035. 1 while(defined(next_chr()) and $ch ne "\n" and $ch ne "\r");
  7036. }
  7037. elsif(defined $ch and $ch eq '*'){
  7038. next_chr();
  7039. while(1){
  7040. if(defined $ch){
  7041. if($ch eq '*'){
  7042. if(defined(next_chr()) and $ch eq '/'){
  7043. next_chr();
  7044. last;
  7045. }
  7046. }
  7047. else{
  7048. next_chr();
  7049. }
  7050. }
  7051. else{
  7052. decode_error("Unterminated comment");
  7053. }
  7054. }
  7055. next;
  7056. }
  7057. else{
  7058. $at--;
  7059. decode_error("malformed JSON string, neither array, object, number, string or atom");
  7060. }
  7061. }
  7062. else{
  7063. if ($relaxed and $ch eq '#') { # correctly?
  7064. pos($text) = $at;
  7065. $text =~ /\G([^\n]*(?:\r\n|\r|\n|$))/g;
  7066. $at = pos($text);
  7067. next_chr;
  7068. next;
  7069. }
  7070. last;
  7071. }
  7072. }
  7073. }
  7074. sub array {
  7075. my $a = $_[0] || []; # you can use this code to use another array ref object.
  7076. decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')
  7077. if (++$depth > $max_depth);
  7078. next_chr();
  7079. white();
  7080. if(defined $ch and $ch eq ']'){
  7081. --$depth;
  7082. next_chr();
  7083. return $a;
  7084. }
  7085. else {
  7086. while(defined($ch)){
  7087. push @$a, value();
  7088. white();
  7089. if (!defined $ch) {
  7090. last;
  7091. }
  7092. if($ch eq ']'){
  7093. --$depth;
  7094. next_chr();
  7095. return $a;
  7096. }
  7097. if($ch ne ','){
  7098. last;
  7099. }
  7100. next_chr();
  7101. white();
  7102. if ($relaxed and $ch eq ']') {
  7103. --$depth;
  7104. next_chr();
  7105. return $a;
  7106. }
  7107. }
  7108. }
  7109. decode_error(", or ] expected while parsing array");
  7110. }
  7111. sub object {
  7112. my $o = $_[0] || {}; # you can use this code to use another hash ref object.
  7113. my $k;
  7114. decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')
  7115. if (++$depth > $max_depth);
  7116. next_chr();
  7117. white();
  7118. if(defined $ch and $ch eq '}'){
  7119. --$depth;
  7120. next_chr();
  7121. if ($F_HOOK) {
  7122. return _json_object_hook($o);
  7123. }
  7124. return $o;
  7125. }
  7126. else {
  7127. while (defined $ch) {
  7128. $k = ($allow_barekey and $ch ne '"' and $ch ne "'") ? bareKey() : string();
  7129. white();
  7130. if(!defined $ch or $ch ne ':'){
  7131. $at--;
  7132. decode_error("':' expected");
  7133. }
  7134. next_chr();
  7135. $o->{$k} = value();
  7136. white();
  7137. last if (!defined $ch);
  7138. if($ch eq '}'){
  7139. --$depth;
  7140. next_chr();
  7141. if ($F_HOOK) {
  7142. return _json_object_hook($o);
  7143. }
  7144. return $o;
  7145. }
  7146. if($ch ne ','){
  7147. last;
  7148. }
  7149. next_chr();
  7150. white();
  7151. if ($relaxed and $ch eq '}') {
  7152. --$depth;
  7153. next_chr();
  7154. if ($F_HOOK) {
  7155. return _json_object_hook($o);
  7156. }
  7157. return $o;
  7158. }
  7159. }
  7160. }
  7161. $at--;
  7162. decode_error(", or } expected while parsing object/hash");
  7163. }
  7164. sub bareKey { # doesn't strictly follow Standard ECMA-262 3rd Edition
  7165. my $key;
  7166. while($ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){
  7167. $key .= $ch;
  7168. next_chr();
  7169. }
  7170. return $key;
  7171. }
  7172. sub word {
  7173. my $word = substr($text,$at-1,4);
  7174. if($word eq 'true'){
  7175. $at += 3;
  7176. next_chr;
  7177. return $JSON::PP::true;
  7178. }
  7179. elsif($word eq 'null'){
  7180. $at += 3;
  7181. next_chr;
  7182. return undef;
  7183. }
  7184. elsif($word eq 'fals'){
  7185. $at += 3;
  7186. if(substr($text,$at,1) eq 'e'){
  7187. $at++;
  7188. next_chr;
  7189. return $JSON::PP::false;
  7190. }
  7191. }
  7192. $at--; # for decode_error report
  7193. decode_error("'null' expected") if ($word =~ /^n/);
  7194. decode_error("'true' expected") if ($word =~ /^t/);
  7195. decode_error("'false' expected") if ($word =~ /^f/);
  7196. decode_error("malformed JSON string, neither array, object, number, string or atom");
  7197. }
  7198. sub number {
  7199. my $n = '';
  7200. my $v;
  7201. # According to RFC4627, hex or oct digts are invalid.
  7202. if($ch eq '0'){
  7203. my $peek = substr($text,$at,1);
  7204. my $hex = $peek =~ /[xX]/; # 0 or 1
  7205. if($hex){
  7206. decode_error("malformed number (leading zero must not be followed by another digit)");
  7207. ($n) = ( substr($text, $at+1) =~ /^([0-9a-fA-F]+)/);
  7208. }
  7209. else{ # oct
  7210. ($n) = ( substr($text, $at) =~ /^([0-7]+)/);
  7211. if (defined $n and length $n > 1) {
  7212. decode_error("malformed number (leading zero must not be followed by another digit)");
  7213. }
  7214. }
  7215. if(defined $n and length($n)){
  7216. if (!$hex and length($n) == 1) {
  7217. decode_error("malformed number (leading zero must not be followed by another digit)");
  7218. }
  7219. $at += length($n) + $hex;
  7220. next_chr;
  7221. return $hex ? hex($n) : oct($n);
  7222. }
  7223. }
  7224. if($ch eq '-'){
  7225. $n = '-';
  7226. next_chr;
  7227. if (!defined $ch or $ch !~ /\d/) {
  7228. decode_error("malformed number (no digits after initial minus)");
  7229. }
  7230. }
  7231. while(defined $ch and $ch =~ /\d/){
  7232. $n .= $ch;
  7233. next_chr;
  7234. }
  7235. if(defined $ch and $ch eq '.'){
  7236. $n .= '.';
  7237. next_chr;
  7238. if (!defined $ch or $ch !~ /\d/) {
  7239. decode_error("malformed number (no digits after decimal point)");
  7240. }
  7241. else {
  7242. $n .= $ch;
  7243. }
  7244. while(defined(next_chr) and $ch =~ /\d/){
  7245. $n .= $ch;
  7246. }
  7247. }
  7248. if(defined $ch and ($ch eq 'e' or $ch eq 'E')){
  7249. $n .= $ch;
  7250. next_chr;
  7251. if(defined($ch) and ($ch eq '+' or $ch eq '-')){
  7252. $n .= $ch;
  7253. next_chr;
  7254. if (!defined $ch or $ch =~ /\D/) {
  7255. decode_error("malformed number (no digits after exp sign)");
  7256. }
  7257. $n .= $ch;
  7258. }
  7259. elsif(defined($ch) and $ch =~ /\d/){
  7260. $n .= $ch;
  7261. }
  7262. else {
  7263. decode_error("malformed number (no digits after exp sign)");
  7264. }
  7265. while(defined(next_chr) and $ch =~ /\d/){
  7266. $n .= $ch;
  7267. }
  7268. }
  7269. $v .= $n;
  7270. if ($v !~ /[.eE]/ and length $v > $max_intsize) {
  7271. if ($allow_bigint) { # from Adam Sussman
  7272. require Math::BigInt;
  7273. return Math::BigInt->new($v);
  7274. }
  7275. else {
  7276. return "$v";
  7277. }
  7278. }
  7279. elsif ($allow_bigint) {
  7280. require Math::BigFloat;
  7281. return Math::BigFloat->new($v);
  7282. }
  7283. return 0+$v;
  7284. }
  7285. sub is_valid_utf8 {
  7286. $utf8_len = $_[0] =~ /[\x00-\x7F]/ ? 1
  7287. : $_[0] =~ /[\xC2-\xDF]/ ? 2
  7288. : $_[0] =~ /[\xE0-\xEF]/ ? 3
  7289. : $_[0] =~ /[\xF0-\xF4]/ ? 4
  7290. : 0
  7291. ;
  7292. return unless $utf8_len;
  7293. my $is_valid_utf8 = substr($text, $at - 1, $utf8_len);
  7294. return ( $is_valid_utf8 =~ /^(?:
  7295. [\x00-\x7F]
  7296. |[\xC2-\xDF][\x80-\xBF]
  7297. |[\xE0][\xA0-\xBF][\x80-\xBF]
  7298. |[\xE1-\xEC][\x80-\xBF][\x80-\xBF]
  7299. |[\xED][\x80-\x9F][\x80-\xBF]
  7300. |[\xEE-\xEF][\x80-\xBF][\x80-\xBF]
  7301. |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF]
  7302. |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF]
  7303. |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF]
  7304. )$/x ) ? $is_valid_utf8 : '';
  7305. }
  7306. sub decode_error {
  7307. my $error = shift;
  7308. my $no_rep = shift;
  7309. my $str = defined $text ? substr($text, $at) : '';
  7310. my $mess = '';
  7311. my $type = $] >= 5.008 ? 'U*'
  7312. : $] < 5.006 ? 'C*'
  7313. : utf8::is_utf8( $str ) ? 'U*' # 5.6
  7314. : 'C*'
  7315. ;
  7316. for my $c ( unpack( $type, $str ) ) { # emulate pv_uni_display() ?
  7317. $mess .= $c == 0x07 ? '\a'
  7318. : $c == 0x09 ? '\t'
  7319. : $c == 0x0a ? '\n'
  7320. : $c == 0x0d ? '\r'
  7321. : $c == 0x0c ? '\f'
  7322. : $c < 0x20 ? sprintf('\x{%x}', $c)
  7323. : $c == 0x5c ? '\\\\'
  7324. : $c < 0x80 ? chr($c)
  7325. : sprintf('\x{%x}', $c)
  7326. ;
  7327. if ( length $mess >= 20 ) {
  7328. $mess .= '...';
  7329. last;
  7330. }
  7331. }
  7332. unless ( length $mess ) {
  7333. $mess = '(end of string)';
  7334. }
  7335. Carp::croak (
  7336. $no_rep ? "$error" : "$error, at character offset $at (before \"$mess\")"
  7337. );
  7338. }
  7339. sub _json_object_hook {
  7340. my $o = $_[0];
  7341. my @ks = keys %{$o};
  7342. if ( $cb_sk_object and @ks == 1 and exists $cb_sk_object->{ $ks[0] } and ref $cb_sk_object->{ $ks[0] } ) {
  7343. my @val = $cb_sk_object->{ $ks[0] }->( $o->{$ks[0]} );
  7344. if (@val == 1) {
  7345. return $val[0];
  7346. }
  7347. }
  7348. my @val = $cb_object->($o) if ($cb_object);
  7349. if (@val == 0 or @val > 1) {
  7350. return $o;
  7351. }
  7352. else {
  7353. return $val[0];
  7354. }
  7355. }
  7356. sub PP_decode_box {
  7357. {
  7358. text => $text,
  7359. at => $at,
  7360. ch => $ch,
  7361. len => $len,
  7362. depth => $depth,
  7363. encoding => $encoding,
  7364. is_valid_utf8 => $is_valid_utf8,
  7365. };
  7366. }
  7367. } # PARSE
  7368. sub _decode_surrogates { # from perlunicode
  7369. my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00);
  7370. my $un = pack('U*', $uni);
  7371. utf8::encode( $un );
  7372. return $un;
  7373. }
  7374. sub _decode_unicode {
  7375. my $un = pack('U', hex shift);
  7376. utf8::encode( $un );
  7377. return $un;
  7378. }
  7379. #
  7380. # Setup for various Perl versions (the code from JSON::PP58)
  7381. #
  7382. BEGIN {
  7383. unless ( defined &utf8::is_utf8 ) {
  7384. require Encode;
  7385. *utf8::is_utf8 = *Encode::is_utf8;
  7386. }
  7387. if ( $] >= 5.008 ) {
  7388. *JSON::PP::JSON_PP_encode_ascii = \&_encode_ascii;
  7389. *JSON::PP::JSON_PP_encode_latin1 = \&_encode_latin1;
  7390. *JSON::PP::JSON_PP_decode_surrogates = \&_decode_surrogates;
  7391. *JSON::PP::JSON_PP_decode_unicode = \&_decode_unicode;
  7392. }
  7393. if ($] >= 5.008 and $] < 5.008003) { # join() in 5.8.0 - 5.8.2 is broken.
  7394. package JSON::PP;
  7395. require subs;
  7396. subs->import('join');
  7397. eval q|
  7398. sub join {
  7399. return '' if (@_ < 2);
  7400. my $j = shift;
  7401. my $str = shift;
  7402. for (@_) { $str .= $j . $_; }
  7403. return $str;
  7404. }
  7405. |;
  7406. }
  7407. sub JSON::PP::incr_parse {
  7408. local $Carp::CarpLevel = 1;
  7409. ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ );
  7410. }
  7411. sub JSON::PP::incr_skip {
  7412. ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip;
  7413. }
  7414. sub JSON::PP::incr_reset {
  7415. ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset;
  7416. }
  7417. eval q{
  7418. sub JSON::PP::incr_text : lvalue {
  7419. $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new;
  7420. if ( $_[0]->{_incr_parser}->{incr_parsing} ) {
  7421. Carp::croak("incr_text can not be called when the incremental parser already started parsing");
  7422. }
  7423. $_[0]->{_incr_parser}->{incr_text};
  7424. }
  7425. } if ( $] >= 5.006 );
  7426. } # Setup for various Perl versions (the code from JSON::PP58)
  7427. ###############################
  7428. # Utilities
  7429. #
  7430. BEGIN {
  7431. eval 'require Scalar::Util';
  7432. unless($@){
  7433. *JSON::PP::blessed = \&Scalar::Util::blessed;
  7434. *JSON::PP::reftype = \&Scalar::Util::reftype;
  7435. *JSON::PP::refaddr = \&Scalar::Util::refaddr;
  7436. }
  7437. else{ # This code is from Sclar::Util.
  7438. # warn $@;
  7439. eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }';
  7440. *JSON::PP::blessed = sub {
  7441. local($@, $SIG{__DIE__}, $SIG{__WARN__});
  7442. ref($_[0]) ? eval { $_[0]->a_sub_not_likely_to_be_here } : undef;
  7443. };
  7444. my %tmap = qw(
  7445. B::NULL SCALAR
  7446. B::HV HASH
  7447. B::AV ARRAY
  7448. B::CV CODE
  7449. B::IO IO
  7450. B::GV GLOB
  7451. B::REGEXP REGEXP
  7452. );
  7453. *JSON::PP::reftype = sub {
  7454. my $r = shift;
  7455. return undef unless length(ref($r));
  7456. my $t = ref(B::svref_2object($r));
  7457. return
  7458. exists $tmap{$t} ? $tmap{$t}
  7459. : length(ref($$r)) ? 'REF'
  7460. : 'SCALAR';
  7461. };
  7462. *JSON::PP::refaddr = sub {
  7463. return undef unless length(ref($_[0]));
  7464. my $addr;
  7465. if(defined(my $pkg = blessed($_[0]))) {
  7466. $addr .= bless $_[0], 'Scalar::Util::Fake';
  7467. bless $_[0], $pkg;
  7468. }
  7469. else {
  7470. $addr .= $_[0]
  7471. }
  7472. $addr =~ /0x(\w+)/;
  7473. local $^W;
  7474. #no warnings 'portable';
  7475. hex($1);
  7476. }
  7477. }
  7478. }
  7479. # shamely copied and modified from JSON::XS code.
  7480. $JSON::PP::true = do { bless \(my $dummy = 1), "JSON::PP::Boolean" };
  7481. $JSON::PP::false = do { bless \(my $dummy = 0), "JSON::PP::Boolean" };
  7482. sub is_bool { defined $_[0] and UNIVERSAL::isa($_[0], "JSON::PP::Boolean"); }
  7483. sub true { $JSON::PP::true }
  7484. sub false { $JSON::PP::false }
  7485. sub null { undef; }
  7486. ###############################
  7487. package JSON::PP::Boolean;
  7488. use overload (
  7489. "0+" => sub { ${$_[0]} },
  7490. "++" => sub { $_[0] = ${$_[0]} + 1 },
  7491. "--" => sub { $_[0] = ${$_[0]} - 1 },
  7492. fallback => 1,
  7493. );
  7494. ###############################
  7495. package JSON::PP::IncrParser;
  7496. use strict;
  7497. use constant INCR_M_WS => 0; # initial whitespace skipping
  7498. use constant INCR_M_STR => 1; # inside string
  7499. use constant INCR_M_BS => 2; # inside backslash
  7500. use constant INCR_M_JSON => 3; # outside anything, count nesting
  7501. use constant INCR_M_C0 => 4;
  7502. use constant INCR_M_C1 => 5;
  7503. $JSON::PP::IncrParser::VERSION = '1.01';
  7504. my $unpack_format = $] < 5.006 ? 'C*' : 'U*';
  7505. sub new {
  7506. my ( $class ) = @_;
  7507. bless {
  7508. incr_nest => 0,
  7509. incr_text => undef,
  7510. incr_parsing => 0,
  7511. incr_p => 0,
  7512. }, $class;
  7513. }
  7514. sub incr_parse {
  7515. my ( $self, $coder, $text ) = @_;
  7516. $self->{incr_text} = '' unless ( defined $self->{incr_text} );
  7517. if ( defined $text ) {
  7518. if ( utf8::is_utf8( $text ) and !utf8::is_utf8( $self->{incr_text} ) ) {
  7519. utf8::upgrade( $self->{incr_text} ) ;
  7520. utf8::decode( $self->{incr_text} ) ;
  7521. }
  7522. $self->{incr_text} .= $text;
  7523. }
  7524. my $max_size = $coder->get_max_size;
  7525. if ( defined wantarray ) {
  7526. $self->{incr_mode} = INCR_M_WS unless defined $self->{incr_mode};
  7527. if ( wantarray ) {
  7528. my @ret;
  7529. $self->{incr_parsing} = 1;
  7530. do {
  7531. push @ret, $self->_incr_parse( $coder, $self->{incr_text} );
  7532. unless ( !$self->{incr_nest} and $self->{incr_mode} == INCR_M_JSON ) {
  7533. $self->{incr_mode} = INCR_M_WS if $self->{incr_mode} != INCR_M_STR;
  7534. }
  7535. } until ( length $self->{incr_text} >= $self->{incr_p} );
  7536. $self->{incr_parsing} = 0;
  7537. return @ret;
  7538. }
  7539. else { # in scalar context
  7540. $self->{incr_parsing} = 1;
  7541. my $obj = $self->_incr_parse( $coder, $self->{incr_text} );
  7542. $self->{incr_parsing} = 0 if defined $obj; # pointed by Martin J. Evans
  7543. return $obj ? $obj : undef; # $obj is an empty string, parsing was completed.
  7544. }
  7545. }
  7546. }
  7547. sub _incr_parse {
  7548. my ( $self, $coder, $text, $skip ) = @_;
  7549. my $p = $self->{incr_p};
  7550. my $restore = $p;
  7551. my @obj;
  7552. my $len = length $text;
  7553. if ( $self->{incr_mode} == INCR_M_WS ) {
  7554. while ( $len > $p ) {
  7555. my $s = substr( $text, $p, 1 );
  7556. $p++ and next if ( 0x20 >= unpack($unpack_format, $s) );
  7557. $self->{incr_mode} = INCR_M_JSON;
  7558. last;
  7559. }
  7560. }
  7561. while ( $len > $p ) {
  7562. my $s = substr( $text, $p++, 1 );
  7563. if ( $s eq '"' ) {
  7564. if (substr( $text, $p - 2, 1 ) eq '\\' ) {
  7565. next;
  7566. }
  7567. if ( $self->{incr_mode} != INCR_M_STR ) {
  7568. $self->{incr_mode} = INCR_M_STR;
  7569. }
  7570. else {
  7571. $self->{incr_mode} = INCR_M_JSON;
  7572. unless ( $self->{incr_nest} ) {
  7573. last;
  7574. }
  7575. }
  7576. }
  7577. if ( $self->{incr_mode} == INCR_M_JSON ) {
  7578. if ( $s eq '[' or $s eq '{' ) {
  7579. if ( ++$self->{incr_nest} > $coder->get_max_depth ) {
  7580. Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)');
  7581. }
  7582. }
  7583. elsif ( $s eq ']' or $s eq '}' ) {
  7584. last if ( --$self->{incr_nest} <= 0 );
  7585. }
  7586. elsif ( $s eq '#' ) {
  7587. while ( $len > $p ) {
  7588. last if substr( $text, $p++, 1 ) eq "\n";
  7589. }
  7590. }
  7591. }
  7592. }
  7593. $self->{incr_p} = $p;
  7594. return if ( $self->{incr_mode} == INCR_M_STR and not $self->{incr_nest} );
  7595. return if ( $self->{incr_mode} == INCR_M_JSON and $self->{incr_nest} > 0 );
  7596. return '' unless ( length substr( $self->{incr_text}, 0, $p ) );
  7597. local $Carp::CarpLevel = 2;
  7598. $self->{incr_p} = $restore;
  7599. $self->{incr_c} = $p;
  7600. my ( $obj, $tail ) = $coder->PP_decode_json( substr( $self->{incr_text}, 0, $p ), 0x10000001 );
  7601. $self->{incr_text} = substr( $self->{incr_text}, $p );
  7602. $self->{incr_p} = 0;
  7603. return $obj or '';
  7604. }
  7605. sub incr_text {
  7606. if ( $_[0]->{incr_parsing} ) {
  7607. Carp::croak("incr_text can not be called when the incremental parser already started parsing");
  7608. }
  7609. $_[0]->{incr_text};
  7610. }
  7611. sub incr_skip {
  7612. my $self = shift;
  7613. $self->{incr_text} = substr( $self->{incr_text}, $self->{incr_c} );
  7614. $self->{incr_p} = 0;
  7615. }
  7616. sub incr_reset {
  7617. my $self = shift;
  7618. $self->{incr_text} = undef;
  7619. $self->{incr_p} = 0;
  7620. $self->{incr_mode} = 0;
  7621. $self->{incr_nest} = 0;
  7622. $self->{incr_parsing} = 0;
  7623. }
  7624. ###############################
  7625. 1;
  7626. __END__
  7627. =pod
  7628. JSON_PP
  7629.  
  7630. $fatpacked{"JSON/PP/Boolean.pm"} = <<'JSON_PP_BOOLEAN';
  7631. use JSON::PP ();
  7632. use strict;
  7633. 1;
  7634. JSON_PP_BOOLEAN
  7635.  
  7636. $fatpacked{"Module/CPANfile.pm"} = <<'MODULE_CPANFILE';
  7637. package Module::CPANfile;
  7638. use strict;
  7639. use warnings;
  7640. use Cwd;
  7641. our $VERSION = '0.9010';
  7642. sub new {
  7643. my($class, $file) = @_;
  7644. bless {}, $class;
  7645. }
  7646. sub load {
  7647. my($proto, $file) = @_;
  7648. my $self = ref $proto ? $proto : $proto->new;
  7649. $self->{file} = $file || "cpanfile";
  7650. $self->parse;
  7651. $self;
  7652. }
  7653. sub parse {
  7654. my $self = shift;
  7655. my $file = Cwd::abs_path($self->{file});
  7656. $self->{result} = Module::CPANfile::Environment::parse($file) or die $@;
  7657. }
  7658. sub prereqs { shift->prereq }
  7659. sub prereq {
  7660. my $self = shift;
  7661. require CPAN::Meta::Prereqs;
  7662. CPAN::Meta::Prereqs->new($self->prereq_specs);
  7663. }
  7664. sub prereq_specs {
  7665. my $self = shift;
  7666. $self->{result}{spec};
  7667. }
  7668. sub merge_meta {
  7669. my($self, $file, $version) = @_;
  7670. require CPAN::Meta;
  7671. $version ||= $file =~ /\.yml$/ ? '1.4' : '2';
  7672. my $prereq = $self->prereqs;
  7673. my $meta = CPAN::Meta->load_file($file);
  7674. my $prereqs_hash = $prereq->with_merged_prereqs($meta->effective_prereqs)->as_string_hash;
  7675. my $struct = { %{$meta->as_struct}, prereqs => $prereqs_hash };
  7676. CPAN::Meta->new($struct)->save($file, { version => $version });
  7677. }
  7678. package Module::CPANfile::Environment;
  7679. use strict;
  7680. my @bindings = qw(
  7681. on requires recommends suggests conflicts
  7682. osname perl
  7683. configure_requires build_requires test_requires author_requires
  7684. );
  7685. my $file_id = 1;
  7686. sub import {
  7687. my($class, $result_ref) = @_;
  7688. my $pkg = caller;
  7689. $$result_ref = Module::CPANfile::Result->new;
  7690. for my $binding (@bindings) {
  7691. no strict 'refs';
  7692. *{"$pkg\::$binding"} = sub { $$result_ref->$binding(@_) };
  7693. }
  7694. }
  7695. sub parse {
  7696. my $file = shift;
  7697. my $code = do {
  7698. open my $fh, "<", $file or die "$file: $!";
  7699. join '', <$fh>;
  7700. };
  7701. my($res, $err);
  7702. {
  7703. local $@;
  7704. $res = eval sprintf <<EVAL, $file_id++;
  7705. package Module::CPANfile::Sandbox%d;
  7706. no warnings;
  7707. my \$_result;
  7708. BEGIN { import Module::CPANfile::Environment \\\$_result };
  7709. $code;
  7710. \$_result;
  7711. EVAL
  7712. $err = $@;
  7713. }
  7714. if ($err) { die "Parsing $file failed: $err" };
  7715. return $res;
  7716. }
  7717. package Module::CPANfile::Result;
  7718. use strict;
  7719. sub new {
  7720. bless {
  7721. phase => 'runtime', # default phase
  7722. spec => {},
  7723. }, shift;
  7724. }
  7725. sub on {
  7726. my($self, $phase, $code) = @_;
  7727. local $self->{phase} = $phase;
  7728. $code->()
  7729. }
  7730. sub osname { die "TODO" }
  7731. sub perl { die "TODO" }
  7732. sub requires {
  7733. my($self, $module, $requirement) = @_;
  7734. $self->{spec}{$self->{phase}}{requires}{$module} = $requirement || 0;
  7735. }
  7736. sub recommends {
  7737. my($self, $module, $requirement) = @_;
  7738. $self->{spec}->{$self->{phase}}{recommends}{$module} = $requirement || 0;
  7739. }
  7740. sub suggests {
  7741. my($self, $module, $requirement) = @_;
  7742. $self->{spec}->{$self->{phase}}{suggests}{$module} = $requirement || 0;
  7743. }
  7744. sub conflicts {
  7745. my($self, $module, $requirement) = @_;
  7746. $self->{spec}->{$self->{phase}}{conflicts}{$module} = $requirement || 0;
  7747. }
  7748. # Module::Install compatible shortcuts
  7749. sub configure_requires {
  7750. my($self, @args) = @_;
  7751. $self->on(configure => sub { $self->requires(@args) });
  7752. }
  7753. sub build_requires {
  7754. my($self, @args) = @_;
  7755. $self->on(build => sub { $self->requires(@args) });
  7756. }
  7757. sub test_requires {
  7758. my($self, @args) = @_;
  7759. $self->on(test => sub { $self->requires(@args) });
  7760. }
  7761. sub author_requires {
  7762. my($self, @args) = @_;
  7763. $self->on(develop => sub { $self->requires(@args) });
  7764. }
  7765. package Module::CPANfile;
  7766. 1;
  7767. __END__
  7768. MODULE_CPANFILE
  7769.  
  7770. $fatpacked{"Module/Metadata.pm"} = <<'MODULE_METADATA';
  7771. # -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*-
  7772. # vim:ts=8:sw=2:et:sta:sts=2
  7773. package Module::Metadata;
  7774. # Adapted from Perl-licensed code originally distributed with
  7775. # Module-Build by Ken Williams
  7776. # This module provides routines to gather information about
  7777. # perl modules (assuming this may be expanded in the distant
  7778. # parrot future to look at other types of modules).
  7779. use strict;
  7780. use vars qw($VERSION);
  7781. $VERSION = '1.000011';
  7782. $VERSION = eval $VERSION;
  7783. use Carp qw/croak/;
  7784. use File::Spec;
  7785. use IO::File;
  7786. use version 0.87;
  7787. BEGIN {
  7788. if ($INC{'Log/Contextual.pm'}) {
  7789. Log::Contextual->import('log_info');
  7790. } else {
  7791. *log_info = sub (&) { warn $_[0]->() };
  7792. }
  7793. }
  7794. use File::Find qw(find);
  7795. my $V_NUM_REGEXP = qr{v?[0-9._]+}; # crudely, a v-string or decimal
  7796. my $PKG_REGEXP = qr{ # match a package declaration
  7797. ^[\s\{;]* # intro chars on a line
  7798. package # the word 'package'
  7799. \s+ # whitespace
  7800. ([\w:]+) # a package name
  7801. \s* # optional whitespace
  7802. ($V_NUM_REGEXP)? # optional version number
  7803. \s* # optional whitesapce
  7804. [;\{] # semicolon line terminator or block start (since 5.16)
  7805. }x;
  7806. my $VARNAME_REGEXP = qr{ # match fully-qualified VERSION name
  7807. ([\$*]) # sigil - $ or *
  7808. (
  7809. ( # optional leading package name
  7810. (?:::|\')? # possibly starting like just :: (� la $::VERSION)
  7811. (?:\w+(?:::|\'))* # Foo::Bar:: ...
  7812. )?
  7813. VERSION
  7814. )\b
  7815. }x;
  7816. my $VERS_REGEXP = qr{ # match a VERSION definition
  7817. (?:
  7818. \(\s*$VARNAME_REGEXP\s*\) # with parens
  7819. |
  7820. $VARNAME_REGEXP # without parens
  7821. )
  7822. \s*
  7823. =[^=~] # = but not ==, nor =~
  7824. }x;
  7825. sub new_from_file {
  7826. my $class = shift;
  7827. my $filename = File::Spec->rel2abs( shift );
  7828. return undef unless defined( $filename ) && -f $filename;
  7829. return $class->_init(undef, $filename, @_);
  7830. }
  7831. sub new_from_handle {
  7832. my $class = shift;
  7833. my $handle = shift;
  7834. my $filename = shift;
  7835. return undef unless defined($handle) && defined($filename);
  7836. $filename = File::Spec->rel2abs( $filename );
  7837. return $class->_init(undef, $filename, @_, handle => $handle);
  7838. }
  7839. sub new_from_module {
  7840. my $class = shift;
  7841. my $module = shift;
  7842. my %props = @_;
  7843. $props{inc} ||= \@INC;
  7844. my $filename = $class->find_module_by_name( $module, $props{inc} );
  7845. return undef unless defined( $filename ) && -f $filename;
  7846. return $class->_init($module, $filename, %props);
  7847. }
  7848. {
  7849. my $compare_versions = sub {
  7850. my ($v1, $op, $v2) = @_;
  7851. $v1 = version->new($v1)
  7852. unless UNIVERSAL::isa($v1,'version');
  7853. my $eval_str = "\$v1 $op \$v2";
  7854. my $result = eval $eval_str;
  7855. log_info { "error comparing versions: '$eval_str' $@" } if $@;
  7856. return $result;
  7857. };
  7858. my $normalize_version = sub {
  7859. my ($version) = @_;
  7860. if ( $version =~ /[=<>!,]/ ) { # logic, not just version
  7861. # take as is without modification
  7862. }
  7863. elsif ( ref $version eq 'version' ) { # version objects
  7864. $version = $version->is_qv ? $version->normal : $version->stringify;
  7865. }
  7866. elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots
  7867. # normalize string tuples without "v": "1.2.3" -> "v1.2.3"
  7868. $version = "v$version";
  7869. }
  7870. else {
  7871. # leave alone
  7872. }
  7873. return $version;
  7874. };
  7875. # separate out some of the conflict resolution logic
  7876. my $resolve_module_versions = sub {
  7877. my $packages = shift;
  7878. my( $file, $version );
  7879. my $err = '';
  7880. foreach my $p ( @$packages ) {
  7881. if ( defined( $p->{version} ) ) {
  7882. if ( defined( $version ) ) {
  7883. if ( $compare_versions->( $version, '!=', $p->{version} ) ) {
  7884. $err .= " $p->{file} ($p->{version})\n";
  7885. } else {
  7886. # same version declared multiple times, ignore
  7887. }
  7888. } else {
  7889. $file = $p->{file};
  7890. $version = $p->{version};
  7891. }
  7892. }
  7893. $file ||= $p->{file} if defined( $p->{file} );
  7894. }
  7895. if ( $err ) {
  7896. $err = " $file ($version)\n" . $err;
  7897. }
  7898. my %result = (
  7899. file => $file,
  7900. version => $version,
  7901. err => $err
  7902. );
  7903. return \%result;
  7904. };
  7905. sub provides {
  7906. my $class = shift;
  7907. croak "provides() requires key/value pairs \n" if @_ % 2;
  7908. my %args = @_;
  7909. croak "provides() takes only one of 'dir' or 'files'\n"
  7910. if $args{dir} && $args{files};
  7911. croak "provides() requires a 'version' argument"
  7912. unless defined $args{version};
  7913. croak "provides() does not support version '$args{version}' metadata"
  7914. unless grep { $args{version} eq $_ } qw/1.4 2/;
  7915. $args{prefix} = 'lib' unless defined $args{prefix};
  7916. my $p;
  7917. if ( $args{dir} ) {
  7918. $p = $class->package_versions_from_directory($args{dir});
  7919. }
  7920. else {
  7921. croak "provides() requires 'files' to be an array reference\n"
  7922. unless ref $args{files} eq 'ARRAY';
  7923. $p = $class->package_versions_from_directory($args{files});
  7924. }
  7925. # Now, fix up files with prefix
  7926. if ( length $args{prefix} ) { # check in case disabled with q{}
  7927. $args{prefix} =~ s{/$}{};
  7928. for my $v ( values %$p ) {
  7929. $v->{file} = "$args{prefix}/$v->{file}";
  7930. }
  7931. }
  7932. return $p
  7933. }
  7934. sub package_versions_from_directory {
  7935. my ( $class, $dir, $files ) = @_;
  7936. my @files;
  7937. if ( $files ) {
  7938. @files = @$files;
  7939. } else {
  7940. find( {
  7941. wanted => sub {
  7942. push @files, $_ if -f $_ && /\.pm$/;
  7943. },
  7944. no_chdir => 1,
  7945. }, $dir );
  7946. }
  7947. # First, we enumerate all packages & versions,
  7948. # separating into primary & alternative candidates
  7949. my( %prime, %alt );
  7950. foreach my $file (@files) {
  7951. my $mapped_filename = File::Spec::Unix->abs2rel( $file, $dir );
  7952. my @path = split( /\//, $mapped_filename );
  7953. (my $prime_package = join( '::', @path )) =~ s/\.pm$//;
  7954. my $pm_info = $class->new_from_file( $file );
  7955. foreach my $package ( $pm_info->packages_inside ) {
  7956. next if $package eq 'main'; # main can appear numerous times, ignore
  7957. next if $package eq 'DB'; # special debugging package, ignore
  7958. next if grep /^_/, split( /::/, $package ); # private package, ignore
  7959. my $version = $pm_info->version( $package );
  7960. $prime_package = $package if lc($prime_package) eq lc($package);
  7961. if ( $package eq $prime_package ) {
  7962. if ( exists( $prime{$package} ) ) {
  7963. croak "Unexpected conflict in '$package'; multiple versions found.\n";
  7964. } else {
  7965. $mapped_filename = "$package.pm" if lc("$package.pm") eq lc($mapped_filename);
  7966. $prime{$package}{file} = $mapped_filename;
  7967. $prime{$package}{version} = $version if defined( $version );
  7968. }
  7969. } else {
  7970. push( @{$alt{$package}}, {
  7971. file => $mapped_filename,
  7972. version => $version,
  7973. } );
  7974. }
  7975. }
  7976. }
  7977. # Then we iterate over all the packages found above, identifying conflicts
  7978. # and selecting the "best" candidate for recording the file & version
  7979. # for each package.
  7980. foreach my $package ( keys( %alt ) ) {
  7981. my $result = $resolve_module_versions->( $alt{$package} );
  7982. if ( exists( $prime{$package} ) ) { # primary package selected
  7983. if ( $result->{err} ) {
  7984. # Use the selected primary package, but there are conflicting
  7985. # errors among multiple alternative packages that need to be
  7986. # reported
  7987. log_info {
  7988. "Found conflicting versions for package '$package'\n" .
  7989. " $prime{$package}{file} ($prime{$package}{version})\n" .
  7990. $result->{err}
  7991. };
  7992. } elsif ( defined( $result->{version} ) ) {
  7993. # There is a primary package selected, and exactly one
  7994. # alternative package
  7995. if ( exists( $prime{$package}{version} ) &&
  7996. defined( $prime{$package}{version} ) ) {
  7997. # Unless the version of the primary package agrees with the
  7998. # version of the alternative package, report a conflict
  7999. if ( $compare_versions->(
  8000. $prime{$package}{version}, '!=', $result->{version}
  8001. )
  8002. ) {
  8003. log_info {
  8004. "Found conflicting versions for package '$package'\n" .
  8005. " $prime{$package}{file} ($prime{$package}{version})\n" .
  8006. " $result->{file} ($result->{version})\n"
  8007. };
  8008. }
  8009. } else {
  8010. # The prime package selected has no version so, we choose to
  8011. # use any alternative package that does have a version
  8012. $prime{$package}{file} = $result->{file};
  8013. $prime{$package}{version} = $result->{version};
  8014. }
  8015. } else {
  8016. # no alt package found with a version, but we have a prime
  8017. # package so we use it whether it has a version or not
  8018. }
  8019. } else { # No primary package was selected, use the best alternative
  8020. if ( $result->{err} ) {
  8021. log_info {
  8022. "Found conflicting versions for package '$package'\n" .
  8023. $result->{err}
  8024. };
  8025. }
  8026. # Despite possible conflicting versions, we choose to record
  8027. # something rather than nothing
  8028. $prime{$package}{file} = $result->{file};
  8029. $prime{$package}{version} = $result->{version}
  8030. if defined( $result->{version} );
  8031. }
  8032. }
  8033. # Normalize versions. Can't use exists() here because of bug in YAML::Node.
  8034. # XXX "bug in YAML::Node" comment seems irrelvant -- dagolden, 2009-05-18
  8035. for (grep defined $_->{version}, values %prime) {
  8036. $_->{version} = $normalize_version->( $_->{version} );
  8037. }
  8038. return \%prime;
  8039. }
  8040. }
  8041. sub _init {
  8042. my $class = shift;
  8043. my $module = shift;
  8044. my $filename = shift;
  8045. my %props = @_;
  8046. my $handle = delete $props{handle};
  8047. my( %valid_props, @valid_props );
  8048. @valid_props = qw( collect_pod inc );
  8049. @valid_props{@valid_props} = delete( @props{@valid_props} );
  8050. warn "Unknown properties: @{[keys %props]}\n" if scalar( %props );
  8051. my %data = (
  8052. module => $module,
  8053. filename => $filename,
  8054. version => undef,
  8055. packages => [],
  8056. versions => {},
  8057. pod => {},
  8058. pod_headings => [],
  8059. collect_pod => 0,
  8060. %valid_props,
  8061. );
  8062. my $self = bless(\%data, $class);
  8063. if ( $handle ) {
  8064. $self->_parse_fh($handle);
  8065. }
  8066. else {
  8067. $self->_parse_file();
  8068. }
  8069. unless($self->{module} and length($self->{module})) {
  8070. my ($v, $d, $f) = File::Spec->splitpath($self->{filename});
  8071. if($f =~ /\.pm$/) {
  8072. $f =~ s/\..+$//;
  8073. my @candidates = grep /$f$/, @{$self->{packages}};
  8074. $self->{module} = shift(@candidates); # punt
  8075. }
  8076. else {
  8077. if(grep /main/, @{$self->{packages}}) {
  8078. $self->{module} = 'main';
  8079. }
  8080. else {
  8081. $self->{module} = $self->{packages}[0] || '';
  8082. }
  8083. }
  8084. }
  8085. $self->{version} = $self->{versions}{$self->{module}}
  8086. if defined( $self->{module} );
  8087. return $self;
  8088. }
  8089. # class method
  8090. sub _do_find_module {
  8091. my $class = shift;
  8092. my $module = shift || croak 'find_module_by_name() requires a package name';
  8093. my $dirs = shift || \@INC;
  8094. my $file = File::Spec->catfile(split( /::/, $module));
  8095. foreach my $dir ( @$dirs ) {
  8096. my $testfile = File::Spec->catfile($dir, $file);
  8097. return [ File::Spec->rel2abs( $testfile ), $dir ]
  8098. if -e $testfile and !-d _; # For stuff like ExtUtils::xsubpp
  8099. return [ File::Spec->rel2abs( "$testfile.pm" ), $dir ]
  8100. if -e "$testfile.pm";
  8101. }
  8102. return;
  8103. }
  8104. # class method
  8105. sub find_module_by_name {
  8106. my $found = shift()->_do_find_module(@_) or return;
  8107. return $found->[0];
  8108. }
  8109. # class method
  8110. sub find_module_dir_by_name {
  8111. my $found = shift()->_do_find_module(@_) or return;
  8112. return $found->[1];
  8113. }
  8114. # given a line of perl code, attempt to parse it if it looks like a
  8115. # $VERSION assignment, returning sigil, full name, & package name
  8116. sub _parse_version_expression {
  8117. my $self = shift;
  8118. my $line = shift;
  8119. my( $sig, $var, $pkg );
  8120. if ( $line =~ /$VERS_REGEXP/o ) {
  8121. ( $sig, $var, $pkg ) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 );
  8122. if ( $pkg ) {
  8123. $pkg = ($pkg eq '::') ? 'main' : $pkg;
  8124. $pkg =~ s/::$//;
  8125. }
  8126. }
  8127. return ( $sig, $var, $pkg );
  8128. }
  8129. sub _parse_file {
  8130. my $self = shift;
  8131. my $filename = $self->{filename};
  8132. my $fh = IO::File->new( $filename )
  8133. or croak( "Can't open '$filename': $!" );
  8134. $self->_handle_bom($fh, $filename);
  8135. $self->_parse_fh($fh);
  8136. }
  8137. # Look for a UTF-8/UTF-16BE/UTF-16LE BOM at the beginning of the stream.
  8138. # If there's one, then skip it and set the :encoding layer appropriately.
  8139. sub _handle_bom {
  8140. my ($self, $fh, $filename) = @_;
  8141. my $pos = $fh->getpos;
  8142. return unless defined $pos;
  8143. my $buf = ' ' x 2;
  8144. my $count = $fh->read( $buf, length $buf );
  8145. return unless defined $count and $count >= 2;
  8146. my $encoding;
  8147. if ( $buf eq "\x{FE}\x{FF}" ) {
  8148. $encoding = 'UTF-16BE';
  8149. } elsif ( $buf eq "\x{FF}\x{FE}" ) {
  8150. $encoding = 'UTF-16LE';
  8151. } elsif ( $buf eq "\x{EF}\x{BB}" ) {
  8152. $buf = ' ';
  8153. $count = $fh->read( $buf, length $buf );
  8154. if ( defined $count and $count >= 1 and $buf eq "\x{BF}" ) {
  8155. $encoding = 'UTF-8';
  8156. }
  8157. }
  8158. if ( defined $encoding ) {
  8159. if ( "$]" >= 5.008 ) {
  8160. # $fh->binmode requires perl 5.10
  8161. binmode( $fh, ":encoding($encoding)" );
  8162. }
  8163. } else {
  8164. $fh->setpos($pos)
  8165. or croak( sprintf "Can't reset position to the top of '$filename'" );
  8166. }
  8167. return $encoding;
  8168. }
  8169. sub _parse_fh {
  8170. my ($self, $fh) = @_;
  8171. my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 );
  8172. my( @pkgs, %vers, %pod, @pod );
  8173. my $pkg = 'main';
  8174. my $pod_sect = '';
  8175. my $pod_data = '';
  8176. while (defined( my $line = <$fh> )) {
  8177. my $line_num = $.;
  8178. chomp( $line );
  8179. # From toke.c : any line that begins by "=X", where X is an alphabetic
  8180. # character, introduces a POD segment.
  8181. my $is_cut;
  8182. if ( $line =~ /^=([a-zA-Z].*)/ ) {
  8183. my $cmd = $1;
  8184. # Then it goes back to Perl code for "=cutX" where X is a non-alphabetic
  8185. # character (which includes the newline, but here we chomped it away).
  8186. $is_cut = $cmd =~ /^cut(?:[^a-zA-Z]|$)/;
  8187. $in_pod = !$is_cut;
  8188. }
  8189. if ( $in_pod ) {
  8190. if ( $line =~ /^=head[1-4]\s+(.+)\s*$/ ) {
  8191. push( @pod, $1 );
  8192. if ( $self->{collect_pod} && length( $pod_data ) ) {
  8193. $pod{$pod_sect} = $pod_data;
  8194. $pod_data = '';
  8195. }
  8196. $pod_sect = $1;
  8197. } elsif ( $self->{collect_pod} ) {
  8198. $pod_data .= "$line\n";
  8199. }
  8200. } elsif ( $is_cut ) {
  8201. if ( $self->{collect_pod} && length( $pod_data ) ) {
  8202. $pod{$pod_sect} = $pod_data;
  8203. $pod_data = '';
  8204. }
  8205. $pod_sect = '';
  8206. } else {
  8207. # Skip comments in code
  8208. next if $line =~ /^\s*#/;
  8209. # Would be nice if we could also check $in_string or something too
  8210. last if $line =~ /^__(?:DATA|END)__$/;
  8211. # parse $line to see if it's a $VERSION declaration
  8212. my( $vers_sig, $vers_fullname, $vers_pkg ) =
  8213. ($line =~ /VERSION/)
  8214. ? $self->_parse_version_expression( $line )
  8215. : ();
  8216. if ( $line =~ /$PKG_REGEXP/o ) {
  8217. $pkg = $1;
  8218. push( @pkgs, $pkg ) unless grep( $pkg eq $_, @pkgs );
  8219. $vers{$pkg} = $2 unless exists( $vers{$pkg} );
  8220. $need_vers = defined $2 ? 0 : 1;
  8221. # VERSION defined with full package spec, i.e. $Module::VERSION
  8222. } elsif ( $vers_fullname && $vers_pkg ) {
  8223. push( @pkgs, $vers_pkg ) unless grep( $vers_pkg eq $_, @pkgs );
  8224. $need_vers = 0 if $vers_pkg eq $pkg;
  8225. unless ( defined $vers{$vers_pkg} && length $vers{$vers_pkg} ) {
  8226. $vers{$vers_pkg} =
  8227. $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
  8228. }
  8229. # first non-comment line in undeclared package main is VERSION
  8230. } elsif ( !exists($vers{main}) && $pkg eq 'main' && $vers_fullname ) {
  8231. $need_vers = 0;
  8232. my $v =
  8233. $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
  8234. $vers{$pkg} = $v;
  8235. push( @pkgs, 'main' );
  8236. # first non-comment line in undeclared package defines package main
  8237. } elsif ( !exists($vers{main}) && $pkg eq 'main' && $line =~ /\w+/ ) {
  8238. $need_vers = 1;
  8239. $vers{main} = '';
  8240. push( @pkgs, 'main' );
  8241. # only keep if this is the first $VERSION seen
  8242. } elsif ( $vers_fullname && $need_vers ) {
  8243. $need_vers = 0;
  8244. my $v =
  8245. $self->_evaluate_version_line( $vers_sig, $vers_fullname, $line );
  8246. unless ( defined $vers{$pkg} && length $vers{$pkg} ) {
  8247. $vers{$pkg} = $v;
  8248. }
  8249. }
  8250. }
  8251. }
  8252. if ( $self->{collect_pod} && length($pod_data) ) {
  8253. $pod{$pod_sect} = $pod_data;
  8254. }
  8255. $self->{versions} = \%vers;
  8256. $self->{packages} = \@pkgs;
  8257. $self->{pod} = \%pod;
  8258. $self->{pod_headings} = \@pod;
  8259. }
  8260. {
  8261. my $pn = 0;
  8262. sub _evaluate_version_line {
  8263. my $self = shift;
  8264. my( $sigil, $var, $line ) = @_;
  8265. # Some of this code came from the ExtUtils:: hierarchy.
  8266. # We compile into $vsub because 'use version' would cause
  8267. # compiletime/runtime issues with local()
  8268. my $vsub;
  8269. $pn++; # everybody gets their own package
  8270. my $eval = qq{BEGIN { q# Hide from _packages_inside()
  8271. #; package Module::Metadata::_version::p$pn;
  8272. use version;
  8273. no strict;
  8274. \$vsub = sub {
  8275. local $sigil$var;
  8276. \$$var=undef;
  8277. $line;
  8278. \$$var
  8279. };
  8280. }};
  8281. local $^W;
  8282. # Try to get the $VERSION
  8283. eval $eval;
  8284. # some modules say $VERSION = $Foo::Bar::VERSION, but Foo::Bar isn't
  8285. # installed, so we need to hunt in ./lib for it
  8286. if ( $@ =~ /Can't locate/ && -d 'lib' ) {
  8287. local @INC = ('lib',@INC);
  8288. eval $eval;
  8289. }
  8290. warn "Error evaling version line '$eval' in $self->{filename}: $@\n"
  8291. if $@;
  8292. (ref($vsub) eq 'CODE') or
  8293. croak "failed to build version sub for $self->{filename}";
  8294. my $result = eval { $vsub->() };
  8295. croak "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n"
  8296. if $@;
  8297. # Upgrade it into a version object
  8298. my $version = eval { _dwim_version($result) };
  8299. croak "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n"
  8300. unless defined $version; # "0" is OK!
  8301. return $version;
  8302. }
  8303. }
  8304. # Try to DWIM when things fail the lax version test in obvious ways
  8305. {
  8306. my @version_prep = (
  8307. # Best case, it just works
  8308. sub { return shift },
  8309. # If we still don't have a version, try stripping any
  8310. # trailing junk that is prohibited by lax rules
  8311. sub {
  8312. my $v = shift;
  8313. $v =~ s{([0-9])[a-z-].*$}{$1}i; # 1.23-alpha or 1.23b
  8314. return $v;
  8315. },
  8316. # Activestate apparently creates custom versions like '1.23_45_01', which
  8317. # cause version.pm to think it's an invalid alpha. So check for that
  8318. # and strip them
  8319. sub {
  8320. my $v = shift;
  8321. my $num_dots = () = $v =~ m{(\.)}g;
  8322. my $num_unders = () = $v =~ m{(_)}g;
  8323. my $leading_v = substr($v,0,1) eq 'v';
  8324. if ( ! $leading_v && $num_dots < 2 && $num_unders > 1 ) {
  8325. $v =~ s{_}{}g;
  8326. $num_unders = () = $v =~ m{(_)}g;
  8327. }
  8328. return $v;
  8329. },
  8330. # Worst case, try numifying it like we would have before version objects
  8331. sub {
  8332. my $v = shift;
  8333. no warnings 'numeric';
  8334. return 0 + $v;
  8335. },
  8336. );
  8337. sub _dwim_version {
  8338. my ($result) = shift;
  8339. return $result if ref($result) eq 'version';
  8340. my ($version, $error);
  8341. for my $f (@version_prep) {
  8342. $result = $f->($result);
  8343. $version = eval { version->new($result) };
  8344. $error ||= $@ if $@; # capture first failure
  8345. last if defined $version;
  8346. }
  8347. croak $error unless defined $version;
  8348. return $version;
  8349. }
  8350. }
  8351. ############################################################
  8352. # accessors
  8353. sub name { $_[0]->{module} }
  8354. sub filename { $_[0]->{filename} }
  8355. sub packages_inside { @{$_[0]->{packages}} }
  8356. sub pod_inside { @{$_[0]->{pod_headings}} }
  8357. sub contains_pod { $#{$_[0]->{pod_headings}} }
  8358. sub version {
  8359. my $self = shift;
  8360. my $mod = shift || $self->{module};
  8361. my $vers;
  8362. if ( defined( $mod ) && length( $mod ) &&
  8363. exists( $self->{versions}{$mod} ) ) {
  8364. return $self->{versions}{$mod};
  8365. } else {
  8366. return undef;
  8367. }
  8368. }
  8369. sub pod {
  8370. my $self = shift;
  8371. my $sect = shift;
  8372. if ( defined( $sect ) && length( $sect ) &&
  8373. exists( $self->{pod}{$sect} ) ) {
  8374. return $self->{pod}{$sect};
  8375. } else {
  8376. return undef;
  8377. }
  8378. }
  8379. 1;
  8380. MODULE_METADATA
  8381.  
  8382. $fatpacked{"Parse/CPAN/Meta.pm"} = <<'PARSE_CPAN_META';
  8383. package Parse::CPAN::Meta;
  8384. use strict;
  8385. use Carp 'croak';
  8386. # UTF Support?
  8387. sub HAVE_UTF8 () { $] >= 5.007003 }
  8388. sub IO_LAYER () { $] >= 5.008001 ? ":utf8" : "" }
  8389. BEGIN {
  8390. if ( HAVE_UTF8 ) {
  8391. # The string eval helps hide this from Test::MinimumVersion
  8392. eval "require utf8;";
  8393. die "Failed to load UTF-8 support" if $@;
  8394. }
  8395. # Class structure
  8396. require 5.004;
  8397. require Exporter;
  8398. $Parse::CPAN::Meta::VERSION = '1.4404';
  8399. @Parse::CPAN::Meta::ISA = qw{ Exporter };
  8400. @Parse::CPAN::Meta::EXPORT_OK = qw{ Load LoadFile };
  8401. }
  8402. sub load_file {
  8403. my ($class, $filename) = @_;
  8404. if ($filename =~ /\.ya?ml$/) {
  8405. return $class->load_yaml_string(_slurp($filename));
  8406. }
  8407. if ($filename =~ /\.json$/) {
  8408. return $class->load_json_string(_slurp($filename));
  8409. }
  8410. croak("file type cannot be determined by filename");
  8411. }
  8412. sub load_yaml_string {
  8413. my ($class, $string) = @_;
  8414. my $backend = $class->yaml_backend();
  8415. my $data = eval { no strict 'refs'; &{"$backend\::Load"}($string) };
  8416. if ( $@ ) {
  8417. croak $backend->can('errstr') ? $backend->errstr : $@
  8418. }
  8419. return $data || {}; # in case document was valid but empty
  8420. }
  8421. sub load_json_string {
  8422. my ($class, $string) = @_;
  8423. return $class->json_backend()->new->decode($string);
  8424. }
  8425. sub yaml_backend {
  8426. local $Module::Load::Conditional::CHECK_INC_HASH = 1;
  8427. if (! defined $ENV{PERL_YAML_BACKEND} ) {
  8428. _can_load( 'CPAN::Meta::YAML', 0.002 )
  8429. or croak "CPAN::Meta::YAML 0.002 is not available\n";
  8430. return "CPAN::Meta::YAML";
  8431. }
  8432. else {
  8433. my $backend = $ENV{PERL_YAML_BACKEND};
  8434. _can_load( $backend )
  8435. or croak "Could not load PERL_YAML_BACKEND '$backend'\n";
  8436. $backend->can("Load")
  8437. or croak "PERL_YAML_BACKEND '$backend' does not implement Load()\n";
  8438. return $backend;
  8439. }
  8440. }
  8441. sub json_backend {
  8442. local $Module::Load::Conditional::CHECK_INC_HASH = 1;
  8443. if (! $ENV{PERL_JSON_BACKEND} or $ENV{PERL_JSON_BACKEND} eq 'JSON::PP') {
  8444. _can_load( 'JSON::PP' => 2.27103 )
  8445. or croak "JSON::PP 2.27103 is not available\n";
  8446. return 'JSON::PP';
  8447. }
  8448. else {
  8449. _can_load( 'JSON' => 2.5 )
  8450. or croak "JSON 2.5 is required for " .
  8451. "\$ENV{PERL_JSON_BACKEND} = '$ENV{PERL_JSON_BACKEND}'\n";
  8452. return "JSON";
  8453. }
  8454. }
  8455. sub _slurp {
  8456. open my $fh, "<" . IO_LAYER, "$_[0]"
  8457. or die "can't open $_[0] for reading: $!";
  8458. return do { local $/; <$fh> };
  8459. }
  8460. sub _can_load {
  8461. my ($module, $version) = @_;
  8462. (my $file = $module) =~ s{::}{/}g;
  8463. $file .= ".pm";
  8464. return 1 if $INC{$file};
  8465. return 0 if exists $INC{$file}; # prior load failed
  8466. eval { require $file; 1 }
  8467. or return 0;
  8468. if ( defined $version ) {
  8469. eval { $module->VERSION($version); 1 }
  8470. or return 0;
  8471. }
  8472. return 1;
  8473. }
  8474. # Kept for backwards compatibility only
  8475. # Create an object from a file
  8476. sub LoadFile ($) {
  8477. require CPAN::Meta::YAML;
  8478. return CPAN::Meta::YAML::LoadFile(shift)
  8479. or die CPAN::Meta::YAML->errstr;
  8480. }
  8481. # Parse a document from a string.
  8482. sub Load ($) {
  8483. require CPAN::Meta::YAML;
  8484. return CPAN::Meta::YAML::Load(shift)
  8485. or die CPAN::Meta::YAML->errstr;
  8486. }
  8487. 1;
  8488. __END__
  8489. PARSE_CPAN_META
  8490.  
  8491. $fatpacked{"lib/core/only.pm"} = <<'LIB_CORE_ONLY';
  8492. package lib::core::only;
  8493. use strict;
  8494. use warnings FATAL => 'all';
  8495. use Config;
  8496. sub import {
  8497. @INC = @Config{qw(privlibexp archlibexp)};
  8498. return
  8499. }
  8500. 1;
  8501. LIB_CORE_ONLY
  8502.  
  8503. $fatpacked{"local/lib.pm"} = <<'LOCAL_LIB';
  8504. use strict;
  8505. use warnings;
  8506. package local::lib;
  8507. use 5.008001; # probably works with earlier versions but I'm not supporting them
  8508. # (patches would, of course, be welcome)
  8509. use File::Spec ();
  8510. use File::Path ();
  8511. use Config;
  8512. our $VERSION = '1.008009'; # 1.8.9
  8513. our @KNOWN_FLAGS = qw(--self-contained --deactivate --deactivate-all);
  8514. sub DEACTIVATE_ONE () { 1 }
  8515. sub DEACTIVATE_ALL () { 2 }
  8516. sub INTERPOLATE_ENV () { 1 }
  8517. sub LITERAL_ENV () { 0 }
  8518. sub import {
  8519. my ($class, @args) = @_;
  8520. # Remember what PERL5LIB was when we started
  8521. my $perl5lib = $ENV{PERL5LIB} || '';
  8522. my %arg_store;
  8523. for my $arg (@args) {
  8524. # check for lethal dash first to stop processing before causing problems
  8525. if ($arg =~ /−/) {
  8526. die <<'DEATH';
  8527. WHOA THERE! It looks like you've got some fancy dashes in your commandline!
  8528. These are *not* the traditional -- dashes that software recognizes. You
  8529. probably got these by copy-pasting from the perldoc for this module as
  8530. rendered by a UTF8-capable formatter. This most typically happens on an OS X
  8531. terminal, but can happen elsewhere too. Please try again after replacing the
  8532. dashes with normal minus signs.
  8533. DEATH
  8534. }
  8535. elsif(grep { $arg eq $_ } @KNOWN_FLAGS) {
  8536. (my $flag = $arg) =~ s/--//;
  8537. $arg_store{$flag} = 1;
  8538. }
  8539. elsif($arg =~ /^--/) {
  8540. die "Unknown import argument: $arg";
  8541. }
  8542. else {
  8543. # assume that what's left is a path
  8544. $arg_store{path} = $arg;
  8545. }
  8546. }
  8547. if($arg_store{'self-contained'}) {
  8548. 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";
  8549. }
  8550. my $deactivating = 0;
  8551. if ($arg_store{deactivate}) {
  8552. $deactivating = DEACTIVATE_ONE;
  8553. }
  8554. if ($arg_store{'deactivate-all'}) {
  8555. $deactivating = DEACTIVATE_ALL;
  8556. }
  8557. $arg_store{path} = $class->resolve_path($arg_store{path});
  8558. $class->setup_local_lib_for($arg_store{path}, $deactivating);
  8559. for (@INC) { # Untaint @INC
  8560. next if ref; # Skip entry if it is an ARRAY, CODE, blessed, etc.
  8561. m/(.*)/ and $_ = $1;
  8562. }
  8563. }
  8564. sub pipeline;
  8565. sub pipeline {
  8566. my @methods = @_;
  8567. my $last = pop(@methods);
  8568. if (@methods) {
  8569. \sub {
  8570. my ($obj, @args) = @_;
  8571. $obj->${pipeline @methods}(
  8572. $obj->$last(@args)
  8573. );
  8574. };
  8575. } else {
  8576. \sub {
  8577. shift->$last(@_);
  8578. };
  8579. }
  8580. }
  8581. sub _uniq {
  8582. my %seen;
  8583. grep { ! $seen{$_}++ } @_;
  8584. }
  8585. sub resolve_path {
  8586. my ($class, $path) = @_;
  8587. $class->${pipeline qw(
  8588. resolve_relative_path
  8589. resolve_home_path
  8590. resolve_empty_path
  8591. )}($path);
  8592. }
  8593. sub resolve_empty_path {
  8594. my ($class, $path) = @_;
  8595. if (defined $path) {
  8596. $path;
  8597. } else {
  8598. '~/perl5';
  8599. }
  8600. }
  8601. sub resolve_home_path {
  8602. my ($class, $path) = @_;
  8603. return $path unless ($path =~ /^~/);
  8604. my ($user) = ($path =~ /^~([^\/]+)/); # can assume ^~ so undef for 'us'
  8605. my $tried_file_homedir;
  8606. my $homedir = do {
  8607. if (eval { require File::HomeDir } && $File::HomeDir::VERSION >= 0.65) {
  8608. $tried_file_homedir = 1;
  8609. if (defined $user) {
  8610. File::HomeDir->users_home($user);
  8611. } else {
  8612. File::HomeDir->my_home;
  8613. }
  8614. } else {
  8615. if (defined $user) {
  8616. (getpwnam $user)[7];
  8617. } else {
  8618. if (defined $ENV{HOME}) {
  8619. $ENV{HOME};
  8620. } else {
  8621. (getpwuid $<)[7];
  8622. }
  8623. }
  8624. }
  8625. };
  8626. unless (defined $homedir) {
  8627. require Carp;
  8628. Carp::croak(
  8629. "Couldn't resolve homedir for "
  8630. .(defined $user ? $user : 'current user')
  8631. .($tried_file_homedir ? '' : ' - consider installing File::HomeDir')
  8632. );
  8633. }
  8634. $path =~ s/^~[^\/]*/$homedir/;
  8635. $path;
  8636. }
  8637. sub resolve_relative_path {
  8638. my ($class, $path) = @_;
  8639. $path = File::Spec->rel2abs($path);
  8640. }
  8641. sub setup_local_lib_for {
  8642. my ($class, $path, $deactivating) = @_;
  8643. my $interpolate = LITERAL_ENV;
  8644. my @active_lls = $class->active_paths;
  8645. $class->ensure_dir_structure_for($path);
  8646. # On Win32 directories often contain spaces. But some parts of the CPAN
  8647. # toolchain don't like that. To avoid this, GetShortPathName() gives us
  8648. # an alternate representation that has none.
  8649. # This only works if the directory already exists.
  8650. $path = Win32::GetShortPathName($path) if $^O eq 'MSWin32';
  8651. if (! $deactivating) {
  8652. if (@active_lls && $active_lls[-1] eq $path) {
  8653. exit 0 if $0 eq '-';
  8654. return; # Asked to add what's already at the top of the stack
  8655. } elsif (grep { $_ eq $path} @active_lls) {
  8656. # Asked to add a dir that's lower in the stack -- so we remove it from
  8657. # where it is, and then add it back at the top.
  8658. $class->setup_env_hash_for($path, DEACTIVATE_ONE);
  8659. # Which means we can no longer output "PERL5LIB=...:$PERL5LIB" stuff
  8660. # anymore because we're taking something *out*.
  8661. $interpolate = INTERPOLATE_ENV;
  8662. }
  8663. }
  8664. if ($0 eq '-') {
  8665. $class->print_environment_vars_for($path, $deactivating, $interpolate);
  8666. exit 0;
  8667. } else {
  8668. $class->setup_env_hash_for($path, $deactivating);
  8669. my $arch_dir = $Config{archname};
  8670. @INC = _uniq(
  8671. (
  8672. # Inject $path/$archname for each path in PERL5LIB
  8673. map { ( File::Spec->catdir($_, $arch_dir), $_ ) }
  8674. split($Config{path_sep}, $ENV{PERL5LIB})
  8675. ),
  8676. @INC
  8677. );
  8678. }
  8679. }
  8680. sub install_base_bin_path {
  8681. my ($class, $path) = @_;
  8682. File::Spec->catdir($path, 'bin');
  8683. }
  8684. sub install_base_perl_path {
  8685. my ($class, $path) = @_;
  8686. File::Spec->catdir($path, 'lib', 'perl5');
  8687. }
  8688. sub install_base_arch_path {
  8689. my ($class, $path) = @_;
  8690. File::Spec->catdir($class->install_base_perl_path($path), $Config{archname});
  8691. }
  8692. sub ensure_dir_structure_for {
  8693. my ($class, $path) = @_;
  8694. unless (-d $path) {
  8695. warn "Attempting to create directory ${path}\n";
  8696. }
  8697. File::Path::mkpath($path);
  8698. return
  8699. }
  8700. sub guess_shelltype {
  8701. my $shellbin = 'sh';
  8702. if(defined $ENV{'SHELL'}) {
  8703. my @shell_bin_path_parts = File::Spec->splitpath($ENV{'SHELL'});
  8704. $shellbin = $shell_bin_path_parts[-1];
  8705. }
  8706. my $shelltype = do {
  8707. local $_ = $shellbin;
  8708. if(/csh/) {
  8709. 'csh'
  8710. } else {
  8711. 'bourne'
  8712. }
  8713. };
  8714. # Both Win32 and Cygwin have $ENV{COMSPEC} set.
  8715. if (defined $ENV{'COMSPEC'} && $^O ne 'cygwin') {
  8716. my @shell_bin_path_parts = File::Spec->splitpath($ENV{'COMSPEC'});
  8717. $shellbin = $shell_bin_path_parts[-1];
  8718. $shelltype = do {
  8719. local $_ = $shellbin;
  8720. if(/command\.com/) {
  8721. 'win32'
  8722. } elsif(/cmd\.exe/) {
  8723. 'win32'
  8724. } elsif(/4nt\.exe/) {
  8725. 'win32'
  8726. } else {
  8727. $shelltype
  8728. }
  8729. };
  8730. }
  8731. return $shelltype;
  8732. }
  8733. sub print_environment_vars_for {
  8734. my ($class, $path, $deactivating, $interpolate) = @_;
  8735. print $class->environment_vars_string_for($path, $deactivating, $interpolate);
  8736. }
  8737. sub environment_vars_string_for {
  8738. my ($class, $path, $deactivating, $interpolate) = @_;
  8739. my @envs = $class->build_environment_vars_for($path, $deactivating, $interpolate);
  8740. my $out = '';
  8741. # rather basic csh detection, goes on the assumption that something won't
  8742. # call itself csh unless it really is. also, default to bourne in the
  8743. # pathological situation where a user doesn't have $ENV{SHELL} defined.
  8744. # note also that shells with funny names, like zoid, are assumed to be
  8745. # bourne.
  8746. my $shelltype = $class->guess_shelltype;
  8747. while (@envs) {
  8748. my ($name, $value) = (shift(@envs), shift(@envs));
  8749. $value =~ s/(\\")/\\$1/g if defined $value;
  8750. $out .= $class->${\"build_${shelltype}_env_declaration"}($name, $value);
  8751. }
  8752. return $out;
  8753. }
  8754. # simple routines that take two arguments: an %ENV key and a value. return
  8755. # strings that are suitable for passing directly to the relevant shell to set
  8756. # said key to said value.
  8757. sub build_bourne_env_declaration {
  8758. my $class = shift;
  8759. my($name, $value) = @_;
  8760. return defined($value) ? qq{export ${name}="${value}";\n} : qq{unset ${name};\n};
  8761. }
  8762. sub build_csh_env_declaration {
  8763. my $class = shift;
  8764. my($name, $value) = @_;
  8765. return defined($value) ? qq{setenv ${name} "${value}"\n} : qq{unsetenv ${name}\n};
  8766. }
  8767. sub build_win32_env_declaration {
  8768. my $class = shift;
  8769. my($name, $value) = @_;
  8770. return defined($value) ? qq{set ${name}=${value}\n} : qq{set ${name}=\n};
  8771. }
  8772. sub setup_env_hash_for {
  8773. my ($class, $path, $deactivating) = @_;
  8774. my %envs = $class->build_environment_vars_for($path, $deactivating, INTERPOLATE_ENV);
  8775. @ENV{keys %envs} = values %envs;
  8776. }
  8777. sub build_environment_vars_for {
  8778. my ($class, $path, $deactivating, $interpolate) = @_;
  8779. if ($deactivating == DEACTIVATE_ONE) {
  8780. return $class->build_deactivate_environment_vars_for($path, $interpolate);
  8781. } elsif ($deactivating == DEACTIVATE_ALL) {
  8782. return $class->build_deact_all_environment_vars_for($path, $interpolate);
  8783. } else {
  8784. return $class->build_activate_environment_vars_for($path, $interpolate);
  8785. }
  8786. }
  8787. # Build an environment value for a variable like PATH from a list of paths.
  8788. # References to existing variables are given as references to the variable name.
  8789. # Duplicates are removed.
  8790. #
  8791. # options:
  8792. # - interpolate: INTERPOLATE_ENV/LITERAL_ENV
  8793. # - exists: paths are included only if they exist (default: interpolate == INTERPOLATE_ENV)
  8794. # - filter: function to apply to each path do decide if it must be included
  8795. # - empty: the value to return in the case of empty value
  8796. my %ENV_LIST_VALUE_DEFAULTS = (
  8797. interpolate => INTERPOLATE_ENV,
  8798. exists => undef,
  8799. filter => sub { 1 },
  8800. empty => undef,
  8801. );
  8802. sub _env_list_value {
  8803. my $options = shift;
  8804. die(sprintf "unknown option '$_' at %s line %u\n", (caller)[1..2])
  8805. for grep { !exists $ENV_LIST_VALUE_DEFAULTS{$_} } keys %$options;
  8806. my %options = (%ENV_LIST_VALUE_DEFAULTS, %{ $options });
  8807. $options{exists} = $options{interpolate} == INTERPOLATE_ENV
  8808. unless defined $options{exists};
  8809. my %seen;
  8810. my $value = join($Config{path_sep}, map {
  8811. ref $_ ? ($^O eq 'MSWin32' ? "%${$_}%" : "\$${$_}") : $_
  8812. } grep {
  8813. ref $_ || (defined $_
  8814. && length($_) > 0
  8815. && !$seen{$_}++
  8816. && $options{filter}->($_)
  8817. && (!$options{exists} || -e $_))
  8818. } map {
  8819. if (ref $_ eq 'SCALAR' && $options{interpolate} == INTERPOLATE_ENV) {
  8820. exists $ENV{${$_}} ? (split /\Q$Config{path_sep}/, $ENV{${$_}}) : ()
  8821. } else {
  8822. $_
  8823. }
  8824. } @_);
  8825. return length($value) ? $value : $options{empty};
  8826. }
  8827. sub build_activate_environment_vars_for {
  8828. my ($class, $path, $interpolate) = @_;
  8829. return (
  8830. PERL_LOCAL_LIB_ROOT =>
  8831. _env_list_value(
  8832. { interpolate => $interpolate, exists => 0, empty => '' },
  8833. \'PERL_LOCAL_LIB_ROOT',
  8834. $path,
  8835. ),
  8836. PERL_MB_OPT => "--install_base ${path}",
  8837. PERL_MM_OPT => "INSTALL_BASE=${path}",
  8838. PERL5LIB =>
  8839. _env_list_value(
  8840. { interpolate => $interpolate, exists => 0, empty => '' },
  8841. $class->install_base_perl_path($path),
  8842. \'PERL5LIB',
  8843. ),
  8844. PATH => _env_list_value(
  8845. { interpolate => $interpolate, exists => 0, empty => '' },
  8846. $class->install_base_bin_path($path),
  8847. \'PATH',
  8848. ),
  8849. )
  8850. }
  8851. sub active_paths {
  8852. my ($class) = @_;
  8853. return () unless defined $ENV{PERL_LOCAL_LIB_ROOT};
  8854. return grep { $_ ne '' } split /\Q$Config{path_sep}/, $ENV{PERL_LOCAL_LIB_ROOT};
  8855. }
  8856. sub build_deactivate_environment_vars_for {
  8857. my ($class, $path, $interpolate) = @_;
  8858. my @active_lls = $class->active_paths;
  8859. if (!grep { $_ eq $path } @active_lls) {
  8860. warn "Tried to deactivate inactive local::lib '$path'\n";
  8861. return ();
  8862. }
  8863. my $perl_path = $class->install_base_perl_path($path);
  8864. my $arch_path = $class->install_base_arch_path($path);
  8865. my $bin_path = $class->install_base_bin_path($path);
  8866. my %env = (
  8867. PERL_LOCAL_LIB_ROOT => _env_list_value(
  8868. {
  8869. exists => 0,
  8870. },
  8871. grep { $_ ne $path } @active_lls
  8872. ),
  8873. PERL5LIB => _env_list_value(
  8874. {
  8875. exists => 0,
  8876. filter => sub {
  8877. $_ ne $perl_path && $_ ne $arch_path
  8878. },
  8879. },
  8880. \'PERL5LIB',
  8881. ),
  8882. PATH => _env_list_value(
  8883. {
  8884. exists => 0,
  8885. filter => sub { $_ ne $bin_path },
  8886. },
  8887. \'PATH',
  8888. ),
  8889. );
  8890. # If removing ourselves from the "top of the stack", set install paths to
  8891. # correspond with the new top of stack.
  8892. if ($active_lls[-1] eq $path) {
  8893. my $new_top = $active_lls[-2];
  8894. $env{PERL_MB_OPT} = defined($new_top) ? "--install_base ${new_top}" : undef;
  8895. $env{PERL_MM_OPT} = defined($new_top) ? "INSTALL_BASE=${new_top}" : undef;
  8896. }
  8897. return %env;
  8898. }
  8899. sub build_deact_all_environment_vars_for {
  8900. my ($class, $path, $interpolate) = @_;
  8901. my @active_lls = $class->active_paths;
  8902. my %perl_paths = map { (
  8903. $class->install_base_perl_path($_) => 1,
  8904. $class->install_base_arch_path($_) => 1
  8905. ) } @active_lls;
  8906. my %bin_paths = map { (
  8907. $class->install_base_bin_path($_) => 1,
  8908. ) } @active_lls;
  8909. my %env = (
  8910. PERL_LOCAL_LIB_ROOT => undef,
  8911. PERL_MM_OPT => undef,
  8912. PERL_MB_OPT => undef,
  8913. PERL5LIB => _env_list_value(
  8914. {
  8915. exists => 0,
  8916. filter => sub {
  8917. ! scalar grep { exists $perl_paths{$_} } $_[0]
  8918. },
  8919. },
  8920. \'PERL5LIB'
  8921. ),
  8922. PATH => _env_list_value(
  8923. {
  8924. exists => 0,
  8925. filter => sub {
  8926. ! scalar grep { exists $bin_paths{$_} } $_[0]
  8927. },
  8928. },
  8929. \'PATH'
  8930. ),
  8931. );
  8932. return %env;
  8933. }
  8934. 1;
  8935. LOCAL_LIB
  8936.  
  8937. $fatpacked{"version.pm"} = <<'VERSION';
  8938. #!perl -w
  8939. package version;
  8940. use 5.005_04;
  8941. use strict;
  8942. use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv);
  8943. $VERSION = 0.9901;
  8944. $CLASS = 'version';
  8945. #--------------------------------------------------------------------------#
  8946. # Version regexp components
  8947. #--------------------------------------------------------------------------#
  8948. # Fraction part of a decimal version number. This is a common part of
  8949. # both strict and lax decimal versions
  8950. my $FRACTION_PART = qr/\.[0-9]+/;
  8951. # First part of either decimal or dotted-decimal strict version number.
  8952. # Unsigned integer with no leading zeroes (except for zero itself) to
  8953. # avoid confusion with octal.
  8954. my $STRICT_INTEGER_PART = qr/0|[1-9][0-9]*/;
  8955. # First part of either decimal or dotted-decimal lax version number.
  8956. # Unsigned integer, but allowing leading zeros. Always interpreted
  8957. # as decimal. However, some forms of the resulting syntax give odd
  8958. # results if used as ordinary Perl expressions, due to how perl treats
  8959. # octals. E.g.
  8960. # version->new("010" ) == 10
  8961. # version->new( 010 ) == 8
  8962. # version->new( 010.2) == 82 # "8" . "2"
  8963. my $LAX_INTEGER_PART = qr/[0-9]+/;
  8964. # Second and subsequent part of a strict dotted-decimal version number.
  8965. # Leading zeroes are permitted, and the number is always decimal.
  8966. # Limited to three digits to avoid overflow when converting to decimal
  8967. # form and also avoid problematic style with excessive leading zeroes.
  8968. my $STRICT_DOTTED_DECIMAL_PART = qr/\.[0-9]{1,3}/;
  8969. # Second and subsequent part of a lax dotted-decimal version number.
  8970. # Leading zeroes are permitted, and the number is always decimal. No
  8971. # limit on the numerical value or number of digits, so there is the
  8972. # possibility of overflow when converting to decimal form.
  8973. my $LAX_DOTTED_DECIMAL_PART = qr/\.[0-9]+/;
  8974. # Alpha suffix part of lax version number syntax. Acts like a
  8975. # dotted-decimal part.
  8976. my $LAX_ALPHA_PART = qr/_[0-9]+/;
  8977. #--------------------------------------------------------------------------#
  8978. # Strict version regexp definitions
  8979. #--------------------------------------------------------------------------#
  8980. # Strict decimal version number.
  8981. my $STRICT_DECIMAL_VERSION =
  8982. qr/ $STRICT_INTEGER_PART $FRACTION_PART? /x;
  8983. # Strict dotted-decimal version number. Must have both leading "v" and
  8984. # at least three parts, to avoid confusion with decimal syntax.
  8985. my $STRICT_DOTTED_DECIMAL_VERSION =
  8986. qr/ v $STRICT_INTEGER_PART $STRICT_DOTTED_DECIMAL_PART{2,} /x;
  8987. # Complete strict version number syntax -- should generally be used
  8988. # anchored: qr/ \A $STRICT \z /x
  8989. $STRICT =
  8990. qr/ $STRICT_DECIMAL_VERSION | $STRICT_DOTTED_DECIMAL_VERSION /x;
  8991. #--------------------------------------------------------------------------#
  8992. # Lax version regexp definitions
  8993. #--------------------------------------------------------------------------#
  8994. # Lax decimal version number. Just like the strict one except for
  8995. # allowing an alpha suffix or allowing a leading or trailing
  8996. # decimal-point
  8997. my $LAX_DECIMAL_VERSION =
  8998. qr/ $LAX_INTEGER_PART (?: \. | $FRACTION_PART $LAX_ALPHA_PART? )?
  8999. |
  9000. $FRACTION_PART $LAX_ALPHA_PART?
  9001. /x;
  9002. # Lax dotted-decimal version number. Distinguished by having either
  9003. # leading "v" or at least three non-alpha parts. Alpha part is only
  9004. # permitted if there are at least two non-alpha parts. Strangely
  9005. # enough, without the leading "v", Perl takes .1.2 to mean v0.1.2,
  9006. # so when there is no "v", the leading part is optional
  9007. my $LAX_DOTTED_DECIMAL_VERSION =
  9008. qr/
  9009. v $LAX_INTEGER_PART (?: $LAX_DOTTED_DECIMAL_PART+ $LAX_ALPHA_PART? )?
  9010. |
  9011. $LAX_INTEGER_PART? $LAX_DOTTED_DECIMAL_PART{2,} $LAX_ALPHA_PART?
  9012. /x;
  9013. # Complete lax version number syntax -- should generally be used
  9014. # anchored: qr/ \A $LAX \z /x
  9015. #
  9016. # The string 'undef' is a special case to make for easier handling
  9017. # of return values from ExtUtils::MM->parse_version
  9018. $LAX =
  9019. qr/ undef | $LAX_DECIMAL_VERSION | $LAX_DOTTED_DECIMAL_VERSION /x;
  9020. #--------------------------------------------------------------------------#
  9021. {
  9022. local $SIG{'__DIE__'};
  9023. eval "use version::vxs $VERSION";
  9024. if ( $@ ) { # don't have the XS version installed
  9025. eval "use version::vpp $VERSION"; # don't tempt fate
  9026. die "$@" if ( $@ );
  9027. push @ISA, "version::vpp";
  9028. local $^W;
  9029. *version::qv = \&version::vpp::qv;
  9030. *version::declare = \&version::vpp::declare;
  9031. *version::_VERSION = \&version::vpp::_VERSION;
  9032. *version::vcmp = \&version::vpp::vcmp;
  9033. if ($] >= 5.009000) {
  9034. no strict 'refs';
  9035. *version::stringify = \&version::vpp::stringify;
  9036. *{'version::(""'} = \&version::vpp::stringify;
  9037. *{'version::(<=>'} = \&version::vpp::vcmp;
  9038. *version::new = \&version::vpp::new;
  9039. *version::parse = \&version::vpp::parse;
  9040. }
  9041. }
  9042. else { # use XS module
  9043. push @ISA, "version::vxs";
  9044. local $^W;
  9045. *version::declare = \&version::vxs::declare;
  9046. *version::qv = \&version::vxs::qv;
  9047. *version::_VERSION = \&version::vxs::_VERSION;
  9048. *version::vcmp = \&version::vxs::VCMP;
  9049. if ($] >= 5.009000) {
  9050. no strict 'refs';
  9051. *version::stringify = \&version::vxs::stringify;
  9052. *{'version::(""'} = \&version::vxs::stringify;
  9053. *{'version::(<=>'} = \&version::vxs::VCMP;
  9054. *version::new = \&version::vxs::new;
  9055. *version::parse = \&version::vxs::parse;
  9056. }
  9057. }
  9058. }
  9059. # Preloaded methods go here.
  9060. sub import {
  9061. no strict 'refs';
  9062. my ($class) = shift;
  9063. # Set up any derived class
  9064. unless ($class eq 'version') {
  9065. local $^W;
  9066. *{$class.'::declare'} = \&version::declare;
  9067. *{$class.'::qv'} = \&version::qv;
  9068. }
  9069. my %args;
  9070. if (@_) { # any remaining terms are arguments
  9071. map { $args{$_} = 1 } @_
  9072. }
  9073. else { # no parameters at all on use line
  9074. %args =
  9075. (
  9076. qv => 1,
  9077. 'UNIVERSAL::VERSION' => 1,
  9078. );
  9079. }
  9080. my $callpkg = caller();
  9081. if (exists($args{declare})) {
  9082. *{$callpkg.'::declare'} =
  9083. sub {return $class->declare(shift) }
  9084. unless defined(&{$callpkg.'::declare'});
  9085. }
  9086. if (exists($args{qv})) {
  9087. *{$callpkg.'::qv'} =
  9088. sub {return $class->qv(shift) }
  9089. unless defined(&{$callpkg.'::qv'});
  9090. }
  9091. if (exists($args{'UNIVERSAL::VERSION'})) {
  9092. local $^W;
  9093. *UNIVERSAL::VERSION
  9094. = \&version::_VERSION;
  9095. }
  9096. if (exists($args{'VERSION'})) {
  9097. *{$callpkg.'::VERSION'} = \&version::_VERSION;
  9098. }
  9099. if (exists($args{'is_strict'})) {
  9100. *{$callpkg.'::is_strict'} = \&version::is_strict
  9101. unless defined(&{$callpkg.'::is_strict'});
  9102. }
  9103. if (exists($args{'is_lax'})) {
  9104. *{$callpkg.'::is_lax'} = \&version::is_lax
  9105. unless defined(&{$callpkg.'::is_lax'});
  9106. }
  9107. }
  9108. sub is_strict { defined $_[0] && $_[0] =~ qr/ \A $STRICT \z /x }
  9109. sub is_lax { defined $_[0] && $_[0] =~ qr/ \A $LAX \z /x }
  9110. 1;
  9111. VERSION
  9112.  
  9113. $fatpacked{"version/vpp.pm"} = <<'VERSION_VPP';
  9114. package charstar;
  9115. # a little helper class to emulate C char* semantics in Perl
  9116. # so that prescan_version can use the same code as in C
  9117. use overload (
  9118. '""' => \&thischar,
  9119. '0+' => \&thischar,
  9120. '++' => \&increment,
  9121. '--' => \&decrement,
  9122. '+' => \&plus,
  9123. '-' => \&minus,
  9124. '*' => \&multiply,
  9125. 'cmp' => \&cmp,
  9126. '<=>' => \&spaceship,
  9127. 'bool' => \&thischar,
  9128. '=' => \&clone,
  9129. );
  9130. sub new {
  9131. my ($self, $string) = @_;
  9132. my $class = ref($self) || $self;
  9133. my $obj = {
  9134. string => [split(//,$string)],
  9135. current => 0,
  9136. };
  9137. return bless $obj, $class;
  9138. }
  9139. sub thischar {
  9140. my ($self) = @_;
  9141. my $last = $#{$self->{string}};
  9142. my $curr = $self->{current};
  9143. if ($curr >= 0 && $curr <= $last) {
  9144. return $self->{string}->[$curr];
  9145. }
  9146. else {
  9147. return '';
  9148. }
  9149. }
  9150. sub increment {
  9151. my ($self) = @_;
  9152. $self->{current}++;
  9153. }
  9154. sub decrement {
  9155. my ($self) = @_;
  9156. $self->{current}--;
  9157. }
  9158. sub plus {
  9159. my ($self, $offset) = @_;
  9160. my $rself = $self->clone;
  9161. $rself->{current} += $offset;
  9162. return $rself;
  9163. }
  9164. sub minus {
  9165. my ($self, $offset) = @_;
  9166. my $rself = $self->clone;
  9167. $rself->{current} -= $offset;
  9168. return $rself;
  9169. }
  9170. sub multiply {
  9171. my ($left, $right, $swapped) = @_;
  9172. my $char = $left->thischar();
  9173. return $char * $right;
  9174. }
  9175. sub spaceship {
  9176. my ($left, $right, $swapped) = @_;
  9177. unless (ref($right)) { # not an object already
  9178. $right = $left->new($right);
  9179. }
  9180. return $left->{current} <=> $right->{current};
  9181. }
  9182. sub cmp {
  9183. my ($left, $right, $swapped) = @_;
  9184. unless (ref($right)) { # not an object already
  9185. if (length($right) == 1) { # comparing single character only
  9186. return $left->thischar cmp $right;
  9187. }
  9188. $right = $left->new($right);
  9189. }
  9190. return $left->currstr cmp $right->currstr;
  9191. }
  9192. sub bool {
  9193. my ($self) = @_;
  9194. my $char = $self->thischar;
  9195. return ($char ne '');
  9196. }
  9197. sub clone {
  9198. my ($left, $right, $swapped) = @_;
  9199. $right = {
  9200. string => [@{$left->{string}}],
  9201. current => $left->{current},
  9202. };
  9203. return bless $right, ref($left);
  9204. }
  9205. sub currstr {
  9206. my ($self, $s) = @_;
  9207. my $curr = $self->{current};
  9208. my $last = $#{$self->{string}};
  9209. if (defined($s) && $s->{current} < $last) {
  9210. $last = $s->{current};
  9211. }
  9212. my $string = join('', @{$self->{string}}[$curr..$last]);
  9213. return $string;
  9214. }
  9215. package version::vpp;
  9216. use strict;
  9217. use POSIX qw/locale_h/;
  9218. use locale;
  9219. use vars qw ($VERSION @ISA @REGEXS);
  9220. $VERSION = 0.9901;
  9221. use overload (
  9222. '""' => \&stringify,
  9223. '0+' => \&numify,
  9224. 'cmp' => \&vcmp,
  9225. '<=>' => \&vcmp,
  9226. 'bool' => \&vbool,
  9227. '+' => \&vnoop,
  9228. '-' => \&vnoop,
  9229. '*' => \&vnoop,
  9230. '/' => \&vnoop,
  9231. '+=' => \&vnoop,
  9232. '-=' => \&vnoop,
  9233. '*=' => \&vnoop,
  9234. '/=' => \&vnoop,
  9235. 'abs' => \&vnoop,
  9236. );
  9237. eval "use warnings";
  9238. if ($@) {
  9239. eval '
  9240. package
  9241. warnings;
  9242. sub enabled {return $^W;}
  9243. 1;
  9244. ';
  9245. }
  9246. my $VERSION_MAX = 0x7FFFFFFF;
  9247. # implement prescan_version as closely to the C version as possible
  9248. use constant TRUE => 1;
  9249. use constant FALSE => 0;
  9250. sub isDIGIT {
  9251. my ($char) = shift->thischar();
  9252. return ($char =~ /\d/);
  9253. }
  9254. sub isALPHA {
  9255. my ($char) = shift->thischar();
  9256. return ($char =~ /[a-zA-Z]/);
  9257. }
  9258. sub isSPACE {
  9259. my ($char) = shift->thischar();
  9260. return ($char =~ /\s/);
  9261. }
  9262. sub BADVERSION {
  9263. my ($s, $errstr, $error) = @_;
  9264. if ($errstr) {
  9265. $$errstr = $error;
  9266. }
  9267. return $s;
  9268. }
  9269. sub prescan_version {
  9270. my ($s, $strict, $errstr, $sqv, $ssaw_decimal, $swidth, $salpha) = @_;
  9271. my $qv = defined $sqv ? $$sqv : FALSE;
  9272. my $saw_decimal = defined $ssaw_decimal ? $$ssaw_decimal : 0;
  9273. my $width = defined $swidth ? $$swidth : 3;
  9274. my $alpha = defined $salpha ? $$salpha : FALSE;
  9275. my $d = $s;
  9276. if ($qv && isDIGIT($d)) {
  9277. goto dotted_decimal_version;
  9278. }
  9279. if ($d eq 'v') { # explicit v-string
  9280. $d++;
  9281. if (isDIGIT($d)) {
  9282. $qv = TRUE;
  9283. }
  9284. else { # degenerate v-string
  9285. # requires v1.2.3
  9286. return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
  9287. }
  9288. dotted_decimal_version:
  9289. if ($strict && $d eq '0' && isDIGIT($d+1)) {
  9290. # no leading zeros allowed
  9291. return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)");
  9292. }
  9293. while (isDIGIT($d)) { # integer part
  9294. $d++;
  9295. }
  9296. if ($d eq '.')
  9297. {
  9298. $saw_decimal++;
  9299. $d++; # decimal point
  9300. }
  9301. else
  9302. {
  9303. if ($strict) {
  9304. # require v1.2.3
  9305. return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
  9306. }
  9307. else {
  9308. goto version_prescan_finish;
  9309. }
  9310. }
  9311. {
  9312. my $i = 0;
  9313. my $j = 0;
  9314. while (isDIGIT($d)) { # just keep reading
  9315. $i++;
  9316. while (isDIGIT($d)) {
  9317. $d++; $j++;
  9318. # maximum 3 digits between decimal
  9319. if ($strict && $j > 3) {
  9320. return BADVERSION($s,$errstr,"Invalid version format (maximum 3 digits between decimals)");
  9321. }
  9322. }
  9323. if ($d eq '_') {
  9324. if ($strict) {
  9325. return BADVERSION($s,$errstr,"Invalid version format (no underscores)");
  9326. }
  9327. if ( $alpha ) {
  9328. return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)");
  9329. }
  9330. $d++;
  9331. $alpha = TRUE;
  9332. }
  9333. elsif ($d eq '.') {
  9334. if ($alpha) {
  9335. return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)");
  9336. }
  9337. $saw_decimal++;
  9338. $d++;
  9339. }
  9340. elsif (!isDIGIT($d)) {
  9341. last;
  9342. }
  9343. $j = 0;
  9344. }
  9345. if ($strict && $i < 2) {
  9346. # requires v1.2.3
  9347. return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
  9348. }
  9349. }
  9350. } # end if dotted-decimal
  9351. else
  9352. { # decimal versions
  9353. my $j = 0;
  9354. # special $strict case for leading '.' or '0'
  9355. if ($strict) {
  9356. if ($d eq '.') {
  9357. return BADVERSION($s,$errstr,"Invalid version format (0 before decimal required)");
  9358. }
  9359. if ($d eq '0' && isDIGIT($d+1)) {
  9360. return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)");
  9361. }
  9362. }
  9363. # and we never support negative version numbers
  9364. if ($d eq '-') {
  9365. return BADVERSION($s,$errstr,"Invalid version format (negative version number)");
  9366. }
  9367. # consume all of the integer part
  9368. while (isDIGIT($d)) {
  9369. $d++;
  9370. }
  9371. # look for a fractional part
  9372. if ($d eq '.') {
  9373. # we found it, so consume it
  9374. $saw_decimal++;
  9375. $d++;
  9376. }
  9377. elsif (!$d || $d eq ';' || isSPACE($d) || $d eq '}') {
  9378. if ( $d == $s ) {
  9379. # found nothing
  9380. return BADVERSION($s,$errstr,"Invalid version format (version required)");
  9381. }
  9382. # found just an integer
  9383. goto version_prescan_finish;
  9384. }
  9385. elsif ( $d == $s ) {
  9386. # didn't find either integer or period
  9387. return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)");
  9388. }
  9389. elsif ($d eq '_') {
  9390. # underscore can't come after integer part
  9391. if ($strict) {
  9392. return BADVERSION($s,$errstr,"Invalid version format (no underscores)");
  9393. }
  9394. elsif (isDIGIT($d+1)) {
  9395. return BADVERSION($s,$errstr,"Invalid version format (alpha without decimal)");
  9396. }
  9397. else {
  9398. return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)");
  9399. }
  9400. }
  9401. elsif ($d) {
  9402. # anything else after integer part is just invalid data
  9403. return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)");
  9404. }
  9405. # scan the fractional part after the decimal point
  9406. if ($d && !isDIGIT($d) && ($strict || ! ($d eq ';' || isSPACE($d) || $d eq '}') )) {
  9407. # $strict or lax-but-not-the-end
  9408. return BADVERSION($s,$errstr,"Invalid version format (fractional part required)");
  9409. }
  9410. while (isDIGIT($d)) {
  9411. $d++; $j++;
  9412. if ($d eq '.' && isDIGIT($d-1)) {
  9413. if ($alpha) {
  9414. return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)");
  9415. }
  9416. if ($strict) {
  9417. return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
  9418. }
  9419. $d = $s; # start all over again
  9420. $qv = TRUE;
  9421. goto dotted_decimal_version;
  9422. }
  9423. if ($d eq '_') {
  9424. if ($strict) {
  9425. return BADVERSION($s,$errstr,"Invalid version format (no underscores)");
  9426. }
  9427. if ( $alpha ) {
  9428. return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)");
  9429. }
  9430. if ( ! isDIGIT($d+1) ) {
  9431. return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)");
  9432. }
  9433. $width = $j;
  9434. $d++;
  9435. $alpha = TRUE;
  9436. }
  9437. }
  9438. }
  9439. version_prescan_finish:
  9440. while (isSPACE($d)) {
  9441. $d++;
  9442. }
  9443. if ($d && !isDIGIT($d) && (! ($d eq ';' || $d eq '}') )) {
  9444. # trailing non-numeric data
  9445. return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)");
  9446. }
  9447. if (defined $sqv) {
  9448. $$sqv = $qv;
  9449. }
  9450. if (defined $swidth) {
  9451. $$swidth = $width;
  9452. }
  9453. if (defined $ssaw_decimal) {
  9454. $$ssaw_decimal = $saw_decimal;
  9455. }
  9456. if (defined $salpha) {
  9457. $$salpha = $alpha;
  9458. }
  9459. return $d;
  9460. }
  9461. sub scan_version {
  9462. my ($s, $rv, $qv) = @_;
  9463. my $start;
  9464. my $pos;
  9465. my $last;
  9466. my $errstr;
  9467. my $saw_decimal = 0;
  9468. my $width = 3;
  9469. my $alpha = FALSE;
  9470. my $vinf = FALSE;
  9471. my @av;
  9472. $s = new charstar $s;
  9473. while (isSPACE($s)) { # leading whitespace is OK
  9474. $s++;
  9475. }
  9476. $last = prescan_version($s, FALSE, \$errstr, \$qv, \$saw_decimal,
  9477. \$width, \$alpha);
  9478. if ($errstr) {
  9479. # 'undef' is a special case and not an error
  9480. if ( $s ne 'undef') {
  9481. use Carp;
  9482. Carp::croak($errstr);
  9483. }
  9484. }
  9485. $start = $s;
  9486. if ($s eq 'v') {
  9487. $s++;
  9488. }
  9489. $pos = $s;
  9490. if ( $qv ) {
  9491. $$rv->{qv} = $qv;
  9492. }
  9493. if ( $alpha ) {
  9494. $$rv->{alpha} = $alpha;
  9495. }
  9496. if ( !$qv && $width < 3 ) {
  9497. $$rv->{width} = $width;
  9498. }
  9499. while (isDIGIT($pos)) {
  9500. $pos++;
  9501. }
  9502. if (!isALPHA($pos)) {
  9503. my $rev;
  9504. for (;;) {
  9505. $rev = 0;
  9506. {
  9507. # this is atoi() that delimits on underscores
  9508. my $end = $pos;
  9509. my $mult = 1;
  9510. my $orev;
  9511. # the following if() will only be true after the decimal
  9512. # point of a version originally created with a bare
  9513. # floating point number, i.e. not quoted in any way
  9514. #
  9515. if ( !$qv && $s > $start && $saw_decimal == 1 ) {
  9516. $mult *= 100;
  9517. while ( $s < $end ) {
  9518. $orev = $rev;
  9519. $rev += $s * $mult;
  9520. $mult /= 10;
  9521. if ( (abs($orev) > abs($rev))
  9522. || (abs($rev) > $VERSION_MAX )) {
  9523. warn("Integer overflow in version %d",
  9524. $VERSION_MAX);
  9525. $s = $end - 1;
  9526. $rev = $VERSION_MAX;
  9527. $vinf = 1;
  9528. }
  9529. $s++;
  9530. if ( $s eq '_' ) {
  9531. $s++;
  9532. }
  9533. }
  9534. }
  9535. else {
  9536. while (--$end >= $s) {
  9537. $orev = $rev;
  9538. $rev += $end * $mult;
  9539. $mult *= 10;
  9540. if ( (abs($orev) > abs($rev))
  9541. || (abs($rev) > $VERSION_MAX )) {
  9542. warn("Integer overflow in version");
  9543. $end = $s - 1;
  9544. $rev = $VERSION_MAX;
  9545. $vinf = 1;
  9546. }
  9547. }
  9548. }
  9549. }
  9550. # Append revision
  9551. push @av, $rev;
  9552. if ( $vinf ) {
  9553. $s = $last;
  9554. last;
  9555. }
  9556. elsif ( $pos eq '.' ) {
  9557. $s = ++$pos;
  9558. }
  9559. elsif ( $pos eq '_' && isDIGIT($pos+1) ) {
  9560. $s = ++$pos;
  9561. }
  9562. elsif ( $pos eq ',' && isDIGIT($pos+1) ) {
  9563. $s = ++$pos;
  9564. }
  9565. elsif ( isDIGIT($pos) ) {
  9566. $s = $pos;
  9567. }
  9568. else {
  9569. $s = $pos;
  9570. last;
  9571. }
  9572. if ( $qv ) {
  9573. while ( isDIGIT($pos) ) {
  9574. $pos++;
  9575. }
  9576. }
  9577. else {
  9578. my $digits = 0;
  9579. while ( ( isDIGIT($pos) || $pos eq '_' ) && $digits < 3 ) {
  9580. if ( $pos ne '_' ) {
  9581. $digits++;
  9582. }
  9583. $pos++;
  9584. }
  9585. }
  9586. }
  9587. }
  9588. if ( $qv ) { # quoted versions always get at least three terms
  9589. my $len = $#av;
  9590. # This for loop appears to trigger a compiler bug on OS X, as it
  9591. # loops infinitely. Yes, len is negative. No, it makes no sense.
  9592. # Compiler in question is:
  9593. # gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
  9594. # for ( len = 2 - len; len > 0; len-- )
  9595. # av_push(MUTABLE_AV(sv), newSViv(0));
  9596. #
  9597. $len = 2 - $len;
  9598. while ($len-- > 0) {
  9599. push @av, 0;
  9600. }
  9601. }
  9602. # need to save off the current version string for later
  9603. if ( $vinf ) {
  9604. $$rv->{original} = "v.Inf";
  9605. $$rv->{vinf} = 1;
  9606. }
  9607. elsif ( $s > $start ) {
  9608. $$rv->{original} = $start->currstr($s);
  9609. if ( $qv && $saw_decimal == 1 && $start ne 'v' ) {
  9610. # need to insert a v to be consistent
  9611. $$rv->{original} = 'v' . $$rv->{original};
  9612. }
  9613. }
  9614. else {
  9615. $$rv->{original} = '0';
  9616. push(@av, 0);
  9617. }
  9618. # And finally, store the AV in the hash
  9619. $$rv->{version} = \@av;
  9620. # fix RT#19517 - special case 'undef' as string
  9621. if ($s eq 'undef') {
  9622. $s += 5;
  9623. }
  9624. return $s;
  9625. }
  9626. sub new
  9627. {
  9628. my ($class, $value) = @_;
  9629. my $self = bless ({}, ref ($class) || $class);
  9630. my $qv = FALSE;
  9631. if ( ref($value) && eval('$value->isa("version")') ) {
  9632. # Can copy the elements directly
  9633. $self->{version} = [ @{$value->{version} } ];
  9634. $self->{qv} = 1 if $value->{qv};
  9635. $self->{alpha} = 1 if $value->{alpha};
  9636. $self->{original} = ''.$value->{original};
  9637. return $self;
  9638. }
  9639. my $currlocale = setlocale(LC_ALL);
  9640. # if the current locale uses commas for decimal points, we
  9641. # just replace commas with decimal places, rather than changing
  9642. # locales
  9643. if ( localeconv()->{decimal_point} eq ',' ) {
  9644. $value =~ tr/,/./;
  9645. }
  9646. if ( not defined $value or $value =~ /^undef$/ ) {
  9647. # RT #19517 - special case for undef comparison
  9648. # or someone forgot to pass a value
  9649. push @{$self->{version}}, 0;
  9650. $self->{original} = "0";
  9651. return ($self);
  9652. }
  9653. if ( $#_ == 2 ) { # must be CVS-style
  9654. $value = $_[2];
  9655. $qv = TRUE;
  9656. }
  9657. $value = _un_vstring($value);
  9658. # exponential notation
  9659. if ( $value =~ /\d+.?\d*e[-+]?\d+/ ) {
  9660. $value = sprintf("%.9f",$value);
  9661. $value =~ s/(0+)$//; # trim trailing zeros
  9662. }
  9663. my $s = scan_version($value, \$self, $qv);
  9664. if ($s) { # must be something left over
  9665. warn("Version string '%s' contains invalid data; "
  9666. ."ignoring: '%s'", $value, $s);
  9667. }
  9668. return ($self);
  9669. }
  9670. *parse = \&new;
  9671. sub numify
  9672. {
  9673. my ($self) = @_;
  9674. unless (_verify($self)) {
  9675. require Carp;
  9676. Carp::croak("Invalid version object");
  9677. }
  9678. my $width = $self->{width} || 3;
  9679. my $alpha = $self->{alpha} || "";
  9680. my $len = $#{$self->{version}};
  9681. my $digit = $self->{version}[0];
  9682. my $string = sprintf("%d.", $digit );
  9683. for ( my $i = 1 ; $i < $len ; $i++ ) {
  9684. $digit = $self->{version}[$i];
  9685. if ( $width < 3 ) {
  9686. my $denom = 10**(3-$width);
  9687. my $quot = int($digit/$denom);
  9688. my $rem = $digit - ($quot * $denom);
  9689. $string .= sprintf("%0".$width."d_%d", $quot, $rem);
  9690. }
  9691. else {
  9692. $string .= sprintf("%03d", $digit);
  9693. }
  9694. }
  9695. if ( $len > 0 ) {
  9696. $digit = $self->{version}[$len];
  9697. if ( $alpha && $width == 3 ) {
  9698. $string .= "_";
  9699. }
  9700. $string .= sprintf("%0".$width."d", $digit);
  9701. }
  9702. else # $len = 0
  9703. {
  9704. $string .= sprintf("000");
  9705. }
  9706. return $string;
  9707. }
  9708. sub normal
  9709. {
  9710. my ($self) = @_;
  9711. unless (_verify($self)) {
  9712. require Carp;
  9713. Carp::croak("Invalid version object");
  9714. }
  9715. my $alpha = $self->{alpha} || "";
  9716. my $len = $#{$self->{version}};
  9717. my $digit = $self->{version}[0];
  9718. my $string = sprintf("v%d", $digit );
  9719. for ( my $i = 1 ; $i < $len ; $i++ ) {
  9720. $digit = $self->{version}[$i];
  9721. $string .= sprintf(".%d", $digit);
  9722. }
  9723. if ( $len > 0 ) {
  9724. $digit = $self->{version}[$len];
  9725. if ( $alpha ) {
  9726. $string .= sprintf("_%0d", $digit);
  9727. }
  9728. else {
  9729. $string .= sprintf(".%0d", $digit);
  9730. }
  9731. }
  9732. if ( $len <= 2 ) {
  9733. for ( $len = 2 - $len; $len != 0; $len-- ) {
  9734. $string .= sprintf(".%0d", 0);
  9735. }
  9736. }
  9737. return $string;
  9738. }
  9739. sub stringify
  9740. {
  9741. my ($self) = @_;
  9742. unless (_verify($self)) {
  9743. require Carp;
  9744. Carp::croak("Invalid version object");
  9745. }
  9746. return exists $self->{original}
  9747. ? $self->{original}
  9748. : exists $self->{qv}
  9749. ? $self->normal
  9750. : $self->numify;
  9751. }
  9752. sub vcmp
  9753. {
  9754. require UNIVERSAL;
  9755. my ($left,$right,$swap) = @_;
  9756. my $class = ref($left);
  9757. unless ( UNIVERSAL::isa($right, $class) ) {
  9758. $right = $class->new($right);
  9759. }
  9760. if ( $swap ) {
  9761. ($left, $right) = ($right, $left);
  9762. }
  9763. unless (_verify($left)) {
  9764. require Carp;
  9765. Carp::croak("Invalid version object");
  9766. }
  9767. unless (_verify($right)) {
  9768. require Carp;
  9769. Carp::croak("Invalid version format");
  9770. }
  9771. my $l = $#{$left->{version}};
  9772. my $r = $#{$right->{version}};
  9773. my $m = $l < $r ? $l : $r;
  9774. my $lalpha = $left->is_alpha;
  9775. my $ralpha = $right->is_alpha;
  9776. my $retval = 0;
  9777. my $i = 0;
  9778. while ( $i <= $m && $retval == 0 ) {
  9779. $retval = $left->{version}[$i] <=> $right->{version}[$i];
  9780. $i++;
  9781. }
  9782. # tiebreaker for alpha with identical terms
  9783. if ( $retval == 0
  9784. && $l == $r
  9785. && $left->{version}[$m] == $right->{version}[$m]
  9786. && ( $lalpha || $ralpha ) ) {
  9787. if ( $lalpha && !$ralpha ) {
  9788. $retval = -1;
  9789. }
  9790. elsif ( $ralpha && !$lalpha) {
  9791. $retval = +1;
  9792. }
  9793. }
  9794. # possible match except for trailing 0's
  9795. if ( $retval == 0 && $l != $r ) {
  9796. if ( $l < $r ) {
  9797. while ( $i <= $r && $retval == 0 ) {
  9798. if ( $right->{version}[$i] != 0 ) {
  9799. $retval = -1; # not a match after all
  9800. }
  9801. $i++;
  9802. }
  9803. }
  9804. else {
  9805. while ( $i <= $l && $retval == 0 ) {
  9806. if ( $left->{version}[$i] != 0 ) {
  9807. $retval = +1; # not a match after all
  9808. }
  9809. $i++;
  9810. }
  9811. }
  9812. }
  9813. return $retval;
  9814. }
  9815. sub vbool {
  9816. my ($self) = @_;
  9817. return vcmp($self,$self->new("0"),1);
  9818. }
  9819. sub vnoop {
  9820. require Carp;
  9821. Carp::croak("operation not supported with version object");
  9822. }
  9823. sub is_alpha {
  9824. my ($self) = @_;
  9825. return (exists $self->{alpha});
  9826. }
  9827. sub qv {
  9828. my $value = shift;
  9829. my $class = 'version';
  9830. if (@_) {
  9831. $class = ref($value) || $value;
  9832. $value = shift;
  9833. }
  9834. $value = _un_vstring($value);
  9835. $value = 'v'.$value unless $value =~ /(^v|\d+\.\d+\.\d)/;
  9836. my $obj = version->new($value);
  9837. return bless $obj, $class;
  9838. }
  9839. *declare = \&qv;
  9840. sub is_qv {
  9841. my ($self) = @_;
  9842. return (exists $self->{qv});
  9843. }
  9844. sub _verify {
  9845. my ($self) = @_;
  9846. if ( ref($self)
  9847. && eval { exists $self->{version} }
  9848. && ref($self->{version}) eq 'ARRAY'
  9849. ) {
  9850. return 1;
  9851. }
  9852. else {
  9853. return 0;
  9854. }
  9855. }
  9856. sub _is_non_alphanumeric {
  9857. my $s = shift;
  9858. $s = new charstar $s;
  9859. while ($s) {
  9860. return 0 if isSPACE($s); # early out
  9861. return 1 unless (isALPHA($s) || isDIGIT($s) || $s =~ /[.-]/);
  9862. $s++;
  9863. }
  9864. return 0;
  9865. }
  9866. sub _un_vstring {
  9867. my $value = shift;
  9868. # may be a v-string
  9869. if ( length($value) >= 3 && $value !~ /[._]/
  9870. && _is_non_alphanumeric($value)) {
  9871. my $tvalue;
  9872. if ( $] ge 5.008_001 ) {
  9873. $tvalue = _find_magic_vstring($value);
  9874. $value = $tvalue if length $tvalue;
  9875. }
  9876. elsif ( $] ge 5.006_000 ) {
  9877. $tvalue = sprintf("v%vd",$value);
  9878. if ( $tvalue =~ /^v\d+(\.\d+){2,}$/ ) {
  9879. # must be a v-string
  9880. $value = $tvalue;
  9881. }
  9882. }
  9883. }
  9884. return $value;
  9885. }
  9886. sub _find_magic_vstring {
  9887. my $value = shift;
  9888. my $tvalue = '';
  9889. require B;
  9890. my $sv = B::svref_2object(\$value);
  9891. my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef;
  9892. while ( $magic ) {
  9893. if ( $magic->TYPE eq 'V' ) {
  9894. $tvalue = $magic->PTR;
  9895. $tvalue =~ s/^v?(.+)$/v$1/;
  9896. last;
  9897. }
  9898. else {
  9899. $magic = $magic->MOREMAGIC;
  9900. }
  9901. }
  9902. return $tvalue;
  9903. }
  9904. sub _VERSION {
  9905. my ($obj, $req) = @_;
  9906. my $class = ref($obj) || $obj;
  9907. no strict 'refs';
  9908. if ( exists $INC{"$class.pm"} and not %{"$class\::"} and $] >= 5.008) {
  9909. # file but no package
  9910. require Carp;
  9911. Carp::croak( "$class defines neither package nor VERSION"
  9912. ."--version check failed");
  9913. }
  9914. my $version = eval "\$$class\::VERSION";
  9915. if ( defined $version ) {
  9916. local $^W if $] <= 5.008;
  9917. $version = version::vpp->new($version);
  9918. }
  9919. if ( defined $req ) {
  9920. unless ( defined $version ) {
  9921. require Carp;
  9922. my $msg = $] < 5.006
  9923. ? "$class version $req required--this is only version "
  9924. : "$class does not define \$$class\::VERSION"
  9925. ."--version check failed";
  9926. if ( $ENV{VERSION_DEBUG} ) {
  9927. Carp::confess($msg);
  9928. }
  9929. else {
  9930. Carp::croak($msg);
  9931. }
  9932. }
  9933. $req = version::vpp->new($req);
  9934. if ( $req > $version ) {
  9935. require Carp;
  9936. if ( $req->is_qv ) {
  9937. Carp::croak(
  9938. sprintf ("%s version %s required--".
  9939. "this is only version %s", $class,
  9940. $req->normal, $version->normal)
  9941. );
  9942. }
  9943. else {
  9944. Carp::croak(
  9945. sprintf ("%s version %s required--".
  9946. "this is only version %s", $class,
  9947. $req->stringify, $version->stringify)
  9948. );
  9949. }
  9950. }
  9951. }
  9952. return defined $version ? $version->stringify : undef;
  9953. }
  9954. 1; #this line is important and will help the module return a true value
  9955. VERSION_VPP
  9956.  
  9957. s/^ //mg for values %fatpacked;
  9958.  
  9959. unshift @INC, sub {
  9960. if (my $fat = $fatpacked{$_[1]}) {
  9961. if ($] < 5.008) {
  9962. return sub {
  9963. return 0 unless length $fat;
  9964. $fat =~ s/^([^\n]*\n?)//;
  9965. $_ = $1;
  9966. return 1;
  9967. };
  9968. }
  9969. open my $fh, '<', \$fat
  9970. or die "FatPacker error loading $_[1] (could be a perl installation issue?)";
  9971. return $fh;
  9972. }
  9973. return
  9974. };
  9975.  
  9976. } # END OF FATPACK CODE
  9977.  
  9978. use strict;
  9979. use App::cpanminus::script;
  9980.  
  9981. unless (caller) {
  9982. my $app = App::cpanminus::script->new;
  9983. $app->parse_options(@ARGV);
  9984. $app->doit or exit(1);
  9985. }
  9986.  
  9987. __END__
  9988.  
  9989. =head1 NAME
  9990.  
  9991. cpanm - get, unpack build and install modules from CPAN
  9992.  
  9993. =head1 SYNOPSIS
  9994.  
  9995. cpanm Test::More # install Test::More
  9996. cpanm MIYAGAWA/Plack-0.99_05.tar.gz # full distribution path
  9997. cpanm http://example.org/LDS/CGI.pm-3.20.tar.gz # install from URL
  9998. cpanm ~/dists/MyCompany-Enterprise-1.00.tar.gz # install from a local file
  9999. cpanm --interactive Task::Kensho # Configure interactively
  10000. cpanm . # install from local directory
  10001. cpanm --installdeps . # install all the deps for the current directory
  10002. cpanm -L extlib Plack # install Plack and all non-core deps into extlib
  10003. cpanm --mirror http://cpan.cpantesters.org/ DBI # use the fast-syncing mirror
  10004. cpanm --scandeps Moose # See what modules will be installed for Moose
  10005.  
  10006. =head1 COMMANDS
  10007.  
  10008. =over 4
  10009.  
  10010. =item (arguments)
  10011.  
  10012. Command line arguments can be either a module name, distribution file,
  10013. local file path, HTTP URL or git repository URL. Following commands
  10014. will all work as you expect.
  10015.  
  10016. cpanm Plack
  10017. cpanm Plack/Request.pm
  10018. cpanm MIYAGAWA/Plack-1.0000.tar.gz
  10019. cpanm /path/to/Plack-1.0000.tar.gz
  10020. cpanm http://cpan.metacpan.org/authors/id/M/MI/MIYAGAWA/Plack-0.9990.tar.gz
  10021. cpanm git://github.com/miyagawa/Plack.git
  10022.  
  10023. Additionally, you can use the notation using C<~> and C<@> to specify
  10024. version for a given module. C<~> specifies the version requirement in
  10025. the L<CPAN::Meta::Spec> format, while C<@> pins the exact version, and
  10026. is a shortcut for C<~"== VERSION">.
  10027.  
  10028. cpanm Plack~1.0000 # 1.0000 or later
  10029. cpanm Plack~">= 1.0000, < 2.0000" # latest of 1.xxxx
  10030. cpanm Plack@0.9990 # specific version. same as Plack~"== 0.9990"
  10031.  
  10032. The version query including specific version or range will be sent to
  10033. L<MetaCPAN> to search for previous releases. The query will search for
  10034. BackPAN archives by default, unless you specify C<--dev> option, in
  10035. which case, archived versions will be filtered out.
  10036.  
  10037. For a git repository, you can specify a branch, tag, or commit SHA to
  10038. build. The default is C<master>
  10039.  
  10040. cpanm git://github.com/miyagawa/Plack.git@1.0000 # tag
  10041. cpanm git://github.com/miyagawa/Plack.git@devel # branch
  10042.  
  10043. =item -i, --install
  10044.  
  10045. Installs the modules. This is a default behavior and this is just a
  10046. compatibility option to make it work like L<cpan> or L<cpanp>.
  10047.  
  10048. =item --self-upgrade
  10049.  
  10050. Upgrades itself. It's just an alias for:
  10051.  
  10052. cpanm App::cpanminus
  10053.  
  10054. =item --info
  10055.  
  10056. Displays the distribution information in
  10057. C<AUTHOR/Dist-Name-ver.tar.gz> format in the standard out.
  10058.  
  10059. =item --installdeps
  10060.  
  10061. Installs the dependencies of the target distribution but won't build
  10062. itself. Handy if you want to try the application from a version
  10063. controlled repository such as git.
  10064.  
  10065. cpanm --installdeps .
  10066.  
  10067. =item --look
  10068.  
  10069. Download and unpack the distribution and then open the directory with
  10070. your shell. Handy to poke around the source code or do manual
  10071. testing.
  10072.  
  10073. =item -h, --help
  10074.  
  10075. Displays the help message.
  10076.  
  10077. =item -V, --version
  10078.  
  10079. Displays the version number.
  10080.  
  10081. =back
  10082.  
  10083. =head1 OPTIONS
  10084.  
  10085. You can specify the default options in C<PERL_CPANM_OPT> environment variable.
  10086.  
  10087. =over 4
  10088.  
  10089. =item -f, --force
  10090.  
  10091. Force install modules even when testing failed.
  10092.  
  10093. =item -n, --notest
  10094.  
  10095. Skip the testing of modules. Use this only when you just want to save
  10096. time for installing hundreds of distributions to the same perl and
  10097. architecture you've already tested to make sure it builds fine.
  10098.  
  10099. Defaults to false, and you can say C<--no-notest> to override when it
  10100. is set in the default options in C<PERL_CPANM_OPT>.
  10101.  
  10102. =item --test-only
  10103.  
  10104. Run the tests only, and do not install the specified module or
  10105. distributions. Handy if you want to verify the new (or even old)
  10106. releases pass its unit tests without installing the module.
  10107.  
  10108. Note that if you specify this option with a module or distribution
  10109. that has dependencies, these dependencies will be installed if you
  10110. don't currently have them.
  10111.  
  10112. =item -S, --sudo
  10113.  
  10114. Switch to the root user with C<sudo> when installing modules. Use this
  10115. if you want to install modules to the system perl include path.
  10116.  
  10117. Defaults to false, and you can say C<--no-sudo> to override when it is
  10118. set in the default options in C<PERL_CPANM_OPT>.
  10119.  
  10120. =item -v, --verbose
  10121.  
  10122. Makes the output verbose. It also enables the interactive
  10123. configuration. (See --interactive)
  10124.  
  10125. =item -q, --quiet
  10126.  
  10127. Makes the output even more quiet than the default. It doesn't print
  10128. anything to the STDERR.
  10129.  
  10130. =item -l, --local-lib
  10131.  
  10132. Sets the L<local::lib> compatible path to install modules to. You
  10133. don't need to set this if you already configure the shell environment
  10134. variables using L<local::lib>, but this can be used to override that
  10135. as well.
  10136.  
  10137. =item -L, --local-lib-contained
  10138.  
  10139. Same with C<--local-lib> but when examining the dependencies, it
  10140. assumes no non-core modules are installed on the system. It's handy if
  10141. you want to bundle application dependencies in one directory so you
  10142. can distribute to other machines.
  10143.  
  10144. For instance,
  10145.  
  10146. cpanm -L extlib Plack
  10147.  
  10148. would install Plack and all of its non-core dependencies into the
  10149. directory C<extlib>, which can be loaded from your application with:
  10150.  
  10151. use local::lib '/path/to/extlib';
  10152.  
  10153. =item --mirror
  10154.  
  10155. Specifies the base URL for the CPAN mirror to use, such as
  10156. C<http://cpan.cpantesters.org/> (you can omit the trailing slash). You
  10157. can specify multiple mirror URLs by repeating the command line option.
  10158.  
  10159. You can use a local directory that has a CPAN mirror structure
  10160. (created by tools such as L<OrePAN> or L<Pinto>) by using a special
  10161. URL scheme C<file://>. If the given URL begins with `/` (without any
  10162. scheme), it is considered as a file scheme as well.
  10163.  
  10164. cpanm --mirror file:///path/to/mirror
  10165. cpanm --mirror ~/minicpan # Because shell expands ~ to /home/user
  10166.  
  10167. Defaults to C<http://search.cpan.org/CPAN> which is a geo location
  10168. aware redirector.
  10169.  
  10170. =item --mirror-only
  10171.  
  10172. Download the mirror's 02packages.details.txt.gz index file instead of
  10173. querying the CPAN Meta DB.
  10174.  
  10175. Select this option if you are using a local mirror of CPAN, such as
  10176. minicpan when you're offline, or your own CPAN index (a.k.a darkpan).
  10177.  
  10178. B<Tip:> It might be useful if you name these mirror options with your
  10179. shell aliases, like:
  10180.  
  10181. alias minicpanm='cpanm --mirror ~/minicpan --mirror-only'
  10182. alias darkpan='cpanm --mirror http://mycompany.example.com/DPAN --mirror-only'
  10183.  
  10184. =item --mirror-index
  10185.  
  10186. B<EXPERIMENTAL>: Specifies the file path to C<02packages.details.txt>
  10187. for module search index.
  10188.  
  10189. =item --prompt
  10190.  
  10191. Prompts when a test fails so that you can skip, force install, retry
  10192. or look in the shell to see what's going wrong. It also prompts when
  10193. one of the dependency failed if you want to proceed the installation.
  10194.  
  10195. Defaults to false, and you can say C<--no-prompt> to override if it's
  10196. set in the default options in C<PERL_CPANM_OPT>.
  10197.  
  10198. =item --dev
  10199.  
  10200. B<EXPERIMENTAL>: search for a newer developer release as well. Defaults to false.
  10201.  
  10202. =item --reinstall
  10203.  
  10204. cpanm, when given a module name in the command line (i.e. C<cpanm
  10205. Plack>), checks the locally installed version first and skips if it is
  10206. already installed. This option makes it skip the check, so:
  10207.  
  10208. cpanm --reinstall Plack
  10209.  
  10210. would reinstall L<Plack> even if your locally installed version is
  10211. latest, or even newer (which would happen if you install a developer
  10212. release from version control repositories).
  10213.  
  10214. Defaults to false.
  10215.  
  10216. =item --interactive
  10217.  
  10218. Makes the configuration (such as C<Makefile.PL> and C<Build.PL>)
  10219. interactive, so you can answer questions in the distribution that
  10220. requires custom configuration or Task:: distributions.
  10221.  
  10222. Defaults to false, and you can say C<--no-interactive> to override
  10223. when it's set in the default options in C<PERL_CPANM_OPT>.
  10224.  
  10225. =item --scandeps
  10226.  
  10227. Scans the depencencies of given modules and output the tree in a text
  10228. format. (See C<--format> below for more options)
  10229.  
  10230. Because this command doesn't actually install any distributions, it
  10231. will be useful that by typing:
  10232.  
  10233. cpanm --scandeps Catalyst::Runtime
  10234.  
  10235. you can make sure what modules will be installed.
  10236.  
  10237. This command takes into account which modules you already have
  10238. installed in your system. If you want to see what modules will be
  10239. installed against a vanilla perl installation, you might want to
  10240. combine it with C<-L> option.
  10241.  
  10242. =item --format
  10243.  
  10244. Determines what format to display the scanned dependency
  10245. tree. Available options are C<tree>, C<json>, C<yaml> and C<dists>.
  10246.  
  10247. =over 8
  10248.  
  10249. =item tree
  10250.  
  10251. Displays the tree in a plain text format. This is the default value.
  10252.  
  10253. =item json, yaml
  10254.  
  10255. Outputs the tree in a JSON or YAML format. L<JSON> and L<YAML> modules
  10256. need to be installed respectively. The output tree is represented as a
  10257. recursive tuple of:
  10258.  
  10259. [ distribution, dependencies ]
  10260.  
  10261. and the container is an array containing the root elements. Note that
  10262. there may be multiple root nodes, since you can give multiple modules
  10263. to the C<--scandeps> command.
  10264.  
  10265. =item dists
  10266.  
  10267. C<dists> is a special output format, where it prints the distribution
  10268. filename in the I<depth first order> after the dependency resolution,
  10269. like:
  10270.  
  10271. GAAS/MIME-Base64-3.13.tar.gz
  10272. GAAS/URI-1.58.tar.gz
  10273. PETDANCE/HTML-Tagset-3.20.tar.gz
  10274. GAAS/HTML-Parser-3.68.tar.gz
  10275. GAAS/libwww-perl-5.837.tar.gz
  10276.  
  10277. which means you can install these distributions in this order without
  10278. extra dependencies. When combined with C<-L> option, it will be useful
  10279. to replay installations on other machines.
  10280.  
  10281. =back
  10282.  
  10283. =item --save-dists
  10284.  
  10285. Specifies the optional directory path to copy downloaded tarballs in
  10286. the CPAN mirror compatible directory structure
  10287. i.e. I<authors/id/A/AU/AUTHORS/Foo-Bar-version.tar.gz>
  10288.  
  10289. =item --uninst-shadows
  10290.  
  10291. Uninstalls the shadow files of the distribution that you're
  10292. installing. This eliminates the confusion if you're trying to install
  10293. core (dual-life) modules from CPAN against perl 5.10 or older, or
  10294. modules that used to be XS-based but switched to pure perl at some
  10295. version.
  10296.  
  10297. If you run cpanm as root and use C<INSTALL_BASE> or equivalent to
  10298. specify custom installation path, you SHOULD disable this option so
  10299. you won't accidentally uninstall dual-life modules from the core
  10300. include path.
  10301.  
  10302. Defaults to true if your perl version is smaller than 5.12, and you
  10303. can disable that with C<--no-uninst-shadows>.
  10304.  
  10305. B<NOTE>: Since version 1.3000 this flag is turned off by default for
  10306. perl newer than 5.12, since with 5.12 @INC contains site_perl directory
  10307. I<before> the perl core library path, and uninstalling shadows is not
  10308. necessary anymore and does more harm by deleting files from the core
  10309. library path.
  10310.  
  10311. =item --cascade-search
  10312.  
  10313. B<EXPERIMENTAL>: Specifies whether to cascade search when you specify
  10314. multiple mirrors and a mirror doesn't have a module or has a lower
  10315. version of the module than requested. Defaults to false.
  10316.  
  10317. =item --skip-installed
  10318.  
  10319. Specifies whether a module given in the command line is skipped if its latest
  10320. version is already installed. Defaults to true.
  10321.  
  10322. B<NOTE>: The C<PERL5LIB> environment variable have to be correctly set for this
  10323. to work with modules installed using L<local::lib>.
  10324.  
  10325. =item --skip-satisfied
  10326.  
  10327. B<EXPERIMENTAL>: Specifies whether a module (and version) given in the
  10328. command line is skipped if it's already installed.
  10329.  
  10330. If you run:
  10331.  
  10332. cpanm --skip-satisfied CGI DBI~1.2
  10333.  
  10334. cpanm won't install them if you already have CGI (for whatever
  10335. versions) or have DBI with version higher than 1.2. It is similar to
  10336. C<--skip-installed> but while C<--skip-installed> checks if the
  10337. I<latest> version of CPAN is installed, C<--skip-satisfied> checks if
  10338. a requested version (or not, which means any version) is installed.
  10339.  
  10340. Defaults to false.
  10341.  
  10342. =item --verify
  10343.  
  10344. Verify the integrity of distribution files retrieved from PAUSE using
  10345. CHECKSUMS and SIGNATURES (if found). Defaults to false.
  10346.  
  10347. =item --auto-cleanup
  10348.  
  10349. Specifies the number of days in which cpanm's work directories
  10350. expire. Defaults to 7, which means old work directories will be
  10351. cleaned up in one week.
  10352.  
  10353. You can set the value to C<0> to make cpan never cleanup those
  10354. directories.
  10355.  
  10356. =item --man-pages
  10357.  
  10358. Generates man pages for executables (man1) and libraries (man3).
  10359.  
  10360. Defaults to false (no man pages generated) if
  10361. C<-L|--local-lib-contained> option is supplied. Otherwise, defaults to
  10362. true, and you can disable it with C<--no-man-pages>.
  10363.  
  10364. =item --lwp
  10365.  
  10366. Uses L<LWP> module to download stuff over HTTP. Defaults to true, and
  10367. you can say C<--no-lwp> to disable using LWP, when you want to upgrade
  10368. LWP from CPAN on some broken perl systems.
  10369.  
  10370. =item --wget
  10371.  
  10372. Uses GNU Wget (if available) to download stuff. Defaults to true, and
  10373. you can say C<--no-wget> to disable using Wget (versions of Wget older
  10374. than 1.9 don't support the C<--retry-connrefused> option used by cpanm).
  10375.  
  10376. =item --curl
  10377.  
  10378. Uses cURL (if available) to download stuff. Defaults to true, and
  10379. you can say C<--no-curl> to disable using cURL.
  10380.  
  10381. Normally with C<--lwp>, C<--wget> and C<--curl> options set to true
  10382. (which is the default) cpanm tries L<LWP>, Wget, cURL and L<HTTP::Tiny>
  10383. (in that order) and uses the first one available.
  10384.  
  10385. =back
  10386.  
  10387. =head1 SEE ALSO
  10388.  
  10389. L<App::cpanminus>
  10390.  
  10391. =head1 COPYRIGHT
  10392.  
  10393. Copyright 2010 Tatsuhiko Miyagawa.
  10394.  
  10395. =head1 AUTHOR
  10396.  
  10397. Tatsuhiko Miyagawa
  10398.  
  10399. =cut