From c507dbefe9048aca52386027976607a549391513 Mon Sep 17 00:00:00 2001 From: Matthew Somerville Date: Thu, 3 Sep 2015 18:03:58 +0100 Subject: Bundle carton. This was generated using 'carton fatpack' as follows: bin/cpanm -L local-carton --with-recommends Carton export PERL5LIB=/lib/perl5/ local-carton/bin/carton fatpack (It needs to be an absolute path in order to locate the meta files.) This was done on a Debian squeeze box to make sure any too-old core modules were updated and included in the bundle. --- vendor/bin/carton | 80534 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 80534 insertions(+) create mode 100755 vendor/bin/carton (limited to 'vendor') diff --git a/vendor/bin/carton b/vendor/bin/carton new file mode 100755 index 000000000..b311208a4 --- /dev/null +++ b/vendor/bin/carton @@ -0,0 +1,80534 @@ +#!/usr/bin/env perl + +# This chunk of stuff was generated by App::FatPacker. To find the original +# file's code, look for the end of this BEGIN block or the string 'FATPACK' +BEGIN { +my %fatpacked; + +$fatpacked{"App/cpanminus.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_CPANMINUS'; + package App::cpanminus; + our $VERSION = "1.7039"; + + =encoding utf8 + + =head1 NAME + + App::cpanminus - get, unpack, build and install modules from CPAN + + =head1 SYNOPSIS + + cpanm Module + + Run C or C for more options. + + =head1 DESCRIPTION + + cpanminus is a script to get, unpack, build and install modules from + CPAN and does nothing else. + + It's dependency free (can bootstrap itself), requires zero + configuration, and stands alone. When running, it requires only 10MB + of RAM. + + =head1 INSTALLATION + + There are several ways to install cpanminus to your system. + + =head2 Package management system + + There are Debian packages, RPMs, FreeBSD ports, and packages for other + operation systems available. If you want to use the package management system, + search for cpanminus and use the appropriate command to install. This makes it + easy to install C to your system without thinking about where to + install, and later upgrade. + + =head2 Installing to system perl + + You can also use the latest cpanminus to install cpanminus itself: + + curl -L https://cpanmin.us | perl - --sudo App::cpanminus + + This will install C to your bin directory like + C and you'll need the C<--sudo> option to write to + the directory, unless you configured C with L. + + =head2 Installing to local perl (perlbrew, plenv etc.) + + If you have perl in your home directory, which is the case if you use + tools like L or plenv, you don't need the C<--sudo> option, since + you're most likely to have a write permission to the perl's library + path. You can just do: + + curl -L https://cpanmin.us | perl - App::cpanminus + + to install the C executable to the perl's bin path, like + C<~/perl5/perlbrew/bin/cpanm>. + + =head2 Downloading the standalone executable + + You can also copy the standalone executable to whatever location you'd like. + + cd ~/bin + curl -L https://cpanmin.us/ -o cpanm + chmod +x cpanm + + This just works, but be sure to grab the new version manually when you + upgrade because C<--self-upgrade> might not work with this installation setup. + + =head2 Troubleshoot: HTTPS warnings + + When you run C commands above, you may encounter SSL handshake + errors or certification warnings. This is due to your HTTP client + (curl) being old, or SSL certificates installed on your system needs + to be updated. + + You're recommended to update the software or system if you can. If + that is impossible or difficult, use the C<-k> option with curl or an + alternative URL, C + + =head1 DEPENDENCIES + + perl 5.8.1 or later. + + =over 4 + + =item * + + 'tar' executable (bsdtar or GNU tar version 1.22 are recommended) or Archive::Tar to unpack files. + + =item * + + C compiler, if you want to build XS modules. + + =item * + + make + + =item * + + Module::Build (core in 5.10) + + =back + + =head1 QUESTIONS + + =head2 How does cpanm get/parse/update the CPAN index? + + It queries the CPAN Meta DB site at L. + The site is updated at least every hour to reflect the latest changes + from fast syncing mirrors. The script then also falls back to query the + module at L using its seach API. + + Upon calling these API hosts, cpanm (1.6004 or later) will send the + local perl versions to the server in User-Agent string by default. You + can turn it off with C<--no-report-perl-version> option. Read more + about the option with L, and read more about the privacy policy + about this data collection at L + + Fetched files are unpacked in C<~/.cpanm> and automatically cleaned up + periodically. You can configure the location of this with the + C environment variable. + + =head2 Where does this install modules to? Do I need root access? + + It installs to wherever ExtUtils::MakeMaker and Module::Build are + configured to (via C and C). + + By default, it installs to the site_perl directory that belongs to + your perl. You can see the locations for that by running C + and it will be likely something under C if you're + using system perl, or under your home directory if you have built perl + yourself using perlbrew or plenv. + + If you've already configured local::lib on your shell, cpanm respects + that settings and modules will be installed to your local perl5 + directory. + + At a boot time, cpanminus checks whether you have already configured + local::lib, or have a permission to install modules to the site_perl + directory. If neither, i.e. you're using system perl and do not run + cpanm as a root, it automatically sets up local::lib compatible + installation path in a C directory under your home + directory. + + To avoid this, run C either as a root user, with C<--sudo> + option, or with C<--local-lib> option. + + =head2 cpanminus can't install the module XYZ. Is it a bug? + + It is more likely a problem with the distribution itself. cpanminus + doesn't support or may have issues with distributions such as follows: + + =over 4 + + =item * + + Tests that require input from STDIN. + + =item * + + Build.PL or Makefile.PL that prompts for input even when + C is enabled. + + =item * + + Modules that have invalid numeric values as VERSION (such as C<1.1a>) + + =back + + These failures can be reported back to the author of the module so + that they can fix it accordingly, rather than to cpanminus. + + =head2 Does cpanm support the feature XYZ of L and L? + + Most likely not. Here are the things that cpanm doesn't do by + itself. + + If you need these features, use L, L or the standalone + tools that are mentioned. + + =over 4 + + =item * + + CPAN testers reporting. See L + + =item * + + Building RPM packages from CPAN modules + + =item * + + Listing the outdated modules that needs upgrading. See L + + =item * + + Showing the changes of the modules you're about to upgrade. See L + + =item * + + Patching CPAN modules with distroprefs. + + =back + + See L or C to see what cpanminus I do :) + + =head1 COPYRIGHT + + Copyright 2010- Tatsuhiko Miyagawa + + The standalone executable contains the following modules embedded. + + =over 4 + + =item L Copyright 2003 Graham Barr + + =item L Copyright 2007-2009 Matt S Trout + + =item L Copyright 2011 Christian Hansen + + =item L Copyright 2001-2006 Ken Williams. 2010 Matt S Trout + + =item L Copyright 2004-2010 John Peacock + + =item L Copyright 2007-2011 by Makamaka Hannyaharamitu + + =item L, L Copyright (c) 2010 by David Golden and Ricardo Signes + + =item L Copyright 2010 Adam Kennedy + + =item L Copyright 2012 David Golden + + =back + + =head1 LICENSE + + This software is licensed under the same terms as Perl. + + =head1 CREDITS + + =head2 CONTRIBUTORS + + Patches and code improvements were contributed by: + + Goro Fuji, Kazuhiro Osawa, Tokuhiro Matsuno, Kenichi Ishigaki, Ian + Wells, Pedro Melo, Masayoshi Sekimura, Matt S Trout (mst), squeeky, + horus and Ingy dot Net. + + =head2 ACKNOWLEDGEMENTS + + Bug reports, suggestions and feedbacks were sent by, or general + acknowledgement goes to: + + Jesse Vincent, David Golden, Andreas Koenig, Jos Boumans, Chris + Williams, Adam Kennedy, Audrey Tang, J. Shirley, Chris Prather, Jesse + Luehrs, Marcus Ramberg, Shawn M Moore, chocolateboy, Chirs Nehren, + Jonathan Rockway, Leon Brocard, Simon Elliott, Ricardo Signes, AEvar + Arnfjord Bjarmason, Eric Wilhelm, Florian Ragwitz and xaicron. + + =head1 COMMUNITY + + =over 4 + + =item L - source code repository, issue tracker + + =item L - discussions about Perl toolchain. I'm there. + + =back + + =head1 NO WARRANTY + + This software is provided "as-is," without any express or implied + warranty. In no event shall the author be held liable for any damages + arising from the use of the software. + + =head1 SEE ALSO + + L L L + + =cut + + 1; +APP_CPANMINUS + +$fatpacked{"App/cpanminus/fatscript.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_CPANMINUS_FATSCRIPT'; + package App::cpanminus::fatscript; + # + # This is a pre-compiled source code for the cpanm (cpanminus) program. + # For more details about how to install cpanm, go to the following URL: + # + # https://github.com/miyagawa/cpanminus + # + # Quickstart: Run the following command and it will install itself for + # you. You might want to run it as a root with sudo if you want to install + # to places like /usr/local/bin. + # + # % curl -L https://cpanmin.us | perl - App::cpanminus + # + # If you don't have curl but wget, replace `curl -L` with `wget -O -`. + + # DO NOT EDIT -- this is an auto generated file + + # This chunk of stuff was generated by App::FatPacker. To find the original + # file's code, look for the end of this BEGIN block or the string 'FATPACK' + BEGIN { + my %fatpacked; + + $fatpacked{"App/cpanminus.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_CPANMINUS'; + package App::cpanminus; + our $VERSION = "1.7039"; + + =encoding utf8 + + =head1 NAME + + App::cpanminus - get, unpack, build and install modules from CPAN + + =head1 SYNOPSIS + + cpanm Module + + Run C or C for more options. + + =head1 DESCRIPTION + + cpanminus is a script to get, unpack, build and install modules from + CPAN and does nothing else. + + It's dependency free (can bootstrap itself), requires zero + configuration, and stands alone. When running, it requires only 10MB + of RAM. + + =head1 INSTALLATION + + There are several ways to install cpanminus to your system. + + =head2 Package management system + + There are Debian packages, RPMs, FreeBSD ports, and packages for other + operation systems available. If you want to use the package management system, + search for cpanminus and use the appropriate command to install. This makes it + easy to install C to your system without thinking about where to + install, and later upgrade. + + =head2 Installing to system perl + + You can also use the latest cpanminus to install cpanminus itself: + + curl -L https://cpanmin.us | perl - --sudo App::cpanminus + + This will install C to your bin directory like + C and you'll need the C<--sudo> option to write to + the directory, unless you configured C with L. + + =head2 Installing to local perl (perlbrew, plenv etc.) + + If you have perl in your home directory, which is the case if you use + tools like L or plenv, you don't need the C<--sudo> option, since + you're most likely to have a write permission to the perl's library + path. You can just do: + + curl -L https://cpanmin.us | perl - App::cpanminus + + to install the C executable to the perl's bin path, like + C<~/perl5/perlbrew/bin/cpanm>. + + =head2 Downloading the standalone executable + + You can also copy the standalone executable to whatever location you'd like. + + cd ~/bin + curl -L https://cpanmin.us/ -o cpanm + chmod +x cpanm + + This just works, but be sure to grab the new version manually when you + upgrade because C<--self-upgrade> might not work with this installation setup. + + =head2 Troubleshoot: HTTPS warnings + + When you run C commands above, you may encounter SSL handshake + errors or certification warnings. This is due to your HTTP client + (curl) being old, or SSL certificates installed on your system needs + to be updated. + + You're recommended to update the software or system if you can. If + that is impossible or difficult, use the C<-k> option with curl or an + alternative URL, C + + =head1 DEPENDENCIES + + perl 5.8.1 or later. + + =over 4 + + =item * + + 'tar' executable (bsdtar or GNU tar version 1.22 are recommended) or Archive::Tar to unpack files. + + =item * + + C compiler, if you want to build XS modules. + + =item * + + make + + =item * + + Module::Build (core in 5.10) + + =back + + =head1 QUESTIONS + + =head2 How does cpanm get/parse/update the CPAN index? + + It queries the CPAN Meta DB site at L. + The site is updated at least every hour to reflect the latest changes + from fast syncing mirrors. The script then also falls back to query the + module at L using its seach API. + + Upon calling these API hosts, cpanm (1.6004 or later) will send the + local perl versions to the server in User-Agent string by default. You + can turn it off with C<--no-report-perl-version> option. Read more + about the option with L, and read more about the privacy policy + about this data collection at L + + Fetched files are unpacked in C<~/.cpanm> and automatically cleaned up + periodically. You can configure the location of this with the + C environment variable. + + =head2 Where does this install modules to? Do I need root access? + + It installs to wherever ExtUtils::MakeMaker and Module::Build are + configured to (via C and C). + + By default, it installs to the site_perl directory that belongs to + your perl. You can see the locations for that by running C + and it will be likely something under C if you're + using system perl, or under your home directory if you have built perl + yourself using perlbrew or plenv. + + If you've already configured local::lib on your shell, cpanm respects + that settings and modules will be installed to your local perl5 + directory. + + At a boot time, cpanminus checks whether you have already configured + local::lib, or have a permission to install modules to the site_perl + directory. If neither, i.e. you're using system perl and do not run + cpanm as a root, it automatically sets up local::lib compatible + installation path in a C directory under your home + directory. + + To avoid this, run C either as a root user, with C<--sudo> + option, or with C<--local-lib> option. + + =head2 cpanminus can't install the module XYZ. Is it a bug? + + It is more likely a problem with the distribution itself. cpanminus + doesn't support or may have issues with distributions such as follows: + + =over 4 + + =item * + + Tests that require input from STDIN. + + =item * + + Build.PL or Makefile.PL that prompts for input even when + C is enabled. + + =item * + + Modules that have invalid numeric values as VERSION (such as C<1.1a>) + + =back + + These failures can be reported back to the author of the module so + that they can fix it accordingly, rather than to cpanminus. + + =head2 Does cpanm support the feature XYZ of L and L? + + Most likely not. Here are the things that cpanm doesn't do by + itself. + + If you need these features, use L, L or the standalone + tools that are mentioned. + + =over 4 + + =item * + + CPAN testers reporting. See L + + =item * + + Building RPM packages from CPAN modules + + =item * + + Listing the outdated modules that needs upgrading. See L + + =item * + + Showing the changes of the modules you're about to upgrade. See L + + =item * + + Patching CPAN modules with distroprefs. + + =back + + See L or C to see what cpanminus I do :) + + =head1 COPYRIGHT + + Copyright 2010- Tatsuhiko Miyagawa + + The standalone executable contains the following modules embedded. + + =over 4 + + =item L Copyright 2003 Graham Barr + + =item L Copyright 2007-2009 Matt S Trout + + =item L Copyright 2011 Christian Hansen + + =item L Copyright 2001-2006 Ken Williams. 2010 Matt S Trout + + =item L Copyright 2004-2010 John Peacock + + =item L Copyright 2007-2011 by Makamaka Hannyaharamitu + + =item L, L Copyright (c) 2010 by David Golden and Ricardo Signes + + =item L Copyright 2010 Adam Kennedy + + =item L Copyright 2012 David Golden + + =back + + =head1 LICENSE + + This software is licensed under the same terms as Perl. + + =head1 CREDITS + + =head2 CONTRIBUTORS + + Patches and code improvements were contributed by: + + Goro Fuji, Kazuhiro Osawa, Tokuhiro Matsuno, Kenichi Ishigaki, Ian + Wells, Pedro Melo, Masayoshi Sekimura, Matt S Trout (mst), squeeky, + horus and Ingy dot Net. + + =head2 ACKNOWLEDGEMENTS + + Bug reports, suggestions and feedbacks were sent by, or general + acknowledgement goes to: + + Jesse Vincent, David Golden, Andreas Koenig, Jos Boumans, Chris + Williams, Adam Kennedy, Audrey Tang, J. Shirley, Chris Prather, Jesse + Luehrs, Marcus Ramberg, Shawn M Moore, chocolateboy, Chirs Nehren, + Jonathan Rockway, Leon Brocard, Simon Elliott, Ricardo Signes, AEvar + Arnfjord Bjarmason, Eric Wilhelm, Florian Ragwitz and xaicron. + + =head1 COMMUNITY + + =over 4 + + =item L - source code repository, issue tracker + + =item L - discussions about Perl toolchain. I'm there. + + =back + + =head1 NO WARRANTY + + This software is provided "as-is," without any express or implied + warranty. In no event shall the author be held liable for any damages + arising from the use of the software. + + =head1 SEE ALSO + + L L L + + =cut + + 1; + APP_CPANMINUS + + $fatpacked{"App/cpanminus/Dependency.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_CPANMINUS_DEPENDENCY'; + package App::cpanminus::Dependency; + use strict; + use CPAN::Meta::Requirements; + + sub from_prereqs { + my($class, $prereqs, $phases, $types) = @_; + + my @deps; + for my $type (@$types) { + push @deps, $class->from_versions( + $prereqs->merged_requirements($phases, [$type])->as_string_hash, + $type, + ); + } + + return @deps; + } + + sub from_versions { + my($class, $versions, $type) = @_; + + my @deps; + while (my($module, $version) = each %$versions) { + push @deps, $class->new($module, $version, $type) + } + + @deps; + } + + sub merge_with { + my($self, $requirements) = @_; + + # save the original requirement + $self->{original_version} = $self->version; + + # should it clone? not cloning means we upgrade root $requirements on our way + eval { + $requirements->add_string_requirement($self->module, $self->version); + }; + if ($@ =~ /illegal requirements/) { + # Just give a warning then replace with the root requirements + # so that later CPAN::Meta::Check can give a valid error + warn sprintf("Can't merge requirements for %s: '%s' and '%s'", + $self->module, $self->version, + $requirements->requirements_for_module($self->module)); + } + + $self->{version} = $requirements->requirements_for_module($self->module); + } + + sub new { + my($class, $module, $version, $type) = @_; + + bless { + module => $module, + version => $version, + type => $type || 'requires', + }, $class; + } + + sub module { $_[0]->{module} } + sub version { $_[0]->{version} } + sub type { $_[0]->{type} } + + sub requires_version { + my $self = shift; + + # original_version may be 0 + if (defined $self->{original_version}) { + return $self->{original_version}; + } + + $self->version; + } + + sub is_requirement { + $_[0]->{type} eq 'requires'; + } + + 1; + APP_CPANMINUS_DEPENDENCY + + $fatpacked{"App/cpanminus/script.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_CPANMINUS_SCRIPT'; + package App::cpanminus::script; + use strict; + use Config; + use Cwd (); + use App::cpanminus; + use App::cpanminus::Dependency; + use File::Basename (); + use File::Find (); + use File::Path (); + use File::Spec (); + use File::Copy (); + use File::Temp (); + use Getopt::Long (); + use Symbol (); + use String::ShellQuote (); + use version (); + + use constant WIN32 => $^O eq 'MSWin32'; + use constant BAD_TAR => ($^O eq 'solaris' || $^O eq 'hpux'); + use constant CAN_SYMLINK => eval { symlink("", ""); 1 }; + + our $VERSION = $App::cpanminus::VERSION; + + if ($INC{"App/FatPacker/Trace.pm"}) { + require version::vpp; + } + + my $quote = WIN32 ? q/"/ : q/'/; + + sub agent { + my $self = shift; + my $agent = "cpanminus/$VERSION"; + $agent .= " perl/$]" if $self->{report_perl_version}; + $agent; + } + + sub determine_home { + my $class = shift; + + my $homedir = $ENV{HOME} + || eval { require File::HomeDir; File::HomeDir->my_home } + || join('', @ENV{qw(HOMEDRIVE HOMEPATH)}); # Win32 + + if (WIN32) { + require Win32; # no fatpack + $homedir = Win32::GetShortPathName($homedir); + } + + return "$homedir/.cpanm"; + } + + sub new { + my $class = shift; + + bless { + home => $class->determine_home, + cmd => 'install', + seen => {}, + notest => undef, + test_only => undef, + installdeps => undef, + force => undef, + sudo => undef, + make => undef, + verbose => undef, + quiet => undef, + interactive => undef, + log => undef, + mirrors => [], + mirror_only => undef, + mirror_index => undef, + cpanmetadb => "http://cpanmetadb.plackperl.org/v1.0/", + perl => $^X, + argv => [], + local_lib => undef, + self_contained => undef, + exclude_vendor => undef, + prompt_timeout => 0, + prompt => undef, + configure_timeout => 60, + build_timeout => 3600, + test_timeout => 1800, + try_lwp => 1, + try_wget => 1, + try_curl => 1, + uninstall_shadows => ($] < 5.012), + skip_installed => 1, + skip_satisfied => 0, + auto_cleanup => 7, # days + pod2man => 1, + installed_dists => 0, + install_types => ['requires'], + with_develop => 0, + showdeps => 0, + scandeps => 0, + scandeps_tree => [], + format => 'tree', + save_dists => undef, + skip_configure => 0, + verify => 0, + report_perl_version => !$class->maybe_ci, + build_args => {}, + features => {}, + pure_perl => 0, + cpanfile_path => 'cpanfile', + @_, + }, $class; + } + + sub env { + my($self, $key) = @_; + $ENV{"PERL_CPANM_" . $key}; + } + + sub maybe_ci { + my $class = shift; + grep $ENV{$_}, qw( TRAVIS CI AUTOMATED_TESTING AUTHOR_TESTING ); + } + + sub install_type_handlers { + my $self = shift; + + my @handlers; + for my $type (qw( recommends suggests )) { + push @handlers, "with-$type" => sub { + my %uniq; + $self->{install_types} = [ grep !$uniq{$_}++, @{$self->{install_types}}, $type ]; + }; + push @handlers, "without-$type" => sub { + $self->{install_types} = [ grep $_ ne $type, @{$self->{install_types}} ]; + }; + } + + @handlers; + } + + sub build_args_handlers { + my $self = shift; + + my @handlers; + for my $phase (qw( configure build test install )) { + push @handlers, "$phase-args=s" => \($self->{build_args}{$phase}); + } + + @handlers; + } + + sub parse_options { + my $self = shift; + + local @ARGV = @{$self->{argv}}; + push @ARGV, grep length, split /\s+/, $self->env('OPT'); + push @ARGV, @_; + + Getopt::Long::Configure("bundling"); + Getopt::Long::GetOptions( + 'f|force' => sub { $self->{skip_installed} = 0; $self->{force} = 1 }, + 'n|notest!' => \$self->{notest}, + 'test-only' => sub { $self->{notest} = 0; $self->{skip_installed} = 0; $self->{test_only} = 1 }, + 'S|sudo!' => \$self->{sudo}, + 'v|verbose' => \$self->{verbose}, + 'verify!' => \$self->{verify}, + 'q|quiet!' => \$self->{quiet}, + 'h|help' => sub { $self->{action} = 'show_help' }, + 'V|version' => sub { $self->{action} = 'show_version' }, + 'perl=s' => sub { + $self->diag("--perl is deprecated since it's known to be fragile in figuring out dependencies. Run `$_[1] -S cpanm` instead.\n", 1); + $self->{perl} = $_[1]; + }, + 'l|local-lib=s' => sub { $self->{local_lib} = $self->maybe_abs($_[1]) }, + 'L|local-lib-contained=s' => sub { + $self->{local_lib} = $self->maybe_abs($_[1]); + $self->{self_contained} = 1; + $self->{pod2man} = undef; + }, + 'self-contained!' => \$self->{self_contained}, + 'exclude-vendor!' => \$self->{exclude_vendor}, + 'mirror=s@' => $self->{mirrors}, + 'mirror-only!' => \$self->{mirror_only}, + 'mirror-index=s' => sub { $self->{mirror_index} = $self->maybe_abs($_[1]) }, + 'M|from=s' => sub { + $self->{mirrors} = [$_[1]]; + $self->{mirror_only} = 1; + }, + 'cpanmetadb=s' => \$self->{cpanmetadb}, + 'cascade-search!' => \$self->{cascade_search}, + 'prompt!' => \$self->{prompt}, + 'installdeps' => \$self->{installdeps}, + 'skip-installed!' => \$self->{skip_installed}, + 'skip-satisfied!' => \$self->{skip_satisfied}, + 'reinstall' => sub { $self->{skip_installed} = 0 }, + 'interactive!' => \$self->{interactive}, + 'i|install' => sub { $self->{cmd} = 'install' }, + 'info' => sub { $self->{cmd} = 'info' }, + 'look' => sub { $self->{cmd} = 'look'; $self->{skip_installed} = 0 }, + 'U|uninstall' => sub { $self->{cmd} = 'uninstall' }, + 'self-upgrade' => sub { $self->{action} = 'self_upgrade' }, + 'uninst-shadows!' => \$self->{uninstall_shadows}, + 'lwp!' => \$self->{try_lwp}, + 'wget!' => \$self->{try_wget}, + 'curl!' => \$self->{try_curl}, + 'auto-cleanup=s' => \$self->{auto_cleanup}, + 'man-pages!' => \$self->{pod2man}, + 'scandeps' => \$self->{scandeps}, + 'showdeps' => sub { $self->{showdeps} = 1; $self->{skip_installed} = 0 }, + 'format=s' => \$self->{format}, + 'save-dists=s' => sub { + $self->{save_dists} = $self->maybe_abs($_[1]); + }, + 'skip-configure!' => \$self->{skip_configure}, + 'dev!' => \$self->{dev_release}, + 'metacpan!' => \$self->{metacpan}, + 'report-perl-version!' => \$self->{report_perl_version}, + 'configure-timeout=i' => \$self->{configure_timeout}, + 'build-timeout=i' => \$self->{build_timeout}, + 'test-timeout=i' => \$self->{test_timeout}, + 'with-develop' => \$self->{with_develop}, + 'without-develop' => sub { $self->{with_develop} = 0 }, + 'with-feature=s' => sub { $self->{features}{$_[1]} = 1 }, + 'without-feature=s' => sub { $self->{features}{$_[1]} = 0 }, + 'with-all-features' => sub { $self->{features}{__all} = 1 }, + 'pp|pureperl!' => \$self->{pure_perl}, + "cpanfile=s" => \$self->{cpanfile_path}, + $self->install_type_handlers, + $self->build_args_handlers, + ); + + if (!@ARGV && $0 ne '-' && !-t STDIN){ # e.g. # cpanm < author/requires.cpanm + push @ARGV, $self->load_argv_from_fh(\*STDIN); + $self->{load_from_stdin} = 1; + } + + $self->{argv} = \@ARGV; + } + + sub check_upgrade { + my $self = shift; + my $install_base = $ENV{PERL_LOCAL_LIB_ROOT} ? $self->local_lib_target($ENV{PERL_LOCAL_LIB_ROOT}) : $Config{installsitebin}; + if ($0 eq '-') { + # run from curl, that's fine + return; + } elsif ($0 !~ /^$install_base/) { + if ($0 =~ m!perlbrew/bin!) { + die <{_checked}++; + $self->bootstrap_local_lib; + } + + sub setup_verify { + my $self = shift; + + my $has_modules = eval { require Module::Signature; require Digest::SHA; 1 }; + $self->{cpansign} = $self->which('cpansign'); + + unless ($has_modules && $self->{cpansign}) { + warn "WARNING: Module::Signature and Digest::SHA is required for distribution verifications.\n"; + $self->{verify} = 0; + } + } + + sub parse_module_args { + my($self, $module) = @_; + + # Plack@1.2 -> Plack~"==1.2" + # BUT don't expand @ in git URLs + $module =~ s/^([A-Za-z0-9_:]+)@([v\d\._]+)$/$1~== $2/; + + # Plack~1.20, DBI~"> 1.0, <= 2.0" + if ($module =~ /\~[v\d\._,\!<>= ]+$/) { + return split /\~/, $module, 2; + } else { + return $module, undef; + } + } + + sub doit { + my $self = shift; + + my $code; + eval { + $code = ($self->_doit == 0); + }; if (my $e = $@) { + warn $e; + $code = 1; + } + + return $code; + } + + sub _doit { + my $self = shift; + + $self->setup_home; + $self->init_tools; + $self->setup_verify if $self->{verify}; + + if (my $action = $self->{action}) { + $self->$action() and return 1; + } + + return $self->show_help(1) + unless @{$self->{argv}} or $self->{load_from_stdin}; + + $self->configure_mirrors; + + my $cwd = Cwd::cwd; + + my @fail; + for my $module (@{$self->{argv}}) { + if ($module =~ s/\.pm$//i) { + my ($volume, $dirs, $file) = File::Spec->splitpath($module); + $module = join '::', grep { $_ } File::Spec->splitdir($dirs), $file; + } + ($module, my $version) = $self->parse_module_args($module); + + $self->chdir($cwd); + if ($self->{cmd} eq 'uninstall') { + $self->uninstall_module($module) + or push @fail, $module; + } else { + $self->install_module($module, 0, $version) + or push @fail, $module; + } + } + + if ($self->{base} && $self->{auto_cleanup}) { + $self->cleanup_workdirs; + } + + if ($self->{installed_dists}) { + my $dists = $self->{installed_dists} > 1 ? "distributions" : "distribution"; + $self->diag("$self->{installed_dists} $dists installed\n", 1); + } + + if ($self->{scandeps}) { + $self->dump_scandeps(); + } + # Workaround for older File::Temp's + # where creating a tempdir with an implicit $PWD + # causes tempdir non-cleanup if $PWD changes + # as paths are stored internally without being resolved + # absolutely. + # https://rt.cpan.org/Public/Bug/Display.html?id=44924 + $self->chdir($cwd); + + return !@fail; + } + + sub setup_home { + my $self = shift; + + $self->{home} = $self->env('HOME') if $self->env('HOME'); + + unless (_writable($self->{home})) { + die "Can't write to cpanm home '$self->{home}': You should fix it with chown/chmod first.\n"; + } + + $self->{base} = "$self->{home}/work/" . time . ".$$"; + File::Path::mkpath([ $self->{base} ], 0, 0777); + + # native path because we use shell redirect + $self->{log} = File::Spec->catfile($self->{base}, "build.log"); + my $final_log = "$self->{home}/build.log"; + + { open my $out, ">$self->{log}" or die "$self->{log}: $!" } + + if (CAN_SYMLINK) { + my $build_link = "$self->{home}/latest-build"; + unlink $build_link; + symlink $self->{base}, $build_link; + + unlink $final_log; + symlink $self->{log}, $final_log; + } else { + my $log = $self->{log}; my $home = $self->{home}; + $self->{at_exit} = sub { + my $self = shift; + my $temp_log = "$home/build.log." . time . ".$$"; + File::Copy::copy($log, $temp_log) + && unlink($final_log); + rename($temp_log, $final_log); + } + } + + $self->chat("cpanm (App::cpanminus) $VERSION on perl $] built for $Config{archname}\n" . + "Work directory is $self->{base}\n"); + } + + sub package_index_for { + my ($self, $mirror) = @_; + return $self->source_for($mirror) . "/02packages.details.txt"; + } + + sub generate_mirror_index { + my ($self, $mirror) = @_; + my $file = $self->package_index_for($mirror); + my $gz_file = $file . '.gz'; + my $index_mtime = (stat $gz_file)[9]; + + unless (-e $file && (stat $file)[9] >= $index_mtime) { + $self->chat("Uncompressing index file...\n"); + if (eval {require Compress::Zlib}) { + my $gz = Compress::Zlib::gzopen($gz_file, "rb") + or do { $self->diag_fail("$Compress::Zlib::gzerrno opening compressed index"); return}; + open my $fh, '>', $file + or do { $self->diag_fail("$! opening uncompressed index for write"); return }; + my $buffer; + while (my $status = $gz->gzread($buffer)) { + if ($status < 0) { + $self->diag_fail($gz->gzerror . " reading compressed index"); + return; + } + print $fh $buffer; + } + } else { + if (system("gunzip -c $gz_file > $file")) { + $self->diag_fail("Cannot uncompress -- please install gunzip or Compress::Zlib"); + return; + } + } + utime $index_mtime, $index_mtime, $file; + } + return 1; + } + + sub search_mirror_index { + my ($self, $mirror, $module, $version) = @_; + $self->search_mirror_index_file($self->package_index_for($mirror), $module, $version); + } + + sub search_mirror_index_file { + my($self, $file, $module, $version) = @_; + + open my $fh, '<', $file or return; + my $found; + while (<$fh>) { + if (m!^\Q$module\E\s+([\w\.]+)\s+(\S*)!m) { + $found = $self->cpan_module($module, $2, $1); + last; + } + } + + return $found unless $self->{cascade_search}; + + if ($found) { + if ($self->satisfy_version($module, $found->{module_version}, $version)) { + return $found; + } else { + $self->chat("Found $module $found->{module_version} which doesn't satisfy $version.\n"); + } + } + + return; + } + + sub with_version_range { + my($self, $version) = @_; + defined($version) && $version =~ /(?:<|!=|==)/; + } + + sub encode_json { + my($self, $data) = @_; + require JSON::PP; + + my $json = JSON::PP::encode_json($data); + $json =~ s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/eg; + $json; + } + + # TODO extract this as a module? + sub version_to_query { + my($self, $module, $version) = @_; + + require CPAN::Meta::Requirements; + + my $requirements = CPAN::Meta::Requirements->new; + $requirements->add_string_requirement($module, $version || '0'); + + my $req = $requirements->requirements_for_module($module); + + if ($req =~ s/^==\s*//) { + return { + term => { 'module.version' => $req }, + }; + } elsif ($req !~ /\s/) { + return { + range => { 'module.version_numified' => { 'gte' => $self->numify_ver_metacpan($req) } }, + }; + } else { + my %ops = qw(< lt <= lte > gt >= gte); + my(%range, @exclusion); + my @requirements = split /,\s*/, $req; + for my $r (@requirements) { + if ($r =~ s/^([<>]=?)\s*//) { + $range{$ops{$1}} = $self->numify_ver_metacpan($r); + } elsif ($r =~ s/\!=\s*//) { + push @exclusion, $self->numify_ver_metacpan($r); + } + } + + my @filters= ( + { range => { 'module.version_numified' => \%range } }, + ); + + if (@exclusion) { + push @filters, { + not => { or => [ map { +{ term => { 'module.version_numified' => $self->numify_ver_metacpan($_) } } } @exclusion ] }, + }; + } + + return @filters; + } + } + + # Apparently MetaCPAN numifies devel releases by stripping _ first + sub numify_ver_metacpan { + my($self, $ver) = @_; + $ver =~ s/_//g; + version->new($ver)->numify; + } + + # version->new("1.00_00")->numify => "1.00_00" :/ + sub numify_ver { + my($self, $ver) = @_; + eval version->new($ver)->numify; + } + + sub maturity_filter { + my($self, $module, $version) = @_; + + if ($version =~ /==/) { + # specific version: allow dev release + return; + } elsif ($self->{dev_release}) { + # backpan'ed dev releases are considered cancelled + return +{ not => { term => { status => 'backpan' } } }; + } else { + return ( + { not => { term => { status => 'backpan' } } }, + { term => { maturity => 'released' } }, + ); + } + } + + sub by_version { + my %s = qw( latest 3 cpan 2 backpan 1 ); + $b->{_score} <=> $a->{_score} || # version: higher version that satisfies the query + $s{ $b->{fields}{status} } <=> $s{ $a->{fields}{status} }; # prefer non-BackPAN dist + } + + sub by_first_come { + $a->{fields}{date} cmp $b->{fields}{date}; # first one wins, if all are in BackPAN/CPAN + } + + sub by_date { + $b->{fields}{date} cmp $a->{fields}{date}; # prefer new uploads, when searching for dev + } + + sub find_best_match { + my($self, $match, $version) = @_; + return unless $match && @{$match->{hits}{hits} || []}; + my @hits = $self->{dev_release} + ? sort { by_version || by_date } @{$match->{hits}{hits}} + : sort { by_version || by_first_come } @{$match->{hits}{hits}}; + $hits[0]->{fields}; + } + + sub search_metacpan { + my($self, $module, $version) = @_; + + require JSON::PP; + + $self->chat("Searching $module ($version) on metacpan ...\n"); + + my $metacpan_uri = 'http://api.metacpan.org/v0'; + + my @filter = $self->maturity_filter($module, $version); + + my $query = { filtered => { + (@filter ? (filter => { and => \@filter }) : ()), + query => { nested => { + score_mode => 'max', + path => 'module', + query => { custom_score => { + metacpan_script => "score_version_numified", + query => { constant_score => { + filter => { and => [ + { term => { 'module.authorized' => JSON::PP::true() } }, + { term => { 'module.indexed' => JSON::PP::true() } }, + { term => { 'module.name' => $module } }, + $self->version_to_query($module, $version), + ] } + } }, + } }, + } }, + } }; + + my $module_uri = "$metacpan_uri/file/_search?source="; + $module_uri .= $self->encode_json({ + query => $query, + fields => [ 'date', 'release', 'author', 'module', 'status' ], + }); + + my($release, $author, $module_version); + + my $module_json = $self->get($module_uri); + my $module_meta = eval { JSON::PP::decode_json($module_json) }; + my $match = $self->find_best_match($module_meta); + if ($match) { + $release = $match->{release}; + $author = $match->{author}; + my $module_matched = (grep { $_->{name} eq $module } @{$match->{module}})[0]; + $module_version = $module_matched->{version}; + } + + unless ($release) { + $self->chat("! Could not find a release matching $module ($version) on MetaCPAN.\n"); + return; + } + + my $dist_uri = "$metacpan_uri/release/_search?source="; + $dist_uri .= $self->encode_json({ + filter => { and => [ + { term => { 'release.name' => $release } }, + { term => { 'release.author' => $author } }, + ]}, + fields => [ 'download_url', 'stat', 'status' ], + }); + + my $dist_json = $self->get($dist_uri); + my $dist_meta = eval { JSON::PP::decode_json($dist_json) }; + + if ($dist_meta) { + $dist_meta = $dist_meta->{hits}{hits}[0]{fields}; + } + if ($dist_meta && $dist_meta->{download_url}) { + (my $distfile = $dist_meta->{download_url}) =~ s!.+/authors/id/!!; + local $self->{mirrors} = $self->{mirrors}; + if ($dist_meta->{status} eq 'backpan') { + $self->{mirrors} = [ 'http://backpan.perl.org' ]; + } elsif ($dist_meta->{stat}{mtime} > time()-24*60*60) { + $self->{mirrors} = [ 'http://cpan.metacpan.org' ]; + } + return $self->cpan_module($module, $distfile, $module_version); + } + + $self->diag_fail("Finding $module on metacpan failed."); + return; + } + + sub search_database { + my($self, $module, $version) = @_; + + my $found; + + if ($self->{dev_release} or $self->{metacpan}) { + $found = $self->search_metacpan($module, $version) and return $found; + $found = $self->search_cpanmetadb($module, $version) and return $found; + } else { + $found = $self->search_cpanmetadb($module, $version) and return $found; + $found = $self->search_metacpan($module, $version) and return $found; + } + } + + sub search_cpanmetadb { + my($self, $module, $version) = @_; + + + $self->chat("Searching $module ($version) on cpanmetadb ...\n"); + + if ($self->with_version_range($version)) { + return $self->search_cpanmetadb_history($module, $version); + } else { + return $self->search_cpanmetadb_package($module, $version); + } + } + + sub search_cpanmetadb_package { + my($self, $module, $version) = @_; + + require CPAN::Meta::YAML; + + (my $uri = $self->{cpanmetadb}) =~ s{/?$}{/package/$module}; + my $yaml = $self->get($uri); + my $meta = eval { CPAN::Meta::YAML::Load($yaml) }; + if ($meta && $meta->{distfile}) { + return $self->cpan_module($module, $meta->{distfile}, $meta->{version}); + } + + $self->diag_fail("Finding $module on cpanmetadb failed."); + return; + } + + sub search_cpanmetadb_history { + my($self, $module, $version) = @_; + + (my $uri = $self->{cpanmetadb}) =~ s{/?$}{/history/$module}; + my $content = $self->get($uri) or return; + + my @found; + for my $line (split /\r?\n/, $content) { + if ($line =~ /^$module\s+(\S+)\s+(\S+)$/) { + push @found, { + version => $1, + version_obj => version::->parse($1), + distfile => $2, + }; + } + } + + return unless @found; + + $found[-1]->{latest} = 1; + + my $match; + for my $try (sort { $b->{version_obj} cmp $a->{version_obj} } @found) { + if ($self->satisfy_version($module, $try->{version_obj}, $version)) { + local $self->{mirrors} = $self->{mirrors}; + unshift @{$self->{mirrors}}, 'http://backpan.perl.org' + unless $try->{latest}; + return $self->cpan_module($module, $try->{distfile}, $try->{version}); + } + } + + $self->diag_fail("Finding $module ($version) on cpanmetadb failed."); + return; + } + + + sub search_module { + my($self, $module, $version) = @_; + + if ($self->{mirror_index}) { + $self->mask_output( chat => "Searching $module on mirror index $self->{mirror_index} ...\n" ); + my $pkg = $self->search_mirror_index_file($self->{mirror_index}, $module, $version); + return $pkg if $pkg; + + unless ($self->{cascade_search}) { + $self->mask_output( diag_fail => "Finding $module ($version) on mirror index $self->{mirror_index} failed." ); + return; + } + } + + unless ($self->{mirror_only}) { + my $found = $self->search_database($module, $version); + return $found if $found; + } + + MIRROR: for my $mirror (@{ $self->{mirrors} }) { + $self->mask_output( chat => "Searching $module on mirror $mirror ...\n" ); + my $name = '02packages.details.txt.gz'; + my $uri = "$mirror/modules/$name"; + my $gz_file = $self->package_index_for($mirror) . '.gz'; + + unless ($self->{pkgs}{$uri}) { + $self->mask_output( chat => "Downloading index file $uri ...\n" ); + $self->mirror($uri, $gz_file); + $self->generate_mirror_index($mirror) or next MIRROR; + $self->{pkgs}{$uri} = "!!retrieved!!"; + } + + my $pkg = $self->search_mirror_index($mirror, $module, $version); + return $pkg if $pkg; + + $self->mask_output( diag_fail => "Finding $module ($version) on mirror $mirror failed." ); + } + + return; + } + + sub source_for { + my($self, $mirror) = @_; + $mirror =~ s/[^\w\.\-]+/%/g; + + my $dir = "$self->{home}/sources/$mirror"; + File::Path::mkpath([ $dir ], 0, 0777); + + return $dir; + } + + sub load_argv_from_fh { + my($self, $fh) = @_; + + my @argv; + while(defined(my $line = <$fh>)){ + chomp $line; + $line =~ s/#.+$//; # comment + $line =~ s/^\s+//; # trim spaces + $line =~ s/\s+$//; # trim spaces + + push @argv, split ' ', $line if $line; + } + return @argv; + } + + sub show_version { + my $self = shift; + + print "cpanm (App::cpanminus) version $VERSION ($0)\n"; + print "perl version $] ($^X)\n\n"; + + print " \%Config:\n"; + for my $key (qw( archname installsitelib installsitebin installman1dir installman3dir + sitearchexp sitelibexp vendorarch vendorlibexp archlibexp privlibexp )) { + print " $key=$Config{$key}\n" if $Config{$key}; + } + + print " \%ENV:\n"; + for my $key (grep /^PERL/, sort keys %ENV) { + print " $key=$ENV{$key}\n"; + } + + print " \@INC:\n"; + for my $inc (@INC) { + print " $inc\n" unless ref($inc) eq 'CODE'; + } + + return 1; + } + + sub show_help { + my $self = shift; + + if ($_[0]) { + print <splitdir($dir); + while (@dir) { + $dir = File::Spec->catdir(@dir); + if (-e $dir) { + return -w _; + } + pop @dir; + } + + return; + } + + sub maybe_abs { + my($self, $lib) = @_; + if ($lib eq '_' or $lib =~ /^~/ or File::Spec->file_name_is_absolute($lib)) { + return $lib; + } else { + return File::Spec->canonpath(File::Spec->catdir(Cwd::cwd(), $lib)); + } + } + + sub local_lib_target { + my($self, $root) = @_; + # local::lib 1.008025 changed the order of PERL_LOCAL_LIB_ROOT + (grep { $_ ne '' } split /\Q$Config{path_sep}/, $root)[0]; + } + + sub bootstrap_local_lib { + my $self = shift; + + # If -l is specified, use that. + if ($self->{local_lib}) { + return $self->setup_local_lib($self->{local_lib}); + } + + # PERL_LOCAL_LIB_ROOT is defined. Run as local::lib mode without overwriting ENV + if ($ENV{PERL_LOCAL_LIB_ROOT} && $ENV{PERL_MM_OPT}) { + return $self->setup_local_lib($self->local_lib_target($ENV{PERL_LOCAL_LIB_ROOT}), 1); + } + + # root, locally-installed perl or --sudo: don't care about install_base + return if $self->{sudo} or (_writable($Config{installsitelib}) and _writable($Config{installsitebin})); + + # local::lib is configured in the shell -- yay + if ($ENV{PERL_MM_OPT} and ($ENV{MODULEBUILDRC} or $ENV{PERL_MB_OPT})) { + return; + } + + $self->setup_local_lib; + + $self->diag(<module => $_ } @$config_deps; + + # M::B 0.38 and EUMM 6.58 for MYMETA + # EU::Install 1.46 for local::lib + my $reqs = CPAN::Meta::Requirements->from_string_hash({ + 'Module::Build' => '0.38', + 'ExtUtils::MakeMaker' => '6.58', + 'ExtUtils::Install' => '1.46', + }); + + if ($deps{"ExtUtils::MakeMaker"}) { + $deps{"ExtUtils::MakeMaker"}->merge_with($reqs); + } elsif ($deps{"Module::Build"}) { + $deps{"Module::Build"}->merge_with($reqs); + $deps{"ExtUtils::Install"} ||= App::cpanminus::Dependency->new("ExtUtils::Install", 0, 'configure'); + $deps{"ExtUtils::Install"}->merge_with($reqs); + } + + @$config_deps = values %deps; + } + + sub _core_only_inc { + my($self, $base) = @_; + require local::lib; + ( + local::lib->resolve_path(local::lib->install_base_arch_path($base)), + local::lib->resolve_path(local::lib->install_base_perl_path($base)), + (!$self->{exclude_vendor} ? grep {$_} @Config{qw(vendorarch vendorlibexp)} : ()), + @Config{qw(archlibexp privlibexp)}, + ); + } + + sub _diff { + my($self, $old, $new) = @_; + + my @diff; + my %old = map { $_ => 1 } @$old; + for my $n (@$new) { + push @diff, $n unless exists $old{$n}; + } + + @diff; + } + + sub _setup_local_lib_env { + my($self, $base) = @_; + + $self->diag(<setup_env_hash_for($base, 0); + } + + sub setup_local_lib { + my($self, $base, $no_env) = @_; + $base = undef if $base eq '_'; + + require local::lib; + { + local $0 = 'cpanm'; # so curl/wget | perl works + $base ||= "~/perl5"; + $base = local::lib->resolve_path($base); + if ($self->{self_contained}) { + my @inc = $self->_core_only_inc($base); + $self->{search_inc} = [ @inc ]; + } else { + $self->{search_inc} = [ + local::lib->install_base_arch_path($base), + local::lib->install_base_perl_path($base), + @INC, + ]; + } + $self->_setup_local_lib_env($base) unless $no_env; + $self->{local_lib} = $base; + } + } + + sub prompt_bool { + my($self, $mess, $def) = @_; + + my $val = $self->prompt($mess, $def); + return lc $val eq 'y'; + } + + sub prompt { + my($self, $mess, $def) = @_; + + my $isa_tty = -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT)) ; + my $dispdef = defined $def ? "[$def] " : " "; + $def = defined $def ? $def : ""; + + if (!$self->{prompt} || (!$isa_tty && eof STDIN)) { + return $def; + } + + local $|=1; + local $\; + my $ans; + eval { + local $SIG{ALRM} = sub { undef $ans; die "alarm\n" }; + print STDOUT "$mess $dispdef"; + alarm $self->{prompt_timeout} if $self->{prompt_timeout}; + $ans = ; + alarm 0; + }; + if ( defined $ans ) { + chomp $ans; + } else { # user hit ctrl-D or alarm timeout + print STDOUT "\n"; + } + + return (!defined $ans || $ans eq '') ? $def : $ans; + } + + sub diag_ok { + my($self, $msg) = @_; + chomp $msg; + $msg ||= "OK"; + if ($self->{in_progress}) { + $self->_diag("$msg\n"); + $self->{in_progress} = 0; + } + $self->log("-> $msg\n"); + } + + sub diag_fail { + my($self, $msg, $always) = @_; + chomp $msg; + if ($self->{in_progress}) { + $self->_diag("FAIL\n"); + $self->{in_progress} = 0; + } + + if ($msg) { + $self->_diag("! $msg\n", $always, 1); + $self->log("-> FAIL $msg\n"); + } + } + + sub diag_progress { + my($self, $msg) = @_; + chomp $msg; + $self->{in_progress} = 1; + $self->_diag("$msg ... "); + $self->log("$msg\n"); + } + + sub _diag { + my($self, $msg, $always, $error) = @_; + my $fh = $error ? *STDERR : *STDOUT; + print {$fh} $msg if $always or $self->{verbose} or !$self->{quiet}; + } + + sub diag { + my($self, $msg, $always) = @_; + $self->_diag($msg, $always); + $self->log($msg); + } + + sub chat { + my $self = shift; + print STDERR @_ if $self->{verbose}; + $self->log(@_); + } + + sub mask_output { + my $self = shift; + my $method = shift; + $self->$method( $self->mask_uri_passwords(@_) ); + } + + sub log { + my $self = shift; + open my $out, ">>$self->{log}"; + print $out @_; + } + + sub run { + my($self, $cmd) = @_; + + if (WIN32) { + $cmd = $self->shell_quote(@$cmd) if ref $cmd eq 'ARRAY'; + unless ($self->{verbose}) { + $cmd .= " >> " . $self->shell_quote($self->{log}) . " 2>&1"; + } + !system $cmd; + } else { + my $pid = fork; + if ($pid) { + waitpid $pid, 0; + return !$?; + } else { + $self->run_exec($cmd); + } + } + } + + sub run_exec { + my($self, $cmd) = @_; + + if (ref $cmd eq 'ARRAY') { + unless ($self->{verbose}) { + open my $logfh, ">>", $self->{log}; + open STDERR, '>&', $logfh; + open STDOUT, '>&', $logfh; + close $logfh; + } + exec @$cmd; + } else { + unless ($self->{verbose}) { + $cmd .= " >> " . $self->shell_quote($self->{log}) . " 2>&1"; + } + exec $cmd; + } + } + + sub run_timeout { + my($self, $cmd, $timeout) = @_; + return $self->run($cmd) if WIN32 || $self->{verbose} || !$timeout; + + my $pid = fork; + if ($pid) { + eval { + local $SIG{ALRM} = sub { die "alarm\n" }; + alarm $timeout; + waitpid $pid, 0; + alarm 0; + }; + if ($@ && $@ eq "alarm\n") { + $self->diag_fail("Timed out (> ${timeout}s). Use --verbose to retry."); + local $SIG{TERM} = 'IGNORE'; + kill TERM => 0; + waitpid $pid, 0; + return; + } + return !$?; + } elsif ($pid == 0) { + $self->run_exec($cmd); + } else { + $self->chat("! fork failed: falling back to system()\n"); + $self->run($cmd); + } + } + + sub append_args { + my($self, $cmd, $phase) = @_; + + if (my $args = $self->{build_args}{$phase}) { + $cmd = join ' ', $self->shell_quote(@$cmd), $args; + } + + $cmd; + } + + sub configure { + my($self, $cmd, $depth) = @_; + + # trick AutoInstall + local $ENV{PERL5_CPAN_IS_RUNNING} = local $ENV{PERL5_CPANPLUS_IS_RUNNING} = $$; + + # e.g. skip CPAN configuration on local::lib + local $ENV{PERL5_CPANM_IS_RUNNING} = $$; + + my $use_default = !$self->{interactive}; + local $ENV{PERL_MM_USE_DEFAULT} = $use_default; + + local $ENV{PERL_MM_OPT} = $ENV{PERL_MM_OPT}; + local $ENV{PERL_MB_OPT} = $ENV{PERL_MB_OPT}; + + # skip man page generation + unless ($self->{pod2man}) { + $ENV{PERL_MM_OPT} .= " INSTALLMAN1DIR=none INSTALLMAN3DIR=none"; + $ENV{PERL_MB_OPT} .= " --config installman1dir= --config installsiteman1dir= --config installman3dir= --config installsiteman3dir="; + } + + # Lancaster Consensus + if ($self->{pure_perl}) { + $ENV{PERL_MM_OPT} .= " PUREPERL_ONLY=1"; + $ENV{PERL_MB_OPT} .= " --pureperl-only"; + } + + $cmd = $self->append_args($cmd, 'configure') if $depth == 0; + + local $self->{verbose} = $self->{verbose} || $self->{interactive}; + $self->run_timeout($cmd, $self->{configure_timeout}); + } + + sub build { + my($self, $cmd, $distname, $depth) = @_; + + local $ENV{PERL_MM_USE_DEFAULT} = !$self->{interactive}; + + $cmd = $self->append_args($cmd, 'build') if $depth == 0; + + return 1 if $self->run_timeout($cmd, $self->{build_timeout}); + while (1) { + my $ans = lc $self->prompt("Building $distname failed.\nYou can s)kip, r)etry, e)xamine build log, or l)ook ?", "s"); + return if $ans eq 's'; + return $self->build($cmd, $distname, $depth) if $ans eq 'r'; + $self->show_build_log if $ans eq 'e'; + $self->look if $ans eq 'l'; + } + } + + sub test { + my($self, $cmd, $distname, $depth) = @_; + return 1 if $self->{notest}; + + # https://rt.cpan.org/Ticket/Display.html?id=48965#txn-1013385 + local $ENV{PERL_MM_USE_DEFAULT} = !$self->{interactive}; + + # https://github.com/Perl-Toolchain-Gang/toolchain-site/blob/master/lancaster-consensus.md + local $ENV{NONINTERACTIVE_TESTING} = !$self->{interactive}; + + $cmd = $self->append_args($cmd, 'test') if $depth == 0; + + return 1 if $self->run_timeout($cmd, $self->{test_timeout}); + if ($self->{force}) { + $self->diag_fail("Testing $distname failed but installing it anyway."); + return 1; + } else { + $self->diag_fail; + while (1) { + my $ans = lc $self->prompt("Testing $distname failed.\nYou can s)kip, r)etry, f)orce install, e)xamine build log, or l)ook ?", "s"); + return if $ans eq 's'; + return $self->test($cmd, $distname, $depth) if $ans eq 'r'; + return 1 if $ans eq 'f'; + $self->show_build_log if $ans eq 'e'; + $self->look if $ans eq 'l'; + } + } + } + + sub install { + my($self, $cmd, $uninst_opts, $depth) = @_; + + if ($depth == 0 && $self->{test_only}) { + return 1; + } + + if ($self->{sudo}) { + unshift @$cmd, "sudo"; + } + + if ($self->{uninstall_shadows} && !$ENV{PERL_MM_OPT}) { + push @$cmd, @$uninst_opts; + } + + $cmd = $self->append_args($cmd, 'install') if $depth == 0; + + $self->run($cmd); + } + + sub look { + my $self = shift; + + my $shell = $ENV{SHELL}; + $shell ||= $ENV{COMSPEC} if WIN32; + if ($shell) { + my $cwd = Cwd::cwd; + $self->diag("Entering $cwd with $shell\n"); + system $shell; + } else { + $self->diag_fail("You don't seem to have a SHELL :/"); + } + } + + sub show_build_log { + my $self = shift; + + my @pagers = ( + $ENV{PAGER}, + (WIN32 ? () : ('less')), + 'more' + ); + my $pager; + while (@pagers) { + $pager = shift @pagers; + next unless $pager; + $pager = $self->which($pager); + next unless $pager; + last; + } + + if ($pager) { + # win32 'more' doesn't allow "more build.log", the < is required + system("$pager < $self->{log}"); + } + else { + $self->diag_fail("You don't seem to have a PAGER :/"); + } + } + + sub chdir { + my $self = shift; + Cwd::chdir(File::Spec->canonpath($_[0])) or die "$_[0]: $!"; + } + + sub configure_mirrors { + my $self = shift; + unless (@{$self->{mirrors}}) { + $self->{mirrors} = [ 'http://www.cpan.org' ]; + } + for (@{$self->{mirrors}}) { + s!^/!file:///!; + s!/$!!; + } + } + + sub self_upgrade { + my $self = shift; + $self->check_upgrade; + $self->{argv} = [ 'App::cpanminus' ]; + return; # continue + } + + sub install_module { + my($self, $module, $depth, $version) = @_; + + $self->check_libs; + + if ($self->{seen}{$module}++) { + # TODO: circular dependencies + $self->chat("Already tried $module. Skipping.\n"); + return 1; + } + + if ($self->{skip_satisfied}) { + my($ok, $local) = $self->check_module($module, $version || 0); + if ($ok) { + $self->diag("You have $module ($local)\n", 1); + return 1; + } + } + + my $dist = $self->resolve_name($module, $version); + unless ($dist) { + my $what = $module . ($version ? " ($version)" : ""); + $self->diag_fail("Couldn't find module or a distribution $what", 1); + return; + } + + if ($dist->{distvname} && $self->{seen}{$dist->{distvname}}++) { + $self->chat("Already tried $dist->{distvname}. Skipping.\n"); + return 1; + } + + if ($self->{cmd} eq 'info') { + print $self->format_dist($dist), "\n"; + return 1; + } + + $dist->{depth} = $depth; # ugly hack + + if ($dist->{module}) { + unless ($self->satisfy_version($dist->{module}, $dist->{module_version}, $version)) { + $self->diag("Found $dist->{module} $dist->{module_version} which doesn't satisfy $version.\n", 1); + return; + } + + # If a version is requested, it has to be the exact same version, otherwise, check as if + # it is the minimum version you need. + my $cmp = $version ? "==" : ""; + my $requirement = $dist->{module_version} ? "$cmp$dist->{module_version}" : 0; + my($ok, $local) = $self->check_module($dist->{module}, $requirement); + if ($self->{skip_installed} && $ok) { + $self->diag("$dist->{module} is up to date. ($local)\n", 1); + return 1; + } + } + + if ($dist->{dist} eq 'perl'){ + $self->diag("skipping $dist->{pathname}\n"); + return 1; + } + + $self->diag("--> Working on $module\n"); + + $dist->{dir} ||= $self->fetch_module($dist); + + unless ($dist->{dir}) { + $self->diag_fail("Failed to fetch distribution $dist->{distvname}", 1); + return; + } + + $self->chat("Entering $dist->{dir}\n"); + $self->chdir($self->{base}); + $self->chdir($dist->{dir}); + + if ($self->{cmd} eq 'look') { + $self->look; + return 1; + } + + return $self->build_stuff($module, $dist, $depth); + } + + sub uninstall_search_path { + my $self = shift; + + $self->{local_lib} + ? (local::lib->install_base_arch_path($self->{local_lib}), + local::lib->install_base_perl_path($self->{local_lib})) + : @Config{qw(installsitearch installsitelib)}; + } + + sub uninstall_module { + my ($self, $module) = @_; + + $self->check_libs; + + my @inc = $self->uninstall_search_path; + + my($metadata, $packlist) = $self->packlists_containing($module, \@inc); + unless ($packlist) { + $self->diag_fail(<uninstall_target($metadata, $packlist); + + $self->ask_permission($module, \@uninst_files) or return; + $self->uninstall_files(@uninst_files, $packlist); + + $self->diag("Successfully uninstalled $module\n", 1); + + return 1; + } + + sub packlists_containing { + my($self, $module, $inc) = @_; + + require Module::Metadata; + my $metadata = Module::Metadata->new_from_module($module, inc => $inc) + or return; + + my $packlist; + my $wanted = sub { + return unless $_ eq '.packlist' && -f $_; + for my $file ($self->unpack_packlist($File::Find::name)) { + $packlist ||= $File::Find::name if $file eq $metadata->filename; + } + }; + + { + require File::pushd; + my $pushd = File::pushd::pushd(); + my @search = grep -d $_, map File::Spec->catdir($_, 'auto'), @$inc; + File::Find::find($wanted, @search); + } + + return $metadata, $packlist; + } + + sub uninstall_target { + my($self, $metadata, $packlist) = @_; + + # If the module has a shadow install, or uses local::lib, then you can't just remove + # all files in .packlist since it might have shadows in there + if ($self->has_shadow_install($metadata) or $self->{local_lib}) { + grep $self->should_unlink($_), $self->unpack_packlist($packlist); + } else { + $self->unpack_packlist($packlist); + } + } + + sub has_shadow_install { + my($self, $metadata) = @_; + + # check if you have the module in site_perl *and* perl + my @shadow = grep defined, map Module::Metadata->new_from_module($metadata->name, inc => [$_]), @INC; + @shadow >= 2; + } + + sub should_unlink { + my($self, $file) = @_; + + # If local::lib is used, everything under the directory can be safely removed + # Otherwise, bin and man files might be shared with the shadows i.e. site_perl vs perl + # This is not 100% safe to keep the script there hoping to work with older version of .pm + # files in the shadow, but there's nothing you can do about it. + if ($self->{local_lib}) { + $file =~ /^\Q$self->{local_lib}\E/; + } else { + !(grep $file =~ /^\Q$_\E/, @Config{qw(installbin installscript installman1dir installman3dir)}); + } + } + + sub ask_permission { + my ($self, $module, $files) = @_; + + $self->diag("$module contains the following files:\n\n"); + for my $file (@$files) { + $self->diag(" $file\n"); + } + $self->diag("\n"); + + return 'force uninstall' if $self->{force}; + local $self->{prompt} = 1; + return $self->prompt_bool("Are you sure you want to uninstall $module?", 'y'); + } + + sub unpack_packlist { + my ($self, $packlist) = @_; + open my $fh, '<', $packlist or die "$packlist: $!"; + map { chomp; $_ } <$fh>; + } + + sub uninstall_files { + my ($self, @files) = @_; + + $self->diag("\n"); + + for my $file (@files) { + $self->diag("Unlink: $file\n"); + unlink $file or $self->diag_fail("$!: $file"); + } + + $self->diag("\n"); + + return 1; + } + + sub format_dist { + my($self, $dist) = @_; + + # TODO support --dist-format? + return "$dist->{cpanid}/$dist->{filename}"; + } + + sub trim { + local $_ = shift; + tr/\n/ /d; + s/^\s*|\s*$//g; + $_; + } + + sub fetch_module { + my($self, $dist) = @_; + + $self->chdir($self->{base}); + + for my $uri (@{$dist->{uris}}) { + $self->mask_output( diag_progress => "Fetching $uri" ); + + # Ugh, $dist->{filename} can contain sub directory + my $filename = $dist->{filename} || $uri; + my $name = File::Basename::basename($filename); + + my $cancelled; + my $fetch = sub { + my $file; + eval { + local $SIG{INT} = sub { $cancelled = 1; die "SIGINT\n" }; + $self->mirror($uri, $name); + $file = $name if -e $name; + }; + $self->diag("ERROR: " . trim("$@") . "\n", 1) if $@ && $@ ne "SIGINT\n"; + return $file; + }; + + my($try, $file); + while ($try++ < 3) { + $file = $fetch->(); + last if $cancelled or $file; + $self->mask_output( diag_fail => "Download $uri failed. Retrying ... "); + } + + if ($cancelled) { + $self->diag_fail("Download cancelled."); + return; + } + + unless ($file) { + $self->mask_output( diag_fail => "Failed to download $uri"); + next; + } + + $self->diag_ok; + $dist->{local_path} = File::Spec->rel2abs($name); + + my $dir = $self->unpack($file, $uri, $dist); + next unless $dir; # unpack failed + + if (my $save = $self->{save_dists}) { + # Only distros retrieved from CPAN have a pathname set + my $path = $dist->{pathname} ? "$save/authors/id/$dist->{pathname}" + : "$save/vendor/$file"; + $self->chat("Copying $name to $path\n"); + File::Path::mkpath([ File::Basename::dirname($path) ], 0, 0777); + File::Copy::copy($file, $path) or warn $!; + } + + return $dist, $dir; + } + } + + sub unpack { + my($self, $file, $uri, $dist) = @_; + + if ($self->{verify}) { + $self->verify_archive($file, $uri, $dist) or return; + } + + $self->chat("Unpacking $file\n"); + my $dir = $file =~ /\.zip/i ? $self->unzip($file) : $self->untar($file); + unless ($dir) { + $self->diag_fail("Failed to unpack $file: no directory"); + } + return $dir; + } + + sub verify_checksums_signature { + my($self, $chk_file) = @_; + + require Module::Signature; # no fatpack + + $self->chat("Verifying the signature of CHECKSUMS\n"); + + my $rv = eval { + local $SIG{__WARN__} = sub {}; # suppress warnings + my $v = Module::Signature::_verify($chk_file); + $v == Module::Signature::SIGNATURE_OK(); + }; + if ($rv) { + $self->chat("Verified OK!\n"); + } else { + $self->diag_fail("Verifying CHECKSUMS signature failed: $rv\n"); + return; + } + + return 1; + } + + sub verify_archive { + my($self, $file, $uri, $dist) = @_; + + unless ($dist->{cpanid}) { + $self->chat("Archive '$file' does not seem to be from PAUSE. Skip verification.\n"); + return 1; + } + + (my $mirror = $uri) =~ s!/authors/id.*$!!; + + (my $chksum_uri = $uri) =~ s!/[^/]*$!/CHECKSUMS!; + my $chk_file = $self->source_for($mirror) . "/$dist->{cpanid}.CHECKSUMS"; + $self->mask_output( diag_progress => "Fetching $chksum_uri" ); + $self->mirror($chksum_uri, $chk_file); + + unless (-e $chk_file) { + $self->diag_fail("Fetching $chksum_uri failed.\n"); + return; + } + + $self->diag_ok; + $self->verify_checksums_signature($chk_file) or return; + $self->verify_checksum($file, $chk_file); + } + + sub verify_checksum { + my($self, $file, $chk_file) = @_; + + $self->chat("Verifying the SHA1 for $file\n"); + + open my $fh, "<$chk_file" or die "$chk_file: $!"; + my $data = join '', <$fh>; + $data =~ s/\015?\012/\n/g; + + require Safe; # no fatpack + my $chksum = Safe->new->reval($data); + + if (!ref $chksum or ref $chksum ne 'HASH') { + $self->diag_fail("! Checksum file downloaded from $chk_file is broken.\n"); + return; + } + + if (my $sha = $chksum->{$file}{sha256}) { + my $hex = $self->sha1_for($file); + if ($hex eq $sha) { + $self->chat("Checksum for $file: Verified!\n"); + } else { + $self->diag_fail("Checksum mismatch for $file\n"); + return; + } + } else { + $self->chat("Checksum for $file not found in CHECKSUMS.\n"); + return; + } + } + + sub sha1_for { + my($self, $file) = @_; + + require Digest::SHA; # no fatpack + + open my $fh, "<", $file or die "$file: $!"; + my $dg = Digest::SHA->new(256); + my($data); + while (read($fh, $data, 4096)) { + $dg->add($data); + } + + return $dg->hexdigest; + } + + sub verify_signature { + my($self, $dist) = @_; + + $self->diag_progress("Verifying the SIGNATURE file"); + my $out = `$self->{cpansign} -v --skip 2>&1`; + $self->log($out); + + if ($out =~ /Signature verified OK/) { + $self->diag_ok("Verified OK"); + return 1; + } else { + $self->diag_fail("SIGNATURE verificaion for $dist->{filename} failed\n"); + return; + } + } + + sub resolve_name { + my($self, $module, $version) = @_; + + # Git + if ($module =~ /(?:^git:|\.git(?:@.+)?$)/) { + return $self->git_uri($module); + } + + # URL + if ($module =~ /^(ftp|https?|file):/) { + if ($module =~ m!authors/id/(.*)!) { + return $self->cpan_dist($1, $module); + } else { + return { uris => [ $module ] }; + } + } + + # Directory + if ($module =~ m!^[\./]! && -d $module) { + return { + source => 'local', + dir => Cwd::abs_path($module), + }; + } + + # File + if (-f $module) { + return { + source => 'local', + uris => [ "file://" . Cwd::abs_path($module) ], + }; + } + + # cpan URI + if ($module =~ s!^cpan:///distfile/!!) { + return $self->cpan_dist($module); + } + + # PAUSEID/foo + # P/PA/PAUSEID/foo + if ($module =~ m!^(?:[A-Z]/[A-Z]{2}/)?([A-Z]{2}[\-A-Z0-9]*/.*)$!) { + return $self->cpan_dist($1); + } + + # Module name + return $self->search_module($module, $version); + } + + sub cpan_module { + my($self, $module, $dist, $version) = @_; + + my $dist = $self->cpan_dist($dist); + $dist->{module} = $module; + $dist->{module_version} = $version if $version && $version ne 'undef'; + + return $dist; + } + + sub cpan_dist { + my($self, $dist, $url) = @_; + + $dist =~ s!^([A-Z]{2})!substr($1,0,1)."/".substr($1,0,2)."/".$1!e; + + require CPAN::DistnameInfo; + my $d = CPAN::DistnameInfo->new($dist); + + if ($url) { + $url = [ $url ] unless ref $url eq 'ARRAY'; + } else { + my $id = $d->cpanid; + my $fn = substr($id, 0, 1) . "/" . substr($id, 0, 2) . "/" . $id . "/" . $d->filename; + + my @mirrors = @{$self->{mirrors}}; + my @urls = map "$_/authors/id/$fn", @mirrors; + + $url = \@urls, + } + + return { + $d->properties, + source => 'cpan', + uris => $url, + }; + } + + sub git_uri { + my ($self, $uri) = @_; + + # similar to http://www.pip-installer.org/en/latest/logic.html#vcs-support + # git URL has to end with .git when you need to use pin @ commit/tag/branch + + ($uri, my $commitish) = split /(?<=\.git)@/i, $uri, 2; + + my $dir = File::Temp::tempdir(CLEANUP => 1); + + $self->mask_output( diag_progress => "Cloning $uri" ); + $self->run([ 'git', 'clone', $uri, $dir ]); + + unless (-e "$dir/.git") { + $self->diag_fail("Failed cloning git repository $uri", 1); + return; + } + + if ($commitish) { + require File::pushd; + my $dir = File::pushd::pushd($dir); + + unless ($self->run([ 'git', 'checkout', $commitish ])) { + $self->diag_fail("Failed to checkout '$commitish' in git repository $uri\n"); + return; + } + } + + $self->diag_ok; + + return { + source => 'local', + dir => $dir, + }; + } + + sub setup_module_build_patch { + my $self = shift; + + open my $out, ">$self->{base}/ModuleBuildSkipMan.pm" or die $!; + print $out <{search_inc} ||= do { + # strip lib/ and fatlib/ from search path when booted from dev + if (defined $::Bin) { + [grep !/^\Q$::Bin\E\/..\/(?:fat)?lib$/, @INC] + } else { + [@INC] + } + }; + } + + sub check_module { + my($self, $mod, $want_ver) = @_; + + require Module::Metadata; + my $meta = Module::Metadata->new_from_module($mod, inc => $self->search_inc) + or return 0, undef; + + my $version = $meta->version; + + # When -L is in use, the version loaded from 'perl' library path + # might be newer than (or actually wasn't core at) the version + # that is shipped with the current perl + if ($self->{self_contained} && $self->loaded_from_perl_lib($meta)) { + $version = $self->core_version_for($mod); + return 0, undef if $version && $version == -1; + } + + $self->{local_versions}{$mod} = $version; + + if ($self->is_deprecated($meta)){ + return 0, $version; + } elsif ($self->satisfy_version($mod, $version, $want_ver)) { + return 1, ($version || 'undef'); + } else { + return 0, $version; + } + } + + sub satisfy_version { + my($self, $mod, $version, $want_ver) = @_; + + $want_ver = '0' unless defined($want_ver) && length($want_ver); + + require CPAN::Meta::Requirements; + my $requirements = CPAN::Meta::Requirements->new; + $requirements->add_string_requirement($mod, $want_ver); + $requirements->accepts_module($mod, $version); + } + + sub unsatisfy_how { + my($self, $ver, $want_ver) = @_; + + if ($want_ver =~ /^[v0-9\.\_]+$/) { + return "$ver < $want_ver"; + } else { + return "$ver doesn't satisfy $want_ver"; + } + } + + sub is_deprecated { + my($self, $meta) = @_; + + my $deprecated = eval { + require Module::CoreList; # no fatpack + Module::CoreList::is_deprecated($meta->{module}); + }; + + return $deprecated && $self->loaded_from_perl_lib($meta); + } + + sub loaded_from_perl_lib { + my($self, $meta) = @_; + + require Config; + my @dirs = qw(archlibexp privlibexp); + if ($self->{self_contained} && ! $self->{exclude_vendor} && $Config{vendorarch}) { + unshift @dirs, qw(vendorarch vendorlibexp); + } + for my $dir (@dirs) { + my $confdir = $Config{$dir}; + if ($confdir eq substr($meta->filename, 0, length($confdir))) { + return 1; + } + } + + return; + } + + sub should_install { + my($self, $mod, $ver) = @_; + + $self->chat("Checking if you have $mod $ver ... "); + my($ok, $local) = $self->check_module($mod, $ver); + + if ($ok) { $self->chat("Yes ($local)\n") } + elsif ($local) { $self->chat("No (" . $self->unsatisfy_how($local, $ver) . ")\n") } + else { $self->chat("No\n") } + + return $mod unless $ok; + return; + } + + sub check_perl_version { + my($self, $version) = @_; + require CPAN::Meta::Requirements; + my $req = CPAN::Meta::Requirements->from_string_hash({ perl => $version }); + $req->accepts_module(perl => $]); + } + + sub install_deps { + my($self, $dir, $depth, @deps) = @_; + + my(@install, %seen, @fail); + for my $dep (@deps) { + next if $seen{$dep->module}; + if ($dep->module eq 'perl') { + if ($dep->is_requirement && !$self->check_perl_version($dep->version)) { + $self->diag("Needs perl @{[$dep->version]}, you have $]\n"); + push @fail, 'perl'; + } + } elsif ($self->should_install($dep->module, $dep->version)) { + push @install, $dep; + $seen{$dep->module} = 1; + } + } + + if (@install) { + $self->diag("==> Found dependencies: " . join(", ", map $_->module, @install) . "\n"); + } + + for my $dep (@install) { + $self->install_module($dep->module, $depth + 1, $dep->version); + } + + $self->chdir($self->{base}); + $self->chdir($dir) if $dir; + + if ($self->{scandeps}) { + return 1; # Don't check if dependencies are installed, since with --scandeps they aren't + } + my @not_ok = $self->unsatisfied_deps(@deps); + if (@not_ok) { + return 0, \@not_ok; + } else { + return 1; + } + } + + sub unsatisfied_deps { + my($self, @deps) = @_; + + require CPAN::Meta::Check; + require CPAN::Meta::Requirements; + + my $reqs = CPAN::Meta::Requirements->new; + for my $dep (grep $_->is_requirement, @deps) { + $reqs->add_string_requirement($dep->module => $dep->requires_version || '0'); + } + + my $ret = CPAN::Meta::Check::check_requirements($reqs, 'requires', $self->{search_inc}); + grep defined, values %$ret; + } + + sub install_deps_bailout { + my($self, $target, $dir, $depth, @deps) = @_; + + my($ok, $fail) = $self->install_deps($dir, $depth, @deps); + if (!$ok) { + $self->diag_fail("Installing the dependencies failed: " . join(", ", @$fail), 1); + unless ($self->prompt_bool("Do you want to continue building $target anyway?", "n")) { + $self->diag_fail("Bailing out the installation for $target.", 1); + return; + } + } + + return 1; + } + + sub build_stuff { + my($self, $stuff, $dist, $depth) = @_; + + if ($self->{verify} && -e 'SIGNATURE') { + $self->verify_signature($dist) or return; + } + + require CPAN::Meta; + + my($meta_file) = grep -f, qw(META.json META.yml); + if ($meta_file) { + $self->chat("Checking configure dependencies from $meta_file\n"); + $dist->{cpanmeta} = eval { CPAN::Meta->load_file($meta_file) }; + } elsif ($dist->{dist} && $dist->{version}) { + $self->chat("META.yml/json not found. Creating skeleton for it.\n"); + $dist->{cpanmeta} = CPAN::Meta->new({ name => $dist->{dist}, version => $dist->{version} }); + } + + $dist->{meta} = $dist->{cpanmeta} ? $dist->{cpanmeta}->as_struct : {}; + + my @config_deps; + if ($dist->{cpanmeta}) { + push @config_deps, App::cpanminus::Dependency->from_prereqs( + $dist->{cpanmeta}->effective_prereqs, ['configure'], $self->{install_types}, + ); + } + + if (-e 'Build.PL' && !$self->should_use_mm($dist->{dist}) && !@config_deps) { + push @config_deps, App::cpanminus::Dependency->from_versions( + { 'Module::Build' => '0.38' }, 'configure', + ); + } + + $self->upgrade_toolchain(\@config_deps); + + my $target = $dist->{meta}{name} ? "$dist->{meta}{name}-$dist->{meta}{version}" : $dist->{dir}; + { + local $self->{notest} = 1; + $self->install_deps_bailout($target, $dist->{dir}, $depth, @config_deps) + or return; + } + + $self->diag_progress("Configuring $target"); + + my $configure_state = $self->configure_this($dist, $depth); + $self->diag_ok($configure_state->{configured_ok} ? "OK" : "N/A"); + + if ($dist->{cpanmeta} && $dist->{source} eq 'cpan') { + $dist->{provides} = $dist->{cpanmeta}{provides} || $self->extract_packages($dist->{cpanmeta}, "."); + } + + # install direct 'test' dependencies for --installdeps, even with --notest + my $root_target = (($self->{installdeps} or $self->{showdeps}) and $depth == 0); + $dist->{want_phases} = $self->{notest} && !$root_target + ? [qw( build runtime )] : [qw( build test runtime )]; + + push @{$dist->{want_phases}}, 'develop' if $self->{with_develop} && $depth == 0; + + my @deps = $self->find_prereqs($dist); + my $module_name = $self->find_module_name($configure_state) || $dist->{meta}{name}; + $module_name =~ s/-/::/g; + + if ($self->{showdeps}) { + for my $dep (@config_deps, @deps) { + print $dep->module, ($dep->version ? ("~".$dep->version) : ""), "\n"; + } + return 1; + } + + my $distname = $dist->{meta}{name} ? "$dist->{meta}{name}-$dist->{meta}{version}" : $stuff; + + my $walkup; + if ($self->{scandeps}) { + $walkup = $self->scandeps_append_child($dist); + } + + $self->install_deps_bailout($distname, $dist->{dir}, $depth, @deps) + or return; + + if ($self->{scandeps}) { + unless ($configure_state->{configured_ok}) { + my $diag = <{log} for details. + ! You might have to install the following modules first to get --scandeps working correctly. + DIAG + if (@config_deps) { + my @tree = @{$self->{scandeps_tree}}; + $diag .= "!\n" . join("", map "! * $_->[0]{module}\n", @tree[0..$#tree-1]) if @tree; + } + $self->diag("!\n$diag!\n", 1); + } + $walkup->(); + return 1; + } + + if ($self->{installdeps} && $depth == 0) { + if ($configure_state->{configured_ok}) { + $self->diag("<== Installed dependencies for $stuff. Finishing.\n"); + return 1; + } else { + $self->diag("! Configuring $distname failed. See $self->{log} for details.\n", 1); + return; + } + } + + my $installed; + if ($configure_state->{use_module_build} && -e 'Build' && -f _) { + $self->diag_progress("Building " . ($self->{notest} ? "" : "and testing ") . $distname); + $self->build([ $self->{perl}, "./Build" ], $distname, $depth) && + $self->test([ $self->{perl}, "./Build", "test" ], $distname, $depth) && + $self->install([ $self->{perl}, "./Build", "install" ], [ "--uninst", 1 ], $depth) && + $installed++; + } elsif ($self->{make} && -e 'Makefile') { + $self->diag_progress("Building " . ($self->{notest} ? "" : "and testing ") . $distname); + $self->build([ $self->{make} ], $distname, $depth) && + $self->test([ $self->{make}, "test" ], $distname, $depth) && + $self->install([ $self->{make}, "install" ], [ "UNINST=1" ], $depth) && + $installed++; + } else { + my $why; + my $configure_failed = $configure_state->{configured} && !$configure_state->{configured_ok}; + if ($configure_failed) { $why = "Configure failed for $distname." } + elsif ($self->{make}) { $why = "The distribution doesn't have a proper Makefile.PL/Build.PL" } + else { $why = "Can't configure the distribution. You probably need to have 'make'." } + + $self->diag_fail("$why See $self->{log} for details.", 1); + return; + } + + if ($installed && $self->{test_only}) { + $self->diag_ok; + $self->diag("Successfully tested $distname\n", 1); + } elsif ($installed) { + my $local = $self->{local_versions}{$dist->{module} || ''}; + my $version = $dist->{module_version} || $dist->{meta}{version} || $dist->{version}; + my $reinstall = $local && ($local eq $version); + my $action = $local && !$reinstall + ? $self->numify_ver($version) < $self->numify_ver($local) + ? "downgraded" + : "upgraded" + : undef; + + my $how = $reinstall ? "reinstalled $distname" + : $local ? "installed $distname ($action from $local)" + : "installed $distname" ; + my $msg = "Successfully $how"; + $self->diag_ok; + $self->diag("$msg\n", 1); + $self->{installed_dists}++; + $self->save_meta($stuff, $dist, $module_name, \@config_deps, \@deps); + return 1; + } else { + my $what = $self->{test_only} ? "Testing" : "Installing"; + $self->diag_fail("$what $stuff failed. See $self->{log} for details. Retry with --force to force install it.", 1); + return; + } + } + + sub perl_requirements { + my($self, @requires) = @_; + + my @perl; + for my $requires (grep defined, @requires) { + if (exists $requires->{perl}) { + push @perl, App::cpanminus::Dependency->new(perl => $requires->{perl}); + } + } + + return @perl; + } + + sub should_use_mm { + my($self, $dist) = @_; + + # Module::Build deps should use MakeMaker because that causes circular deps and fail + # Otherwise we should prefer Build.PL + my %should_use_mm = map { $_ => 1 } qw( version ExtUtils-ParseXS ExtUtils-Install ExtUtils-Manifest ); + + $should_use_mm{$dist}; + } + + sub configure_this { + my($self, $dist, $depth) = @_; + + # Short-circuit `cpanm --installdeps .` because it doesn't need to build the current dir + if (-e $self->{cpanfile_path} && $self->{installdeps} && $depth == 0) { + require Module::CPANfile; + $dist->{cpanfile} = eval { Module::CPANfile->load($self->{cpanfile_path}) }; + $self->diag_fail($@, 1) if $@; + return { + configured => 1, + configured_ok => !!$dist->{cpanfile}, + use_module_build => 0, + }; + } + + if ($self->{skip_configure}) { + my $eumm = -e 'Makefile'; + my $mb = -e 'Build' && -f _; + return { + configured => 1, + configured_ok => $eumm || $mb, + use_module_build => $mb, + }; + } + + my $state = {}; + + my $try_eumm = sub { + if (-e 'Makefile.PL') { + $self->chat("Running Makefile.PL\n"); + + # NOTE: according to Devel::CheckLib, most XS modules exit + # with 0 even if header files are missing, to avoid receiving + # tons of FAIL reports in such cases. So exit code can't be + # trusted if it went well. + if ($self->configure([ $self->{perl}, "Makefile.PL" ], $depth)) { + $state->{configured_ok} = -e 'Makefile'; + } + $state->{configured}++; + } + }; + + my $try_mb = sub { + if (-e 'Build.PL') { + $self->chat("Running Build.PL\n"); + if ($self->configure([ $self->{perl}, "Build.PL" ], $depth)) { + $state->{configured_ok} = -e 'Build' && -f _; + } + $state->{use_module_build}++; + $state->{configured}++; + } + }; + + my @try; + if ($dist->{dist} && $self->should_use_mm($dist->{dist})) { + @try = ($try_eumm, $try_mb); + } else { + @try = ($try_mb, $try_eumm); + } + + for my $try (@try) { + $try->(); + last if $state->{configured_ok}; + } + + unless ($state->{configured_ok}) { + while (1) { + my $ans = lc $self->prompt("Configuring $dist->{dist} failed.\nYou can s)kip, r)etry, e)xamine build log, or l)ook ?", "s"); + last if $ans eq 's'; + return $self->configure_this($dist, $depth) if $ans eq 'r'; + $self->show_build_log if $ans eq 'e'; + $self->look if $ans eq 'l'; + } + } + + return $state; + } + + sub find_module_name { + my($self, $state) = @_; + + return unless $state->{configured_ok}; + + if ($state->{use_module_build} && + -e "_build/build_params") { + my $params = do { open my $in, "_build/build_params"; $self->safe_eval(join "", <$in>) }; + return eval { $params->[2]{module_name} } || undef; + } elsif (-e "Makefile") { + open my $mf, "Makefile"; + while (<$mf>) { + if (/^\#\s+NAME\s+=>\s+(.*)/) { + return $self->safe_eval($1); + } + } + } + + return; + } + + sub list_files { + my $self = shift; + + if (-e 'MANIFEST') { + require ExtUtils::Manifest; + my $manifest = eval { ExtUtils::Manifest::manifind() } || {}; + return sort { lc $a cmp lc $b } keys %$manifest; + } else { + require File::Find; + my @files; + my $finder = sub { + my $name = $File::Find::name; + $name =~ s!\.[/\\]!!; + push @files, $name; + }; + File::Find::find($finder, "."); + return sort { lc $a cmp lc $b } @files; + } + } + + sub extract_packages { + my($self, $meta, $dir) = @_; + + my $try = sub { + my $file = shift; + return 0 if $file =~ m!^(?:x?t|inc|local|perl5|fatlib|_build)/!; + return 1 unless $meta->{no_index}; + return 0 if grep { $file =~ m!^$_/! } @{$meta->{no_index}{directory} || []}; + return 0 if grep { $file eq $_ } @{$meta->{no_index}{file} || []}; + return 1; + }; + + require Parse::PMFile; + + my @files = grep { /\.pm(?:\.PL)?$/ && $try->($_) } $self->list_files; + + my $provides = { }; + + for my $file (@files) { + my $parser = Parse::PMFile->new($meta, { UNSAFE => 1, ALLOW_DEV_VERSION => 1 }); + my $packages = $parser->parse($file); + + while (my($package, $meta) = each %$packages) { + $provides->{$package} ||= { + file => $meta->{infile}, + ($meta->{version} eq 'undef') ? () : (version => $meta->{version}), + }; + } + } + + return $provides; + } + + sub save_meta { + my($self, $module, $dist, $module_name, $config_deps, $build_deps) = @_; + + return unless $dist->{distvname} && $dist->{source} eq 'cpan'; + + my $base = ($ENV{PERL_MM_OPT} || '') =~ /INSTALL_BASE=/ + ? ($self->install_base($ENV{PERL_MM_OPT}) . "/lib/perl5") : $Config{sitelibexp}; + + my $provides = $dist->{provides}; + + File::Path::mkpath("blib/meta", 0, 0777); + + my $local = { + name => $module_name, + target => $module, + version => exists $provides->{$module_name} + ? ($provides->{$module_name}{version} || $dist->{version}) : $dist->{version}, + dist => $dist->{distvname}, + pathname => $dist->{pathname}, + provides => $provides, + }; + + require JSON::PP; + open my $fh, ">", "blib/meta/install.json" or die $!; + print $fh JSON::PP::encode_json($local); + + # Existence of MYMETA.* Depends on EUMM/M::B versions and CPAN::Meta + if (-e "MYMETA.json") { + File::Copy::copy("MYMETA.json", "blib/meta/MYMETA.json"); + } + + my @cmd = ( + ($self->{sudo} ? 'sudo' : ()), + $^X, + '-MExtUtils::Install=install', + '-e', + qq[install({ 'blib/meta' => '$base/$Config{archname}/.meta/$dist->{distvname}' })], + ); + $self->run(\@cmd); + } + + sub _merge_hashref { + my($self, @hashrefs) = @_; + + my %hash; + for my $h (@hashrefs) { + %hash = (%hash, %$h); + } + + return \%hash; + } + + sub install_base { + my($self, $mm_opt) = @_; + $mm_opt =~ /INSTALL_BASE=(\S+)/ and return $1; + die "Your PERL_MM_OPT doesn't contain INSTALL_BASE"; + } + + sub safe_eval { + my($self, $code) = @_; + eval $code; + } + + sub configure_features { + my($self, $dist, @features) = @_; + map $_->identifier, grep { $self->effective_feature($dist, $_) } @features; + } + + sub effective_feature { + my($self, $dist, $feature) = @_; + + if ($dist->{depth} == 0) { + my $value = $self->{features}{$feature->identifier}; + return $value if defined $value; + return 1 if $self->{features}{__all}; + } + + if ($self->{interactive}) { + require CPAN::Meta::Requirements; + + $self->diag("[@{[ $feature->description ]}]\n", 1); + + my $req = CPAN::Meta::Requirements->new; + for my $phase (@{$dist->{want_phases}}) { + for my $type (@{$self->{install_types}}) { + $req->add_requirements($feature->prereqs->requirements_for($phase, $type)); + } + } + + my $reqs = $req->as_string_hash; + my @missing; + for my $module (keys %$reqs) { + if ($self->should_install($module, $req->{$module})) { + push @missing, $module; + } + } + + if (@missing) { + my $howmany = @missing; + $self->diag("==> Found missing dependencies: " . join(", ", @missing) . "\n", 1); + local $self->{prompt} = 1; + return $self->prompt_bool("Install the $howmany optional module(s)?", "y"); + } + } + + return; + } + + sub find_prereqs { + my($self, $dist) = @_; + + my @deps = $self->extract_meta_prereqs($dist); + + if ($dist->{module} =~ /^Bundle::/i) { + push @deps, $self->bundle_deps($dist); + } + + if ($self->{cpanfile_requirements} && !$dist->{cpanfile}) { + for my $dep (@deps) { + $dep->merge_with($self->{cpanfile_requirements}); + } + } + + return @deps; + } + + sub extract_meta_prereqs { + my($self, $dist) = @_; + + if ($dist->{cpanfile}) { + my @features = $self->configure_features($dist, $dist->{cpanfile}->features); + my $prereqs = $dist->{cpanfile}->prereqs_with(@features); + # TODO: creating requirements is useful even without cpanfile to detect conflicting prereqs + $self->{cpanfile_requirements} = $prereqs->merged_requirements($dist->{want_phases}, ['requires']); + return App::cpanminus::Dependency->from_prereqs($prereqs, $dist->{want_phases}, $self->{install_types}); + } + + require CPAN::Meta; + + my @deps; + my($meta_file) = grep -f, qw(MYMETA.json MYMETA.yml); + if ($meta_file) { + $self->chat("Checking dependencies from $meta_file ...\n"); + my $mymeta = eval { CPAN::Meta->load_file($meta_file, { lazy_validation => 1 }) }; + if ($mymeta) { + $dist->{meta}{name} = $mymeta->name; + $dist->{meta}{version} = $mymeta->version; + return $self->extract_prereqs($mymeta, $dist); + } + } + + if (-e '_build/prereqs') { + $self->chat("Checking dependencies from _build/prereqs ...\n"); + my $prereqs = do { open my $in, "_build/prereqs"; $self->safe_eval(join "", <$in>) }; + my $meta = CPAN::Meta->new( + { name => $dist->{meta}{name}, version => $dist->{meta}{version}, %$prereqs }, + { lazy_validation => 1 }, + ); + @deps = $self->extract_prereqs($meta, $dist); + } elsif (-e 'Makefile') { + $self->chat("Finding PREREQ from Makefile ...\n"); + open my $mf, "Makefile"; + while (<$mf>) { + if (/^\#\s+PREREQ_PM => \{\s*(.*?)\s*\}/) { + my @all; + my @pairs = split ', ', $1; + for (@pairs) { + my ($pkg, $v) = split '=>', $_; + push @all, [ $pkg, $v ]; + } + my $list = join ", ", map { "'$_->[0]' => $_->[1]" } @all; + my $prereq = $self->safe_eval("no strict; +{ $list }"); + push @deps, App::cpanminus::Dependency->from_versions($prereq) if $prereq; + last; + } + } + } + + return @deps; + } + + sub bundle_deps { + my($self, $dist) = @_; + + my @files; + File::Find::find({ + wanted => sub { push @files, File::Spec->rel2abs($_) if /\.pm/i }, + no_chdir => 1, + }, '.'); + + my @deps; + + for my $file (@files) { + open my $pod, "<", $file or next; + my $in_contents; + while (<$pod>) { + if (/^=head\d\s+CONTENTS/) { + $in_contents = 1; + } elsif (/^=/) { + $in_contents = 0; + } elsif ($in_contents) { + /^(\S+)\s*(\S+)?/ + and push @deps, App::cpanminus::Dependency->new($1, $self->maybe_version($2)); + } + } + } + + return @deps; + } + + sub maybe_version { + my($self, $string) = @_; + return $string && $string =~ /^\.?\d/ ? $string : undef; + } + + sub extract_prereqs { + my($self, $meta, $dist) = @_; + + my @features = $self->configure_features($dist, $meta->features); + my $prereqs = $self->soften_makemaker_prereqs($meta->effective_prereqs(\@features)->clone); + + return App::cpanminus::Dependency->from_prereqs($prereqs, $dist->{want_phases}, $self->{install_types}); + } + + # Workaround for Module::Install 1.04 creating a bogus (higher) MakeMaker requirement that it needs in build_requires + # Assuming MakeMaker requirement is already satisfied in configure_requires, there's no need to have higher version of + # MakeMaker in build/test anyway. https://github.com/miyagawa/cpanminus/issues/463 + sub soften_makemaker_prereqs { + my($self, $prereqs) = @_; + + return $prereqs unless -e "inc/Module/Install.pm"; + + for my $phase (qw( build test runtime )) { + my $reqs = $prereqs->requirements_for($phase, 'requires'); + if ($reqs->requirements_for_module('ExtUtils::MakeMaker')) { + $reqs->clear_requirement('ExtUtils::MakeMaker'); + $reqs->add_minimum('ExtUtils::MakeMaker' => 0); + } + } + + $prereqs; + } + + sub cleanup_workdirs { + my $self = shift; + + my $expire = time - 24 * 60 * 60 * $self->{auto_cleanup}; + my @targets; + + opendir my $dh, "$self->{home}/work"; + while (my $e = readdir $dh) { + next if $e !~ /^(\d+)\.\d+$/; # {UNIX time}.{PID} + my $time = $1; + if ($time < $expire) { + push @targets, "$self->{home}/work/$e"; + } + } + + if (@targets) { + if (@targets >= 64) { + $self->diag("Expiring " . scalar(@targets) . " work directories. This might take a while...\n"); + } else { + $self->chat("Expiring " . scalar(@targets) . " work directories.\n"); + } + File::Path::rmtree(\@targets, 0, 0); # safe = 0, since blib usually doesn't have write bits + } + } + + sub scandeps_append_child { + my($self, $dist) = @_; + + my $new_node = [ $dist, [] ]; + + my $curr_node = $self->{scandeps_current} || [ undef, $self->{scandeps_tree} ]; + push @{$curr_node->[1]}, $new_node; + + $self->{scandeps_current} = $new_node; + + return sub { $self->{scandeps_current} = $curr_node }; + } + + sub dump_scandeps { + my $self = shift; + + if ($self->{format} eq 'tree') { + $self->walk_down(sub { + my($dist, $depth) = @_; + if ($depth == 0) { + print "$dist->{distvname}\n"; + } else { + print " " x ($depth - 1); + print "\\_ $dist->{distvname}\n"; + } + }, 1); + } elsif ($self->{format} =~ /^dists?$/) { + $self->walk_down(sub { + my($dist, $depth) = @_; + print $self->format_dist($dist), "\n"; + }, 0); + } elsif ($self->{format} eq 'json') { + require JSON::PP; + print JSON::PP::encode_json($self->{scandeps_tree}); + } elsif ($self->{format} eq 'yaml') { + require YAML; # no fatpack + print YAML::Dump($self->{scandeps_tree}); + } else { + $self->diag("Unknown format: $self->{format}\n"); + } + } + + sub walk_down { + my($self, $cb, $pre) = @_; + $self->_do_walk_down($self->{scandeps_tree}, $cb, 0, $pre); + } + + sub _do_walk_down { + my($self, $children, $cb, $depth, $pre) = @_; + + # DFS - $pre determines when we call the callback + for my $node (@$children) { + $cb->($node->[0], $depth) if $pre; + $self->_do_walk_down($node->[1], $cb, $depth + 1, $pre); + $cb->($node->[0], $depth) unless $pre; + } + } + + sub DESTROY { + my $self = shift; + $self->{at_exit}->($self) if $self->{at_exit}; + } + + # Utils + + sub shell_quote { + my($self, @stuff) = @_; + if (WIN32) { + join ' ', map { /^${quote}.+${quote}$/ ? $_ : ($quote . $_ . $quote) } @stuff; + } else { + String::ShellQuote::shell_quote_best_effort(@stuff); + } + } + + sub which { + my($self, $name) = @_; + if (File::Spec->file_name_is_absolute($name)) { + if (-x $name && !-d _) { + return $name; + } + } + my $exe_ext = $Config{_exe}; + for my $dir (File::Spec->path) { + my $fullpath = File::Spec->catfile($dir, $name); + if ((-x $fullpath || -x ($fullpath .= $exe_ext)) && !-d _) { + if ($fullpath =~ /\s/) { + $fullpath = $self->shell_quote($fullpath); + } + return $fullpath; + } + } + return; + } + + sub get { + my($self, $uri) = @_; + if ($uri =~ /^file:/) { + $self->file_get($uri); + } else { + $self->{_backends}{get}->(@_); + } + } + + sub mirror { + my($self, $uri, $local) = @_; + if ($uri =~ /^file:/) { + $self->file_mirror($uri, $local); + } else { + $self->{_backends}{mirror}->(@_); + } + } + + sub untar { $_[0]->{_backends}{untar}->(@_) }; + sub unzip { $_[0]->{_backends}{unzip}->(@_) }; + + sub uri_to_file { + my($self, $uri) = @_; + + # file:///path/to/file -> /path/to/file + # file://C:/path -> C:/path + if ($uri =~ s!file:/+!!) { + $uri = "/$uri" unless $uri =~ m![a-zA-Z]:!; + } + + return $uri; + } + + sub file_get { + my($self, $uri) = @_; + my $file = $self->uri_to_file($uri); + open my $fh, "<$file" or return; + join '', <$fh>; + } + + sub file_mirror { + my($self, $uri, $path) = @_; + my $file = $self->uri_to_file($uri); + File::Copy::copy($file, $path); + } + + sub has_working_lwp { + my($self, $mirrors) = @_; + my $https = grep /^https:/, @$mirrors; + eval { + require LWP::UserAgent; # no fatpack + LWP::UserAgent->VERSION(5.802); + require LWP::Protocol::https if $https; # no fatpack + 1; + }; + } + + sub init_tools { + my $self = shift; + + return if $self->{initialized}++; + + if ($self->{make} = $self->which($Config{make})) { + $self->chat("You have make $self->{make}\n"); + } + + # use --no-lwp if they have a broken LWP, to upgrade LWP + if ($self->{try_lwp} && $self->has_working_lwp($self->{mirrors})) { + $self->chat("You have LWP $LWP::VERSION\n"); + my $ua = sub { + LWP::UserAgent->new( + parse_head => 0, + env_proxy => 1, + agent => $self->agent, + timeout => 30, + @_, + ); + }; + $self->{_backends}{get} = sub { + my $self = shift; + my $res = $ua->()->request(HTTP::Request->new(GET => $_[0])); + return unless $res->is_success; + return $res->decoded_content; + }; + $self->{_backends}{mirror} = sub { + my $self = shift; + my $res = $ua->()->mirror(@_); + die $res->content if $res->code == 501; + $res->code; + }; + } elsif ($self->{try_wget} and my $wget = $self->which('wget')) { + $self->chat("You have $wget\n"); + my @common = ( + '--user-agent', $self->agent, + '--retry-connrefused', + ($self->{verbose} ? () : ('-q')), + ); + $self->{_backends}{get} = sub { + my($self, $uri) = @_; + $self->safeexec( my $fh, $wget, $uri, @common, '-O', '-' ) or die "wget $uri: $!"; + local $/; + <$fh>; + }; + $self->{_backends}{mirror} = sub { + my($self, $uri, $path) = @_; + $self->safeexec( my $fh, $wget, $uri, @common, '-O', $path ) or die "wget $uri: $!"; + local $/; + <$fh>; + }; + } elsif ($self->{try_curl} and my $curl = $self->which('curl')) { + $self->chat("You have $curl\n"); + my @common = ( + '--location', + '--user-agent', $self->agent, + ($self->{verbose} ? () : '-s'), + ); + $self->{_backends}{get} = sub { + my($self, $uri) = @_; + $self->safeexec( my $fh, $curl, @common, $uri ) or die "curl $uri: $!"; + local $/; + <$fh>; + }; + $self->{_backends}{mirror} = sub { + my($self, $uri, $path) = @_; + $self->safeexec( my $fh, $curl, @common, $uri, '-#', '-o', $path ) or die "curl $uri: $!"; + local $/; + <$fh>; + }; + } else { + require HTTP::Tiny; + $self->chat("Falling back to HTTP::Tiny $HTTP::Tiny::VERSION\n"); + my %common = ( + agent => $self->agent, + ); + $self->{_backends}{get} = sub { + my $self = shift; + my $res = HTTP::Tiny->new(%common)->get($_[0]); + return unless $res->{success}; + return $res->{content}; + }; + $self->{_backends}{mirror} = sub { + my $self = shift; + my $res = HTTP::Tiny->new(%common)->mirror(@_); + return $res->{status}; + }; + } + + my $tar = $self->which('tar'); + my $tar_ver; + my $maybe_bad_tar = sub { WIN32 || BAD_TAR || (($tar_ver = `$tar --version 2>/dev/null`) =~ /GNU.*1\.13/i) }; + + if ($tar && !$maybe_bad_tar->()) { + chomp $tar_ver; + $self->chat("You have $tar: $tar_ver\n"); + $self->{_backends}{untar} = sub { + my($self, $tarfile) = @_; + + my $xf = ($self->{verbose} ? 'v' : '')."xf"; + my $ar = $tarfile =~ /bz2$/ ? 'j' : 'z'; + + my($root, @others) = `$tar ${ar}tf $tarfile` + or return undef; + + FILE: { + chomp $root; + $root =~ s!^\./!!; + $root =~ s{^(.+?)/.*$}{$1}; + + if (!length($root)) { + # archive had ./ as the first entry, so try again + $root = shift(@others); + redo FILE if $root; + } + } + + system "$tar $ar$xf $tarfile"; + return $root if -d $root; + + $self->diag_fail("Bad archive: $tarfile"); + return undef; + } + } elsif ( $tar + and my $gzip = $self->which('gzip') + and my $bzip2 = $self->which('bzip2')) { + $self->chat("You have $tar, $gzip and $bzip2\n"); + $self->{_backends}{untar} = sub { + my($self, $tarfile) = @_; + + my $x = "x" . ($self->{verbose} ? 'v' : '') . "f -"; + my $ar = $tarfile =~ /bz2$/ ? $bzip2 : $gzip; + + my($root, @others) = `$ar -dc $tarfile | $tar tf -` + or return undef; + + FILE: { + chomp $root; + $root =~ s!^\./!!; + $root =~ s{^(.+?)/.*$}{$1}; + + if (!length($root)) { + # archive had ./ as the first entry, so try again + $root = shift(@others); + redo FILE if $root; + } + } + + system "$ar -dc $tarfile | $tar $x"; + return $root if -d $root; + + $self->diag_fail("Bad archive: $tarfile"); + return undef; + } + } elsif (eval { require Archive::Tar }) { # uses too much memory! + $self->chat("Falling back to Archive::Tar $Archive::Tar::VERSION\n"); + $self->{_backends}{untar} = sub { + my $self = shift; + my $t = Archive::Tar->new($_[0]); + my($root, @others) = $t->list_files; + FILE: { + $root =~ s!^\./!!; + $root =~ s{^(.+?)/.*$}{$1}; + + if (!length($root)) { + # archive had ./ as the first entry, so try again + $root = shift(@others); + redo FILE if $root; + } + } + $t->extract; + return -d $root ? $root : undef; + }; + } else { + $self->{_backends}{untar} = sub { + die "Failed to extract $_[1] - You need to have tar or Archive::Tar installed.\n"; + }; + } + + if (my $unzip = $self->which('unzip')) { + $self->chat("You have $unzip\n"); + $self->{_backends}{unzip} = sub { + my($self, $zipfile) = @_; + + my $opt = $self->{verbose} ? '' : '-q'; + my(undef, $root, @others) = `$unzip -t $zipfile` + or return undef; + + chomp $root; + $root =~ s{^\s+testing:\s+([^/]+)/.*?\s+OK$}{$1}; + + system "$unzip $opt $zipfile"; + return $root if -d $root; + + $self->diag_fail("Bad archive: [$root] $zipfile"); + return undef; + } + } else { + $self->{_backends}{unzip} = sub { + eval { require Archive::Zip } + or die "Failed to extract $_[1] - You need to have unzip or Archive::Zip installed.\n"; + my($self, $file) = @_; + my $zip = Archive::Zip->new(); + my $status; + $status = $zip->read($file); + $self->diag_fail("Read of file[$file] failed") + if $status != Archive::Zip::AZ_OK(); + my @members = $zip->members(); + for my $member ( @members ) { + my $af = $member->fileName(); + next if ($af =~ m!^(/|\.\./)!); + $status = $member->extractToFileNamed( $af ); + $self->diag_fail("Extracting of file[$af] from zipfile[$file failed") + if $status != Archive::Zip::AZ_OK(); + } + + my ($root) = $zip->membersMatching( qr<^[^/]+/$> ); + $root &&= $root->fileName; + return -d $root ? $root : undef; + }; + } + } + + sub safeexec { + my $self = shift; + my $rdr = $_[0] ||= Symbol::gensym(); + + if (WIN32) { + my $cmd = $self->shell_quote(@_[1..$#_]); + return open( $rdr, "$cmd |" ); + } + + if ( my $pid = open( $rdr, '-|' ) ) { + return $pid; + } + elsif ( defined $pid ) { + exec( @_[ 1 .. $#_ ] ); + exit 1; + } + else { + return; + } + } + + sub mask_uri_passwords { + my($self, @strings) = @_; + s{ (https?://) ([^:/]+) : [^@/]+ @ }{$1$2:********@}gx for @strings; + return @strings; + } + + 1; + APP_CPANMINUS_SCRIPT + + $fatpacked{"CPAN/DistnameInfo.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_DISTNAMEINFO'; + + package CPAN::DistnameInfo; + + $VERSION = "0.12"; + use strict; + + sub distname_info { + my $file = shift or return; + + my ($dist, $version) = $file =~ /^ + ((?:[-+.]*(?:[A-Za-z0-9]+|(?<=\D)_|_(?=\D))* + (?: + [A-Za-z](?=[^A-Za-z]|$) + | + \d(?=-) + )(? 6 and $1 & 1) or ($2 and $2 >= 50)) or $3; + } + elsif ($version =~ /\d\D\d+_\d/ or $version =~ /-TRIAL/) { + $dev = 1; + } + } + else { + $version = undef; + } + + ($dist, $version, $dev); + } + + sub new { + my $class = shift; + my $distfile = shift; + + $distfile =~ s,//+,/,g; + + my %info = ( pathname => $distfile ); + + ($info{filename} = $distfile) =~ s,^(((.*?/)?authors/)?id/)?([A-Z])/(\4[A-Z])/(\5[-A-Z0-9]*)/,, + and $info{cpanid} = $6; + + if ($distfile =~ m,([^/]+)\.(tar\.(?:g?z|bz2)|zip|tgz)$,i) { # support more ? + $info{distvname} = $1; + $info{extension} = $2; + } + + @info{qw(dist version beta)} = distname_info($info{distvname}); + $info{maturity} = delete $info{beta} ? 'developer' : 'released'; + + return bless \%info, $class; + } + + sub dist { shift->{dist} } + sub version { shift->{version} } + sub maturity { shift->{maturity} } + sub filename { shift->{filename} } + sub cpanid { shift->{cpanid} } + sub distvname { shift->{distvname} } + sub extension { shift->{extension} } + sub pathname { shift->{pathname} } + + sub properties { %{ $_[0] } } + + 1; + + __END__ + + =head1 NAME + + CPAN::DistnameInfo - Extract distribution name and version from a distribution filename + + =head1 SYNOPSIS + + my $pathname = "authors/id/G/GB/GBARR/CPAN-DistnameInfo-0.02.tar.gz"; + + my $d = CPAN::DistnameInfo->new($pathname); + + my $dist = $d->dist; # "CPAN-DistnameInfo" + my $version = $d->version; # "0.02" + my $maturity = $d->maturity; # "released" + my $filename = $d->filename; # "CPAN-DistnameInfo-0.02.tar.gz" + my $cpanid = $d->cpanid; # "GBARR" + my $distvname = $d->distvname; # "CPAN-DistnameInfo-0.02" + my $extension = $d->extension; # "tar.gz" + my $pathname = $d->pathname; # "authors/id/G/GB/GBARR/..." + + my %prop = $d->properties; + + =head1 DESCRIPTION + + Many online services that are centered around CPAN attempt to + associate multiple uploads by extracting a distribution name from + the filename of the upload. For most distributions this is easy as + they have used ExtUtils::MakeMaker or Module::Build to create the + distribution, which results in a uniform name. But sadly not all + uploads are created in this way. + + C uses heuristics that have been learnt by + L to extract the distribution name and + version from filenames and also report if the version is to be + treated as a developer release + + The constructor takes a single pathname, returning an object with the following methods + + =over + + =item cpanid + + If the path given looked like a CPAN authors directory path, then this will be the + the CPAN id of the author. + + =item dist + + The name of the distribution + + =item distvname + + The file name with any suffix and leading directory names removed + + =item filename + + If the path given looked like a CPAN authors directory path, then this will be the + path to the file relative to the detected CPAN author directory. Otherwise it is the path + that was passed in. + + =item maturity + + The maturity of the distribution. This will be either C or C + + =item extension + + The extension of the distribution, often used to denote the archive type (e.g. 'tar.gz') + + =item pathname + + The pathname that was passed to the constructor when creating the object. + + =item properties + + This will return a list of key-value pairs, suitable for assigning to a hash, + for the known properties. + + =item version + + The extracted version + + =back + + =head1 AUTHOR + + Graham Barr + + =head1 COPYRIGHT + + Copyright (c) 2003 Graham Barr. All rights reserved. This program is + free software; you can redistribute it and/or modify it under the same + terms as Perl itself. + + =cut + + CPAN_DISTNAMEINFO + + $fatpacked{"CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META'; + use 5.006; + use strict; + use warnings; + package CPAN::Meta; + + our $VERSION = '2.150005'; + + #pod =head1 SYNOPSIS + #pod + #pod use v5.10; + #pod use strict; + #pod use warnings; + #pod use CPAN::Meta; + #pod use Module::Load; + #pod + #pod my $meta = CPAN::Meta->load_file('META.json'); + #pod + #pod printf "testing requirements for %s version %s\n", + #pod $meta->name, + #pod $meta->version; + #pod + #pod my $prereqs = $meta->effective_prereqs; + #pod + #pod for my $phase ( qw/configure runtime build test/ ) { + #pod say "Requirements for $phase:"; + #pod my $reqs = $prereqs->requirements_for($phase, "requires"); + #pod for my $module ( sort $reqs->required_modules ) { + #pod my $status; + #pod if ( eval { load $module unless $module eq 'perl'; 1 } ) { + #pod my $version = $module eq 'perl' ? $] : $module->VERSION; + #pod $status = $reqs->accepts_module($module, $version) + #pod ? "$version ok" : "$version not ok"; + #pod } else { + #pod $status = "missing" + #pod }; + #pod say " $module ($status)"; + #pod } + #pod } + #pod + #pod =head1 DESCRIPTION + #pod + #pod Software distributions released to the CPAN include a F or, for + #pod older distributions, F, which describes the distribution, its + #pod contents, and the requirements for building and installing the distribution. + #pod The data structure stored in the F file is described in + #pod L. + #pod + #pod CPAN::Meta provides a simple class to represent this distribution metadata (or + #pod I), along with some helpful methods for interrogating that data. + #pod + #pod The documentation below is only for the methods of the CPAN::Meta object. For + #pod information on the meaning of individual fields, consult the spec. + #pod + #pod =cut + + use Carp qw(carp croak); + use CPAN::Meta::Feature; + use CPAN::Meta::Prereqs; + use CPAN::Meta::Converter; + use CPAN::Meta::Validator; + use Parse::CPAN::Meta 1.4414 (); + + BEGIN { *_dclone = \&CPAN::Meta::Converter::_dclone } + + #pod =head1 STRING DATA + #pod + #pod The following methods return a single value, which is the value for the + #pod corresponding entry in the distmeta structure. Values should be either undef + #pod or strings. + #pod + #pod =for :list + #pod * abstract + #pod * description + #pod * dynamic_config + #pod * generated_by + #pod * name + #pod * release_status + #pod * version + #pod + #pod =cut + + BEGIN { + my @STRING_READERS = qw( + abstract + description + dynamic_config + generated_by + name + release_status + version + ); + + no strict 'refs'; + for my $attr (@STRING_READERS) { + *$attr = sub { $_[0]{ $attr } }; + } + } + + #pod =head1 LIST DATA + #pod + #pod These methods return lists of string values, which might be represented in the + #pod distmeta structure as arrayrefs or scalars: + #pod + #pod =for :list + #pod * authors + #pod * keywords + #pod * licenses + #pod + #pod The C and C methods may also be called as C and + #pod C, respectively, to match the field name in the distmeta structure. + #pod + #pod =cut + + BEGIN { + my @LIST_READERS = qw( + author + keywords + license + ); + + no strict 'refs'; + for my $attr (@LIST_READERS) { + *$attr = sub { + my $value = $_[0]{ $attr }; + croak "$attr must be called in list context" + unless wantarray; + return @{ _dclone($value) } if ref $value; + return $value; + }; + } + } + + sub authors { $_[0]->author } + sub licenses { $_[0]->license } + + #pod =head1 MAP DATA + #pod + #pod These readers return hashrefs of arbitrary unblessed data structures, each + #pod described more fully in the specification: + #pod + #pod =for :list + #pod * meta_spec + #pod * resources + #pod * provides + #pod * no_index + #pod * prereqs + #pod * optional_features + #pod + #pod =cut + + BEGIN { + my @MAP_READERS = qw( + meta-spec + resources + provides + no_index + + prereqs + optional_features + ); + + no strict 'refs'; + for my $attr (@MAP_READERS) { + (my $subname = $attr) =~ s/-/_/; + *$subname = sub { + my $value = $_[0]{ $attr }; + return _dclone($value) if $value; + return {}; + }; + } + } + + #pod =head1 CUSTOM DATA + #pod + #pod A list of custom keys are available from the C method and + #pod particular keys may be retrieved with the C method. + #pod + #pod say $meta->custom($_) for $meta->custom_keys; + #pod + #pod If a custom key refers to a data structure, a deep clone is returned. + #pod + #pod =cut + + sub custom_keys { + return grep { /^x_/i } keys %{$_[0]}; + } + + sub custom { + my ($self, $attr) = @_; + my $value = $self->{$attr}; + return _dclone($value) if ref $value; + return $value; + } + + #pod =method new + #pod + #pod my $meta = CPAN::Meta->new($distmeta_struct, \%options); + #pod + #pod Returns a valid CPAN::Meta object or dies if the supplied metadata hash + #pod reference fails to validate. Older-format metadata will be up-converted to + #pod version 2 if they validate against the original stated specification. + #pod + #pod It takes an optional hashref of options. Valid options include: + #pod + #pod =over + #pod + #pod =item * + #pod + #pod lazy_validation -- if true, new will attempt to convert the given metadata + #pod to version 2 before attempting to validate it. This means than any + #pod fixable errors will be handled by CPAN::Meta::Converter before validation. + #pod (Note that this might result in invalid optional data being silently + #pod dropped.) The default is false. + #pod + #pod =back + #pod + #pod =cut + + sub _new { + my ($class, $struct, $options) = @_; + my $self; + + if ( $options->{lazy_validation} ) { + # try to convert to a valid structure; if succeeds, then return it + my $cmc = CPAN::Meta::Converter->new( $struct ); + $self = $cmc->convert( version => 2 ); # valid or dies + return bless $self, $class; + } + else { + # validate original struct + my $cmv = CPAN::Meta::Validator->new( $struct ); + unless ( $cmv->is_valid) { + die "Invalid metadata structure. Errors: " + . join(", ", $cmv->errors) . "\n"; + } + } + + # up-convert older spec versions + my $version = $struct->{'meta-spec'}{version} || '1.0'; + if ( $version == 2 ) { + $self = $struct; + } + else { + my $cmc = CPAN::Meta::Converter->new( $struct ); + $self = $cmc->convert( version => 2 ); + } + + return bless $self, $class; + } + + sub new { + my ($class, $struct, $options) = @_; + my $self = eval { $class->_new($struct, $options) }; + croak($@) if $@; + return $self; + } + + #pod =method create + #pod + #pod my $meta = CPAN::Meta->create($distmeta_struct, \%options); + #pod + #pod This is same as C, except that C and C fields + #pod will be generated if not provided. This means the metadata structure is + #pod assumed to otherwise follow the latest L. + #pod + #pod =cut + + sub create { + my ($class, $struct, $options) = @_; + my $version = __PACKAGE__->VERSION || 2; + $struct->{generated_by} ||= __PACKAGE__ . " version $version" ; + $struct->{'meta-spec'}{version} ||= int($version); + my $self = eval { $class->_new($struct, $options) }; + croak ($@) if $@; + return $self; + } + + #pod =method load_file + #pod + #pod my $meta = CPAN::Meta->load_file($distmeta_file, \%options); + #pod + #pod Given a pathname to a file containing metadata, this deserializes the file + #pod according to its file suffix and constructs a new C object, just + #pod like C. It will die if the deserialized version fails to validate + #pod against its stated specification version. + #pod + #pod It takes the same options as C but C defaults to + #pod true. + #pod + #pod =cut + + sub load_file { + my ($class, $file, $options) = @_; + $options->{lazy_validation} = 1 unless exists $options->{lazy_validation}; + + croak "load_file() requires a valid, readable filename" + unless -r $file; + + my $self; + eval { + my $struct = Parse::CPAN::Meta->load_file( $file ); + $self = $class->_new($struct, $options); + }; + croak($@) if $@; + return $self; + } + + #pod =method load_yaml_string + #pod + #pod my $meta = CPAN::Meta->load_yaml_string($yaml, \%options); + #pod + #pod This method returns a new CPAN::Meta object using the first document in the + #pod given YAML string. In other respects it is identical to C. + #pod + #pod =cut + + sub load_yaml_string { + my ($class, $yaml, $options) = @_; + $options->{lazy_validation} = 1 unless exists $options->{lazy_validation}; + + my $self; + eval { + my ($struct) = Parse::CPAN::Meta->load_yaml_string( $yaml ); + $self = $class->_new($struct, $options); + }; + croak($@) if $@; + return $self; + } + + #pod =method load_json_string + #pod + #pod my $meta = CPAN::Meta->load_json_string($json, \%options); + #pod + #pod This method returns a new CPAN::Meta object using the structure represented by + #pod the given JSON string. In other respects it is identical to C. + #pod + #pod =cut + + sub load_json_string { + my ($class, $json, $options) = @_; + $options->{lazy_validation} = 1 unless exists $options->{lazy_validation}; + + my $self; + eval { + my $struct = Parse::CPAN::Meta->load_json_string( $json ); + $self = $class->_new($struct, $options); + }; + croak($@) if $@; + return $self; + } + + #pod =method load_string + #pod + #pod my $meta = CPAN::Meta->load_string($string, \%options); + #pod + #pod If you don't know if a string contains YAML or JSON, this method will use + #pod L to guess. In other respects it is identical to + #pod C. + #pod + #pod =cut + + sub load_string { + my ($class, $string, $options) = @_; + $options->{lazy_validation} = 1 unless exists $options->{lazy_validation}; + + my $self; + eval { + my $struct = Parse::CPAN::Meta->load_string( $string ); + $self = $class->_new($struct, $options); + }; + croak($@) if $@; + return $self; + } + + #pod =method save + #pod + #pod $meta->save($distmeta_file, \%options); + #pod + #pod Serializes the object as JSON and writes it to the given file. The only valid + #pod option is C, which defaults to '2'. On Perl 5.8.1 or later, the file + #pod is saved with UTF-8 encoding. + #pod + #pod For C 2 (or higher), the filename should end in '.json'. L + #pod is the default JSON backend. Using another JSON backend requires L 2.5 or + #pod later and you must set the C<$ENV{PERL_JSON_BACKEND}> to a supported alternate + #pod backend like L. + #pod + #pod For C less than 2, the filename should end in '.yml'. + #pod L is used to generate an older metadata structure, which + #pod is serialized to YAML. CPAN::Meta::YAML is the default YAML backend. You may + #pod set the C<$ENV{PERL_YAML_BACKEND}> to a supported alternative backend, though + #pod this is not recommended due to subtle incompatibilities between YAML parsers on + #pod CPAN. + #pod + #pod =cut + + sub save { + my ($self, $file, $options) = @_; + + my $version = $options->{version} || '2'; + my $layer = $] ge '5.008001' ? ':utf8' : ''; + + if ( $version ge '2' ) { + carp "'$file' should end in '.json'" + unless $file =~ m{\.json$}; + } + else { + carp "'$file' should end in '.yml'" + unless $file =~ m{\.yml$}; + } + + my $data = $self->as_string( $options ); + open my $fh, ">$layer", $file + or die "Error opening '$file' for writing: $!\n"; + + print {$fh} $data; + close $fh + or die "Error closing '$file': $!\n"; + + return 1; + } + + #pod =method meta_spec_version + #pod + #pod This method returns the version part of the C entry in the distmeta + #pod structure. It is equivalent to: + #pod + #pod $meta->meta_spec->{version}; + #pod + #pod =cut + + sub meta_spec_version { + my ($self) = @_; + return $self->meta_spec->{version}; + } + + #pod =method effective_prereqs + #pod + #pod my $prereqs = $meta->effective_prereqs; + #pod + #pod my $prereqs = $meta->effective_prereqs( \@feature_identifiers ); + #pod + #pod This method returns a L object describing all the + #pod prereqs for the distribution. If an arrayref of feature identifiers is given, + #pod the prereqs for the identified features are merged together with the + #pod distribution's core prereqs before the CPAN::Meta::Prereqs object is returned. + #pod + #pod =cut + + sub effective_prereqs { + my ($self, $features) = @_; + $features ||= []; + + my $prereq = CPAN::Meta::Prereqs->new($self->prereqs); + + return $prereq unless @$features; + + my @other = map {; $self->feature($_)->prereqs } @$features; + + return $prereq->with_merged_prereqs(\@other); + } + + #pod =method should_index_file + #pod + #pod ... if $meta->should_index_file( $filename ); + #pod + #pod This method returns true if the given file should be indexed. It decides this + #pod by checking the C and C keys in the C property of + #pod the distmeta structure. Note that neither the version format nor + #pod C are considered. + #pod + #pod C<$filename> should be given in unix format. + #pod + #pod =cut + + sub should_index_file { + my ($self, $filename) = @_; + + for my $no_index_file (@{ $self->no_index->{file} || [] }) { + return if $filename eq $no_index_file; + } + + for my $no_index_dir (@{ $self->no_index->{directory} }) { + $no_index_dir =~ s{$}{/} unless $no_index_dir =~ m{/\z}; + return if index($filename, $no_index_dir) == 0; + } + + return 1; + } + + #pod =method should_index_package + #pod + #pod ... if $meta->should_index_package( $package ); + #pod + #pod This method returns true if the given package should be indexed. It decides + #pod this by checking the C and C keys in the C + #pod property of the distmeta structure. Note that neither the version format nor + #pod C are considered. + #pod + #pod =cut + + sub should_index_package { + my ($self, $package) = @_; + + for my $no_index_pkg (@{ $self->no_index->{package} || [] }) { + return if $package eq $no_index_pkg; + } + + for my $no_index_ns (@{ $self->no_index->{namespace} }) { + return if index($package, "${no_index_ns}::") == 0; + } + + return 1; + } + + #pod =method features + #pod + #pod my @feature_objects = $meta->features; + #pod + #pod This method returns a list of L objects, one for each + #pod optional feature described by the distribution's metadata. + #pod + #pod =cut + + sub features { + my ($self) = @_; + + my $opt_f = $self->optional_features; + my @features = map {; CPAN::Meta::Feature->new($_ => $opt_f->{ $_ }) } + keys %$opt_f; + + return @features; + } + + #pod =method feature + #pod + #pod my $feature_object = $meta->feature( $identifier ); + #pod + #pod This method returns a L object for the optional feature + #pod with the given identifier. If no feature with that identifier exists, an + #pod exception will be raised. + #pod + #pod =cut + + sub feature { + my ($self, $ident) = @_; + + croak "no feature named $ident" + unless my $f = $self->optional_features->{ $ident }; + + return CPAN::Meta::Feature->new($ident, $f); + } + + #pod =method as_struct + #pod + #pod my $copy = $meta->as_struct( \%options ); + #pod + #pod This method returns a deep copy of the object's metadata as an unblessed hash + #pod reference. It takes an optional hashref of options. If the hashref contains + #pod a C argument, the copied metadata will be converted to the version + #pod of the specification and returned. For example: + #pod + #pod my $old_spec = $meta->as_struct( {version => "1.4"} ); + #pod + #pod =cut + + sub as_struct { + my ($self, $options) = @_; + my $struct = _dclone($self); + if ( $options->{version} ) { + my $cmc = CPAN::Meta::Converter->new( $struct ); + $struct = $cmc->convert( version => $options->{version} ); + } + return $struct; + } + + #pod =method as_string + #pod + #pod my $string = $meta->as_string( \%options ); + #pod + #pod This method returns a serialized copy of the object's metadata as a character + #pod string. (The strings are B UTF-8 encoded.) It takes an optional hashref + #pod of options. If the hashref contains a C argument, the copied metadata + #pod will be converted to the version of the specification and returned. For + #pod example: + #pod + #pod my $string = $meta->as_string( {version => "1.4"} ); + #pod + #pod For C greater than or equal to 2, the string will be serialized as + #pod JSON. For C less than 2, the string will be serialized as YAML. In + #pod both cases, the same rules are followed as in the C method for choosing + #pod a serialization backend. + #pod + #pod The serialized structure will include a C entry giving + #pod the package and version used to serialize. Any existing key in the given + #pod C<$meta> object will be clobbered. + #pod + #pod =cut + + sub as_string { + my ($self, $options) = @_; + + my $version = $options->{version} || '2'; + + my $struct; + if ( $self->meta_spec_version ne $version ) { + my $cmc = CPAN::Meta::Converter->new( $self->as_struct ); + $struct = $cmc->convert( version => $version ); + } + else { + $struct = $self->as_struct; + } + + my ($data, $backend); + if ( $version ge '2' ) { + $backend = Parse::CPAN::Meta->json_backend(); + local $struct->{x_serialization_backend} = sprintf '%s version %s', + $backend, $backend->VERSION; + $data = $backend->new->pretty->canonical->encode($struct); + } + else { + $backend = Parse::CPAN::Meta->yaml_backend(); + local $struct->{x_serialization_backend} = sprintf '%s version %s', + $backend, $backend->VERSION; + $data = eval { no strict 'refs'; &{"$backend\::Dump"}($struct) }; + if ( $@ ) { + croak $backend->can('errstr') ? $backend->errstr : $@ + } + } + + return $data; + } + + # Used by JSON::PP, etc. for "convert_blessed" + sub TO_JSON { + return { %{ $_[0] } }; + } + + 1; + + # ABSTRACT: the distribution metadata for a CPAN dist + + =pod + + =encoding UTF-8 + + =head1 NAME + + CPAN::Meta - the distribution metadata for a CPAN dist + + =head1 VERSION + + version 2.150005 + + =head1 SYNOPSIS + + use v5.10; + use strict; + use warnings; + use CPAN::Meta; + use Module::Load; + + my $meta = CPAN::Meta->load_file('META.json'); + + printf "testing requirements for %s version %s\n", + $meta->name, + $meta->version; + + my $prereqs = $meta->effective_prereqs; + + for my $phase ( qw/configure runtime build test/ ) { + say "Requirements for $phase:"; + my $reqs = $prereqs->requirements_for($phase, "requires"); + for my $module ( sort $reqs->required_modules ) { + my $status; + if ( eval { load $module unless $module eq 'perl'; 1 } ) { + my $version = $module eq 'perl' ? $] : $module->VERSION; + $status = $reqs->accepts_module($module, $version) + ? "$version ok" : "$version not ok"; + } else { + $status = "missing" + }; + say " $module ($status)"; + } + } + + =head1 DESCRIPTION + + Software distributions released to the CPAN include a F or, for + older distributions, F, which describes the distribution, its + contents, and the requirements for building and installing the distribution. + The data structure stored in the F file is described in + L. + + CPAN::Meta provides a simple class to represent this distribution metadata (or + I), along with some helpful methods for interrogating that data. + + The documentation below is only for the methods of the CPAN::Meta object. For + information on the meaning of individual fields, consult the spec. + + =head1 METHODS + + =head2 new + + my $meta = CPAN::Meta->new($distmeta_struct, \%options); + + Returns a valid CPAN::Meta object or dies if the supplied metadata hash + reference fails to validate. Older-format metadata will be up-converted to + version 2 if they validate against the original stated specification. + + It takes an optional hashref of options. Valid options include: + + =over + + =item * + + lazy_validation -- if true, new will attempt to convert the given metadata + to version 2 before attempting to validate it. This means than any + fixable errors will be handled by CPAN::Meta::Converter before validation. + (Note that this might result in invalid optional data being silently + dropped.) The default is false. + + =back + + =head2 create + + my $meta = CPAN::Meta->create($distmeta_struct, \%options); + + This is same as C, except that C and C fields + will be generated if not provided. This means the metadata structure is + assumed to otherwise follow the latest L. + + =head2 load_file + + my $meta = CPAN::Meta->load_file($distmeta_file, \%options); + + Given a pathname to a file containing metadata, this deserializes the file + according to its file suffix and constructs a new C object, just + like C. It will die if the deserialized version fails to validate + against its stated specification version. + + It takes the same options as C but C defaults to + true. + + =head2 load_yaml_string + + my $meta = CPAN::Meta->load_yaml_string($yaml, \%options); + + This method returns a new CPAN::Meta object using the first document in the + given YAML string. In other respects it is identical to C. + + =head2 load_json_string + + my $meta = CPAN::Meta->load_json_string($json, \%options); + + This method returns a new CPAN::Meta object using the structure represented by + the given JSON string. In other respects it is identical to C. + + =head2 load_string + + my $meta = CPAN::Meta->load_string($string, \%options); + + If you don't know if a string contains YAML or JSON, this method will use + L to guess. In other respects it is identical to + C. + + =head2 save + + $meta->save($distmeta_file, \%options); + + Serializes the object as JSON and writes it to the given file. The only valid + option is C, which defaults to '2'. On Perl 5.8.1 or later, the file + is saved with UTF-8 encoding. + + For C 2 (or higher), the filename should end in '.json'. L + is the default JSON backend. Using another JSON backend requires L 2.5 or + later and you must set the C<$ENV{PERL_JSON_BACKEND}> to a supported alternate + backend like L. + + For C less than 2, the filename should end in '.yml'. + L is used to generate an older metadata structure, which + is serialized to YAML. CPAN::Meta::YAML is the default YAML backend. You may + set the C<$ENV{PERL_YAML_BACKEND}> to a supported alternative backend, though + this is not recommended due to subtle incompatibilities between YAML parsers on + CPAN. + + =head2 meta_spec_version + + This method returns the version part of the C entry in the distmeta + structure. It is equivalent to: + + $meta->meta_spec->{version}; + + =head2 effective_prereqs + + my $prereqs = $meta->effective_prereqs; + + my $prereqs = $meta->effective_prereqs( \@feature_identifiers ); + + This method returns a L object describing all the + prereqs for the distribution. If an arrayref of feature identifiers is given, + the prereqs for the identified features are merged together with the + distribution's core prereqs before the CPAN::Meta::Prereqs object is returned. + + =head2 should_index_file + + ... if $meta->should_index_file( $filename ); + + This method returns true if the given file should be indexed. It decides this + by checking the C and C keys in the C property of + the distmeta structure. Note that neither the version format nor + C are considered. + + C<$filename> should be given in unix format. + + =head2 should_index_package + + ... if $meta->should_index_package( $package ); + + This method returns true if the given package should be indexed. It decides + this by checking the C and C keys in the C + property of the distmeta structure. Note that neither the version format nor + C are considered. + + =head2 features + + my @feature_objects = $meta->features; + + This method returns a list of L objects, one for each + optional feature described by the distribution's metadata. + + =head2 feature + + my $feature_object = $meta->feature( $identifier ); + + This method returns a L object for the optional feature + with the given identifier. If no feature with that identifier exists, an + exception will be raised. + + =head2 as_struct + + my $copy = $meta->as_struct( \%options ); + + This method returns a deep copy of the object's metadata as an unblessed hash + reference. It takes an optional hashref of options. If the hashref contains + a C argument, the copied metadata will be converted to the version + of the specification and returned. For example: + + my $old_spec = $meta->as_struct( {version => "1.4"} ); + + =head2 as_string + + my $string = $meta->as_string( \%options ); + + This method returns a serialized copy of the object's metadata as a character + string. (The strings are B UTF-8 encoded.) It takes an optional hashref + of options. If the hashref contains a C argument, the copied metadata + will be converted to the version of the specification and returned. For + example: + + my $string = $meta->as_string( {version => "1.4"} ); + + For C greater than or equal to 2, the string will be serialized as + JSON. For C less than 2, the string will be serialized as YAML. In + both cases, the same rules are followed as in the C method for choosing + a serialization backend. + + The serialized structure will include a C entry giving + the package and version used to serialize. Any existing key in the given + C<$meta> object will be clobbered. + + =head1 STRING DATA + + The following methods return a single value, which is the value for the + corresponding entry in the distmeta structure. Values should be either undef + or strings. + + =over 4 + + =item * + + abstract + + =item * + + description + + =item * + + dynamic_config + + =item * + + generated_by + + =item * + + name + + =item * + + release_status + + =item * + + version + + =back + + =head1 LIST DATA + + These methods return lists of string values, which might be represented in the + distmeta structure as arrayrefs or scalars: + + =over 4 + + =item * + + authors + + =item * + + keywords + + =item * + + licenses + + =back + + The C and C methods may also be called as C and + C, respectively, to match the field name in the distmeta structure. + + =head1 MAP DATA + + These readers return hashrefs of arbitrary unblessed data structures, each + described more fully in the specification: + + =over 4 + + =item * + + meta_spec + + =item * + + resources + + =item * + + provides + + =item * + + no_index + + =item * + + prereqs + + =item * + + optional_features + + =back + + =head1 CUSTOM DATA + + A list of custom keys are available from the C method and + particular keys may be retrieved with the C method. + + say $meta->custom($_) for $meta->custom_keys; + + If a custom key refers to a data structure, a deep clone is returned. + + =for Pod::Coverage TO_JSON abstract author authors custom custom_keys description dynamic_config + generated_by keywords license licenses meta_spec name no_index + optional_features prereqs provides release_status resources version + + =head1 BUGS + + Please report any bugs or feature using the CPAN Request Tracker. + Bugs can be submitted through the web interface at + L + + When submitting a bug or request, please include a test-file or a patch to an + existing test-file that illustrates the bug or desired feature. + + =head1 SEE ALSO + + =over 4 + + =item * + + L + + =item * + + L + + =back + + =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan + + =head1 SUPPORT + + =head2 Bugs / Feature Requests + + Please report any bugs or feature requests through the issue tracker + at L. + You will be notified automatically of any progress on your issue. + + =head2 Source Code + + This is open source software. The code repository is available for + public review and contribution under the terms of the license. + + L + + git clone https://github.com/Perl-Toolchain-Gang/CPAN-Meta.git + + =head1 AUTHORS + + =over 4 + + =item * + + David Golden + + =item * + + Ricardo Signes + + =back + + =head1 CONTRIBUTORS + + =for stopwords Ansgar Burchardt Avar Arnfjord Bjarmason Christopher J. Madsen Chuck Adams Cory G Watson Damyan Ivanov Eric Wilhelm Graham Knop Gregor Hermann Karen Etheridge Kenichi Ishigaki Ken Williams Lars Dieckow Leon Timmermans majensen Mark Fowler Matt S Trout Michael G. Schwern mohawk2 moznion Niko Tyni Olaf Alders Olivier Mengué Randy Sims Tomohiro Hosaka + + =over 4 + + =item * + + Ansgar Burchardt + + =item * + + Avar Arnfjord Bjarmason + + =item * + + Christopher J. Madsen + + =item * + + Chuck Adams + + =item * + + Cory G Watson + + =item * + + Damyan Ivanov + + =item * + + Eric Wilhelm + + =item * + + Graham Knop + + =item * + + Gregor Hermann + + =item * + + Karen Etheridge + + =item * + + Kenichi Ishigaki + + =item * + + Ken Williams + + =item * + + Lars Dieckow + + =item * + + Leon Timmermans + + =item * + + majensen + + =item * + + Mark Fowler + + =item * + + Matt S Trout + + =item * + + Michael G. Schwern + + =item * + + mohawk2 + + =item * + + moznion + + =item * + + Niko Tyni + + =item * + + Olaf Alders + + =item * + + Olivier Mengué + + =item * + + Randy Sims + + =item * + + Tomohiro Hosaka + + =back + + =head1 COPYRIGHT AND LICENSE + + This software is copyright (c) 2010 by David Golden and Ricardo Signes. + + This is free software; you can redistribute it and/or modify it under + the same terms as the Perl 5 programming language system itself. + + =cut + + __END__ + + + # vim: ts=2 sts=2 sw=2 et : + CPAN_META + + $fatpacked{"CPAN/Meta/Check.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_CHECK'; + package CPAN::Meta::Check; + $CPAN::Meta::Check::VERSION = '0.012'; + use strict; + use warnings; + + use base 'Exporter'; + our @EXPORT = qw//; + our @EXPORT_OK = qw/check_requirements requirements_for verify_dependencies/; + our %EXPORT_TAGS = (all => [ @EXPORT, @EXPORT_OK ] ); + + use CPAN::Meta::Prereqs '2.132830'; + use CPAN::Meta::Requirements 2.121; + use Module::Metadata 1.000023; + + sub _check_dep { + my ($reqs, $module, $dirs) = @_; + + $module eq 'perl' and return ($reqs->accepts_module($module, $]) ? () : sprintf "Your Perl (%s) is not in the range '%s'", $], $reqs->requirements_for_module($module)); + + my $metadata = Module::Metadata->new_from_module($module, inc => $dirs); + return "Module '$module' is not installed" if not defined $metadata; + my $version = eval { $metadata->version }; + return "Missing version info for module '$module'" if $reqs->requirements_for_module($module) and not $version; + return sprintf 'Installed version (%s) of %s is not in range \'%s\'', $version, $module, $reqs->requirements_for_module($module) if not $reqs->accepts_module($module, $version || 0); + return; + } + + sub _check_conflict { + my ($reqs, $module, $dirs) = @_; + my $metadata = Module::Metadata->new_from_module($module, inc => $dirs); + return if not defined $metadata; + my $version = eval { $metadata->version }; + return "Missing version info for module '$module'" if not $version; + return sprintf 'Installed version (%s) of %s is in range \'%s\'', $version, $module, $reqs->requirements_for_module($module) if $reqs->accepts_module($module, $version); + return; + } + + sub requirements_for { + my ($meta, $phases, $type) = @_; + my $prereqs = ref($meta) eq 'CPAN::Meta' ? $meta->effective_prereqs : $meta; + return $prereqs->merged_requirements(ref($phases) ? $phases : [ $phases ], [ $type ]); + } + + sub check_requirements { + my ($reqs, $type, $dirs) = @_; + + return +{ + map { + $_ => $type ne 'conflicts' + ? scalar _check_dep($reqs, $_, $dirs) + : scalar _check_conflict($reqs, $_, $dirs) + } $reqs->required_modules + }; + } + + sub verify_dependencies { + my ($meta, $phases, $type, $dirs) = @_; + my $reqs = requirements_for($meta, $phases, $type); + my $issues = check_requirements($reqs, $type, $dirs); + return grep { defined } values %{ $issues }; + } + + 1; + + #ABSTRACT: Verify requirements in a CPAN::Meta object + + __END__ + + =pod + + =encoding UTF-8 + + =head1 NAME + + CPAN::Meta::Check - Verify requirements in a CPAN::Meta object + + =head1 VERSION + + version 0.012 + + =head1 SYNOPSIS + + warn "$_\n" for verify_dependencies($meta, [qw/runtime build test/], 'requires'); + + =head1 DESCRIPTION + + This module verifies if requirements described in a CPAN::Meta object are present. + + =head1 FUNCTIONS + + =head2 check_requirements($reqs, $type, $incdirs) + + This function checks if all dependencies in C<$reqs> (a L object) are met, taking into account that 'conflicts' dependencies have to be checked in reverse. It returns a hash with the modules as keys and any problems as values; the value for a successfully found module will be undef. Modules are searched for in C<@$incdirs>, defaulting to C<@INC>. + + =head2 verify_dependencies($meta, $phases, $types, $incdirs) + + Check all requirements in C<$meta> for phases C<$phases> and type C<$type>. Modules are searched for in C<@$incdirs>, defaulting to C<@INC>. C<$meta> should be a L or L object. + + =head2 requirements_for($meta, $phases, $types) + + B<< This function is deprecated and may be removed at some point in the future, please use CPAN::Meta::Prereqs->merged_requirements instead. >> + + This function returns a unified L object for all C<$type> requirements for C<$phases>. C<$phases> may be either one (scalar) value or an arrayref of valid values as defined by the L. C<$type> must be a relationship as defined by the same spec. C<$meta> should be a L or L object. + + =head1 SEE ALSO + + =over 4 + + =item * L + + =item * L + + =for comment # vi:noet:sts=2:sw=2:ts=2 + + =back + + =head1 AUTHOR + + Leon Timmermans + + =head1 COPYRIGHT AND LICENSE + + This software is copyright (c) 2012 by Leon Timmermans. + + This is free software; you can redistribute it and/or modify it under + the same terms as the Perl 5 programming language system itself. + + =cut + CPAN_META_CHECK + + $fatpacked{"CPAN/Meta/Converter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_CONVERTER'; + use 5.006; + use strict; + use warnings; + package CPAN::Meta::Converter; + + our $VERSION = '2.150005'; + + #pod =head1 SYNOPSIS + #pod + #pod my $struct = decode_json_file('META.json'); + #pod + #pod my $cmc = CPAN::Meta::Converter->new( $struct ); + #pod + #pod my $new_struct = $cmc->convert( version => "2" ); + #pod + #pod =head1 DESCRIPTION + #pod + #pod This module converts CPAN Meta structures from one form to another. The + #pod primary use is to convert older structures to the most modern version of + #pod the specification, but other transformations may be implemented in the + #pod future as needed. (E.g. stripping all custom fields or stripping all + #pod optional fields.) + #pod + #pod =cut + + use CPAN::Meta::Validator; + use CPAN::Meta::Requirements; + use Parse::CPAN::Meta 1.4400 (); + + # To help ExtUtils::MakeMaker bootstrap CPAN::Meta::Requirements on perls + # before 5.10, we fall back to the EUMM bundled compatibility version module if + # that's the only thing available. This shouldn't ever happen in a normal CPAN + # install of CPAN::Meta::Requirements, as version.pm will be picked up from + # prereqs and be available at runtime. + + BEGIN { + eval "use version ()"; ## no critic + if ( my $err = $@ ) { + eval "use ExtUtils::MakeMaker::version" or die $err; ## no critic + } + } + + # Perl 5.10.0 didn't have "is_qv" in version.pm + *_is_qv = version->can('is_qv') ? sub { $_[0]->is_qv } : sub { exists $_[0]->{qv} }; + + sub _dclone { + my $ref = shift; + + # if an object is in the data structure and doesn't specify how to + # turn itself into JSON, we just stringify the object. That does the + # right thing for typical things that might be there, like version objects, + # Path::Class objects, etc. + no warnings 'once'; + no warnings 'redefine'; + local *UNIVERSAL::TO_JSON = sub { "$_[0]" }; + + my $json = Parse::CPAN::Meta->json_backend()->new + ->utf8 + ->allow_blessed + ->convert_blessed; + $json->decode($json->encode($ref)) + } + + my %known_specs = ( + '2' => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec', + '1.4' => 'http://module-build.sourceforge.net/META-spec-v1.4.html', + '1.3' => 'http://module-build.sourceforge.net/META-spec-v1.3.html', + '1.2' => 'http://module-build.sourceforge.net/META-spec-v1.2.html', + '1.1' => 'http://module-build.sourceforge.net/META-spec-v1.1.html', + '1.0' => 'http://module-build.sourceforge.net/META-spec-v1.0.html' + ); + + my @spec_list = sort { $a <=> $b } keys %known_specs; + my ($LOWEST, $HIGHEST) = @spec_list[0,-1]; + + #--------------------------------------------------------------------------# + # converters + # + # called as $converter->($element, $field_name, $full_meta, $to_version) + # + # defined return value used for field + # undef return value means field is skipped + #--------------------------------------------------------------------------# + + sub _keep { $_[0] } + + sub _keep_or_one { defined($_[0]) ? $_[0] : 1 } + + sub _keep_or_zero { defined($_[0]) ? $_[0] : 0 } + + sub _keep_or_unknown { defined($_[0]) && length($_[0]) ? $_[0] : "unknown" } + + sub _generated_by { + my $gen = shift; + my $sig = __PACKAGE__ . " version " . (__PACKAGE__->VERSION || ""); + + return $sig unless defined $gen and length $gen; + return $gen if $gen =~ /\Q$sig/; + return "$gen, $sig"; + } + + sub _listify { ! defined $_[0] ? undef : ref $_[0] eq 'ARRAY' ? $_[0] : [$_[0]] } + + sub _prefix_custom { + my $key = shift; + $key =~ s/^(?!x_) # Unless it already starts with x_ + (?:x-?)? # Remove leading x- or x (if present) + /x_/ix; # and prepend x_ + return $key; + } + + sub _ucfirst_custom { + my $key = shift; + $key = ucfirst $key unless $key =~ /[A-Z]/; + return $key; + } + + sub _no_prefix_ucfirst_custom { + my $key = shift; + $key =~ s/^x_//; + return _ucfirst_custom($key); + } + + sub _change_meta_spec { + my ($element, undef, undef, $version) = @_; + return { + version => $version, + url => $known_specs{$version}, + }; + } + + my @open_source = ( + 'perl', + 'gpl', + 'apache', + 'artistic', + 'artistic_2', + 'lgpl', + 'bsd', + 'gpl', + 'mit', + 'mozilla', + 'open_source', + ); + + my %is_open_source = map {; $_ => 1 } @open_source; + + my @valid_licenses_1 = ( + @open_source, + 'unrestricted', + 'restrictive', + 'unknown', + ); + + my %license_map_1 = ( + ( map { $_ => $_ } @valid_licenses_1 ), + artistic2 => 'artistic_2', + ); + + sub _license_1 { + my ($element) = @_; + return 'unknown' unless defined $element; + if ( $license_map_1{lc $element} ) { + return $license_map_1{lc $element}; + } + else { + return 'unknown'; + } + } + + my @valid_licenses_2 = qw( + agpl_3 + apache_1_1 + apache_2_0 + artistic_1 + artistic_2 + bsd + freebsd + gfdl_1_2 + gfdl_1_3 + gpl_1 + gpl_2 + gpl_3 + lgpl_2_1 + lgpl_3_0 + mit + mozilla_1_0 + mozilla_1_1 + openssl + perl_5 + qpl_1_0 + ssleay + sun + zlib + open_source + restricted + unrestricted + unknown + ); + + # The "old" values were defined by Module::Build, and were often vague. I have + # made the decisions below based on reading Module::Build::API and how clearly + # it specifies the version of the license. + my %license_map_2 = ( + (map { $_ => $_ } @valid_licenses_2), + apache => 'apache_2_0', # clearly stated as 2.0 + artistic => 'artistic_1', # clearly stated as 1 + artistic2 => 'artistic_2', # clearly stated as 2 + gpl => 'open_source', # we don't know which GPL; punt + lgpl => 'open_source', # we don't know which LGPL; punt + mozilla => 'open_source', # we don't know which MPL; punt + perl => 'perl_5', # clearly Perl 5 + restrictive => 'restricted', + ); + + sub _license_2 { + my ($element) = @_; + return [ 'unknown' ] unless defined $element; + $element = [ $element ] unless ref $element eq 'ARRAY'; + my @new_list; + for my $lic ( @$element ) { + next unless defined $lic; + if ( my $new = $license_map_2{lc $lic} ) { + push @new_list, $new; + } + } + return @new_list ? \@new_list : [ 'unknown' ]; + } + + my %license_downgrade_map = qw( + agpl_3 open_source + apache_1_1 apache + apache_2_0 apache + artistic_1 artistic + artistic_2 artistic_2 + bsd bsd + freebsd open_source + gfdl_1_2 open_source + gfdl_1_3 open_source + gpl_1 gpl + gpl_2 gpl + gpl_3 gpl + lgpl_2_1 lgpl + lgpl_3_0 lgpl + mit mit + mozilla_1_0 mozilla + mozilla_1_1 mozilla + openssl open_source + perl_5 perl + qpl_1_0 open_source + ssleay open_source + sun open_source + zlib open_source + open_source open_source + restricted restrictive + unrestricted unrestricted + unknown unknown + ); + + sub _downgrade_license { + my ($element) = @_; + if ( ! defined $element ) { + return "unknown"; + } + elsif( ref $element eq 'ARRAY' ) { + if ( @$element > 1) { + if (grep { !$is_open_source{ $license_downgrade_map{lc $_} || 'unknown' } } @$element) { + return 'unknown'; + } + else { + return 'open_source'; + } + } + elsif ( @$element == 1 ) { + return $license_downgrade_map{lc $element->[0]} || "unknown"; + } + } + elsif ( ! ref $element ) { + return $license_downgrade_map{lc $element} || "unknown"; + } + return "unknown"; + } + + my $no_index_spec_1_2 = { + 'file' => \&_listify, + 'dir' => \&_listify, + 'package' => \&_listify, + 'namespace' => \&_listify, + }; + + my $no_index_spec_1_3 = { + 'file' => \&_listify, + 'directory' => \&_listify, + 'package' => \&_listify, + 'namespace' => \&_listify, + }; + + my $no_index_spec_2 = { + 'file' => \&_listify, + 'directory' => \&_listify, + 'package' => \&_listify, + 'namespace' => \&_listify, + ':custom' => \&_prefix_custom, + }; + + sub _no_index_1_2 { + my (undef, undef, $meta) = @_; + my $no_index = $meta->{no_index} || $meta->{private}; + return unless $no_index; + + # cleanup wrong format + if ( ! ref $no_index ) { + my $item = $no_index; + $no_index = { dir => [ $item ], file => [ $item ] }; + } + elsif ( ref $no_index eq 'ARRAY' ) { + my $list = $no_index; + $no_index = { dir => [ @$list ], file => [ @$list ] }; + } + + # common mistake: files -> file + if ( exists $no_index->{files} ) { + $no_index->{file} = delete $no_index->{files}; + } + # common mistake: modules -> module + if ( exists $no_index->{modules} ) { + $no_index->{module} = delete $no_index->{modules}; + } + return _convert($no_index, $no_index_spec_1_2); + } + + sub _no_index_directory { + my ($element, $key, $meta, $version) = @_; + return unless $element; + + # cleanup wrong format + if ( ! ref $element ) { + my $item = $element; + $element = { directory => [ $item ], file => [ $item ] }; + } + elsif ( ref $element eq 'ARRAY' ) { + my $list = $element; + $element = { directory => [ @$list ], file => [ @$list ] }; + } + + if ( exists $element->{dir} ) { + $element->{directory} = delete $element->{dir}; + } + # common mistake: files -> file + if ( exists $element->{files} ) { + $element->{file} = delete $element->{files}; + } + # common mistake: modules -> module + if ( exists $element->{modules} ) { + $element->{module} = delete $element->{modules}; + } + my $spec = $version == 2 ? $no_index_spec_2 : $no_index_spec_1_3; + return _convert($element, $spec); + } + + sub _is_module_name { + my $mod = shift; + return unless defined $mod && length $mod; + return $mod =~ m{^[A-Za-z][A-Za-z0-9_]*(?:::[A-Za-z0-9_]+)*$}; + } + + sub _clean_version { + my ($element) = @_; + return 0 if ! defined $element; + + $element =~ s{^\s*}{}; + $element =~ s{\s*$}{}; + $element =~ s{^\.}{0.}; + + return 0 if ! length $element; + return 0 if ( $element eq 'undef' || $element eq '' ); + + my $v = eval { version->new($element) }; + # XXX check defined $v and not just $v because version objects leak memory + # in boolean context -- dagolden, 2012-02-03 + if ( defined $v ) { + return _is_qv($v) ? $v->normal : $element; + } + else { + return 0; + } + } + + sub _bad_version_hook { + my ($v) = @_; + $v =~ s{^\s*}{}; + $v =~ s{\s*$}{}; + $v =~ s{[a-z]+$}{}; # strip trailing alphabetics + my $vobj = eval { version->new($v) }; + return defined($vobj) ? $vobj : version->new(0); # or give up + } + + sub _version_map { + my ($element) = @_; + return unless defined $element; + if ( ref $element eq 'HASH' ) { + # XXX turn this into CPAN::Meta::Requirements with bad version hook + # and then turn it back into a hash + my $new_map = CPAN::Meta::Requirements->new( + { bad_version_hook => \&_bad_version_hook } # punt + ); + while ( my ($k,$v) = each %$element ) { + next unless _is_module_name($k); + if ( !defined($v) || !length($v) || $v eq 'undef' || $v eq '' ) { + $v = 0; + } + # some weird, old META have bad yml with module => module + # so check if value is like a module name and not like a version + if ( _is_module_name($v) && ! version::is_lax($v) ) { + $new_map->add_minimum($k => 0); + $new_map->add_minimum($v => 0); + } + $new_map->add_string_requirement($k => $v); + } + return $new_map->as_string_hash; + } + elsif ( ref $element eq 'ARRAY' ) { + my $hashref = { map { $_ => 0 } @$element }; + return _version_map($hashref); # cleanup any weird stuff + } + elsif ( ref $element eq '' && length $element ) { + return { $element => 0 } + } + return; + } + + sub _prereqs_from_1 { + my (undef, undef, $meta) = @_; + my $prereqs = {}; + for my $phase ( qw/build configure/ ) { + my $key = "${phase}_requires"; + $prereqs->{$phase}{requires} = _version_map($meta->{$key}) + if $meta->{$key}; + } + for my $rel ( qw/requires recommends conflicts/ ) { + $prereqs->{runtime}{$rel} = _version_map($meta->{$rel}) + if $meta->{$rel}; + } + return $prereqs; + } + + my $prereqs_spec = { + configure => \&_prereqs_rel, + build => \&_prereqs_rel, + test => \&_prereqs_rel, + runtime => \&_prereqs_rel, + develop => \&_prereqs_rel, + ':custom' => \&_prefix_custom, + }; + + my $relation_spec = { + requires => \&_version_map, + recommends => \&_version_map, + suggests => \&_version_map, + conflicts => \&_version_map, + ':custom' => \&_prefix_custom, + }; + + sub _cleanup_prereqs { + my ($prereqs, $key, $meta, $to_version) = @_; + return unless $prereqs && ref $prereqs eq 'HASH'; + return _convert( $prereqs, $prereqs_spec, $to_version ); + } + + sub _prereqs_rel { + my ($relation, $key, $meta, $to_version) = @_; + return unless $relation && ref $relation eq 'HASH'; + return _convert( $relation, $relation_spec, $to_version ); + } + + + BEGIN { + my @old_prereqs = qw( + requires + configure_requires + recommends + conflicts + ); + + for ( @old_prereqs ) { + my $sub = "_get_$_"; + my ($phase,$type) = split qr/_/, $_; + if ( ! defined $type ) { + $type = $phase; + $phase = 'runtime'; + } + no strict 'refs'; + *{$sub} = sub { _extract_prereqs($_[2]->{prereqs},$phase,$type) }; + } + } + + sub _get_build_requires { + my ($data, $key, $meta) = @_; + + my $test_h = _extract_prereqs($_[2]->{prereqs}, qw(test requires)) || {}; + my $build_h = _extract_prereqs($_[2]->{prereqs}, qw(build requires)) || {}; + + my $test_req = CPAN::Meta::Requirements->from_string_hash($test_h); + my $build_req = CPAN::Meta::Requirements->from_string_hash($build_h); + + $test_req->add_requirements($build_req)->as_string_hash; + } + + sub _extract_prereqs { + my ($prereqs, $phase, $type) = @_; + return unless ref $prereqs eq 'HASH'; + return scalar _version_map($prereqs->{$phase}{$type}); + } + + sub _downgrade_optional_features { + my (undef, undef, $meta) = @_; + return unless exists $meta->{optional_features}; + my $origin = $meta->{optional_features}; + my $features = {}; + for my $name ( keys %$origin ) { + $features->{$name} = { + description => $origin->{$name}{description}, + requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','requires'), + configure_requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','configure_requires'), + build_requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','build_requires'), + recommends => _extract_prereqs($origin->{$name}{prereqs},'runtime','recommends'), + conflicts => _extract_prereqs($origin->{$name}{prereqs},'runtime','conflicts'), + }; + for my $k (keys %{$features->{$name}} ) { + delete $features->{$name}{$k} unless defined $features->{$name}{$k}; + } + } + return $features; + } + + sub _upgrade_optional_features { + my (undef, undef, $meta) = @_; + return unless exists $meta->{optional_features}; + my $origin = $meta->{optional_features}; + my $features = {}; + for my $name ( keys %$origin ) { + $features->{$name} = { + description => $origin->{$name}{description}, + prereqs => _prereqs_from_1(undef, undef, $origin->{$name}), + }; + delete $features->{$name}{prereqs}{configure}; + } + return $features; + } + + my $optional_features_2_spec = { + description => \&_keep, + prereqs => \&_cleanup_prereqs, + ':custom' => \&_prefix_custom, + }; + + sub _feature_2 { + my ($element, $key, $meta, $to_version) = @_; + return unless $element && ref $element eq 'HASH'; + _convert( $element, $optional_features_2_spec, $to_version ); + } + + sub _cleanup_optional_features_2 { + my ($element, $key, $meta, $to_version) = @_; + return unless $element && ref $element eq 'HASH'; + my $new_data = {}; + for my $k ( keys %$element ) { + $new_data->{$k} = _feature_2( $element->{$k}, $k, $meta, $to_version ); + } + return unless keys %$new_data; + return $new_data; + } + + sub _optional_features_1_4 { + my ($element) = @_; + return unless $element; + $element = _optional_features_as_map($element); + for my $name ( keys %$element ) { + for my $drop ( qw/requires_packages requires_os excluded_os/ ) { + delete $element->{$name}{$drop}; + } + } + return $element; + } + + sub _optional_features_as_map { + my ($element) = @_; + return unless $element; + if ( ref $element eq 'ARRAY' ) { + my %map; + for my $feature ( @$element ) { + my (@parts) = %$feature; + $map{$parts[0]} = $parts[1]; + } + $element = \%map; + } + return $element; + } + + sub _is_urlish { defined $_[0] && $_[0] =~ m{\A[-+.a-z0-9]+:.+}i } + + sub _url_or_drop { + my ($element) = @_; + return $element if _is_urlish($element); + return; + } + + sub _url_list { + my ($element) = @_; + return unless $element; + $element = _listify( $element ); + $element = [ grep { _is_urlish($_) } @$element ]; + return unless @$element; + return $element; + } + + sub _author_list { + my ($element) = @_; + return [ 'unknown' ] unless $element; + $element = _listify( $element ); + $element = [ map { defined $_ && length $_ ? $_ : 'unknown' } @$element ]; + return [ 'unknown' ] unless @$element; + return $element; + } + + my $resource2_upgrade = { + license => sub { return _is_urlish($_[0]) ? _listify( $_[0] ) : undef }, + homepage => \&_url_or_drop, + bugtracker => sub { + my ($item) = @_; + return unless $item; + if ( $item =~ m{^mailto:(.*)$} ) { return { mailto => $1 } } + elsif( _is_urlish($item) ) { return { web => $item } } + else { return } + }, + repository => sub { return _is_urlish($_[0]) ? { url => $_[0] } : undef }, + ':custom' => \&_prefix_custom, + }; + + sub _upgrade_resources_2 { + my (undef, undef, $meta, $version) = @_; + return unless exists $meta->{resources}; + return _convert($meta->{resources}, $resource2_upgrade); + } + + my $bugtracker2_spec = { + web => \&_url_or_drop, + mailto => \&_keep, + ':custom' => \&_prefix_custom, + }; + + sub _repo_type { + my ($element, $key, $meta, $to_version) = @_; + return $element if defined $element; + return unless exists $meta->{url}; + my $repo_url = $meta->{url}; + for my $type ( qw/git svn/ ) { + return $type if $repo_url =~ m{\A$type}; + } + return; + } + + my $repository2_spec = { + web => \&_url_or_drop, + url => \&_url_or_drop, + type => \&_repo_type, + ':custom' => \&_prefix_custom, + }; + + my $resources2_cleanup = { + license => \&_url_list, + homepage => \&_url_or_drop, + bugtracker => sub { ref $_[0] ? _convert( $_[0], $bugtracker2_spec ) : undef }, + repository => sub { my $data = shift; ref $data ? _convert( $data, $repository2_spec ) : undef }, + ':custom' => \&_prefix_custom, + }; + + sub _cleanup_resources_2 { + my ($resources, $key, $meta, $to_version) = @_; + return unless $resources && ref $resources eq 'HASH'; + return _convert($resources, $resources2_cleanup, $to_version); + } + + my $resource1_spec = { + license => \&_url_or_drop, + homepage => \&_url_or_drop, + bugtracker => \&_url_or_drop, + repository => \&_url_or_drop, + ':custom' => \&_keep, + }; + + sub _resources_1_3 { + my (undef, undef, $meta, $version) = @_; + return unless exists $meta->{resources}; + return _convert($meta->{resources}, $resource1_spec); + } + + *_resources_1_4 = *_resources_1_3; + + sub _resources_1_2 { + my (undef, undef, $meta) = @_; + my $resources = $meta->{resources} || {}; + if ( $meta->{license_url} && ! $resources->{license} ) { + $resources->{license} = $meta->{license_url} + if _is_urlish($meta->{license_url}); + } + return unless keys %$resources; + return _convert($resources, $resource1_spec); + } + + my $resource_downgrade_spec = { + license => sub { return ref $_[0] ? $_[0]->[0] : $_[0] }, + homepage => \&_url_or_drop, + bugtracker => sub { return $_[0]->{web} }, + repository => sub { return $_[0]->{url} || $_[0]->{web} }, + ':custom' => \&_no_prefix_ucfirst_custom, + }; + + sub _downgrade_resources { + my (undef, undef, $meta, $version) = @_; + return unless exists $meta->{resources}; + return _convert($meta->{resources}, $resource_downgrade_spec); + } + + sub _release_status { + my ($element, undef, $meta) = @_; + return $element if $element && $element =~ m{\A(?:stable|testing|unstable)\z}; + return _release_status_from_version(undef, undef, $meta); + } + + sub _release_status_from_version { + my (undef, undef, $meta) = @_; + my $version = $meta->{version} || ''; + return ( $version =~ /_/ ) ? 'testing' : 'stable'; + } + + my $provides_spec = { + file => \&_keep, + version => \&_keep, + }; + + my $provides_spec_2 = { + file => \&_keep, + version => \&_keep, + ':custom' => \&_prefix_custom, + }; + + sub _provides { + my ($element, $key, $meta, $to_version) = @_; + return unless defined $element && ref $element eq 'HASH'; + my $spec = $to_version == 2 ? $provides_spec_2 : $provides_spec; + my $new_data = {}; + for my $k ( keys %$element ) { + $new_data->{$k} = _convert($element->{$k}, $spec, $to_version); + $new_data->{$k}{version} = _clean_version($element->{$k}{version}) + if exists $element->{$k}{version}; + } + return $new_data; + } + + sub _convert { + my ($data, $spec, $to_version, $is_fragment) = @_; + + my $new_data = {}; + for my $key ( keys %$spec ) { + next if $key eq ':custom' || $key eq ':drop'; + next unless my $fcn = $spec->{$key}; + if ( $is_fragment && $key eq 'generated_by' ) { + $fcn = \&_keep; + } + die "spec for '$key' is not a coderef" + unless ref $fcn && ref $fcn eq 'CODE'; + my $new_value = $fcn->($data->{$key}, $key, $data, $to_version); + $new_data->{$key} = $new_value if defined $new_value; + } + + my $drop_list = $spec->{':drop'}; + my $customizer = $spec->{':custom'} || \&_keep; + + for my $key ( keys %$data ) { + next if $drop_list && grep { $key eq $_ } @$drop_list; + next if exists $spec->{$key}; # we handled it + $new_data->{ $customizer->($key) } = $data->{$key}; + } + + return $new_data; + } + + #--------------------------------------------------------------------------# + # define converters for each conversion + #--------------------------------------------------------------------------# + + # each converts from prior version + # special ":custom" field is used for keys not recognized in spec + my %up_convert = ( + '2-from-1.4' => { + # PRIOR MANDATORY + 'abstract' => \&_keep_or_unknown, + 'author' => \&_author_list, + 'generated_by' => \&_generated_by, + 'license' => \&_license_2, + 'meta-spec' => \&_change_meta_spec, + 'name' => \&_keep, + 'version' => \&_keep, + # CHANGED TO MANDATORY + 'dynamic_config' => \&_keep_or_one, + # ADDED MANDATORY + 'release_status' => \&_release_status, + # PRIOR OPTIONAL + 'keywords' => \&_keep, + 'no_index' => \&_no_index_directory, + 'optional_features' => \&_upgrade_optional_features, + 'provides' => \&_provides, + 'resources' => \&_upgrade_resources_2, + # ADDED OPTIONAL + 'description' => \&_keep, + 'prereqs' => \&_prereqs_from_1, + + # drop these deprecated fields, but only after we convert + ':drop' => [ qw( + build_requires + configure_requires + conflicts + distribution_type + license_url + private + recommends + requires + ) ], + + # other random keys need x_ prefixing + ':custom' => \&_prefix_custom, + }, + '1.4-from-1.3' => { + # PRIOR MANDATORY + 'abstract' => \&_keep_or_unknown, + 'author' => \&_author_list, + 'generated_by' => \&_generated_by, + 'license' => \&_license_1, + 'meta-spec' => \&_change_meta_spec, + 'name' => \&_keep, + 'version' => \&_keep, + # PRIOR OPTIONAL + 'build_requires' => \&_version_map, + 'conflicts' => \&_version_map, + 'distribution_type' => \&_keep, + 'dynamic_config' => \&_keep_or_one, + 'keywords' => \&_keep, + 'no_index' => \&_no_index_directory, + 'optional_features' => \&_optional_features_1_4, + 'provides' => \&_provides, + 'recommends' => \&_version_map, + 'requires' => \&_version_map, + 'resources' => \&_resources_1_4, + # ADDED OPTIONAL + 'configure_requires' => \&_keep, + + # drop these deprecated fields, but only after we convert + ':drop' => [ qw( + license_url + private + )], + + # other random keys are OK if already valid + ':custom' => \&_keep + }, + '1.3-from-1.2' => { + # PRIOR MANDATORY + 'abstract' => \&_keep_or_unknown, + 'author' => \&_author_list, + 'generated_by' => \&_generated_by, + 'license' => \&_license_1, + 'meta-spec' => \&_change_meta_spec, + 'name' => \&_keep, + 'version' => \&_keep, + # PRIOR OPTIONAL + 'build_requires' => \&_version_map, + 'conflicts' => \&_version_map, + 'distribution_type' => \&_keep, + 'dynamic_config' => \&_keep_or_one, + 'keywords' => \&_keep, + 'no_index' => \&_no_index_directory, + 'optional_features' => \&_optional_features_as_map, + 'provides' => \&_provides, + 'recommends' => \&_version_map, + 'requires' => \&_version_map, + 'resources' => \&_resources_1_3, + + # drop these deprecated fields, but only after we convert + ':drop' => [ qw( + license_url + private + )], + + # other random keys are OK if already valid + ':custom' => \&_keep + }, + '1.2-from-1.1' => { + # PRIOR MANDATORY + 'version' => \&_keep, + # CHANGED TO MANDATORY + 'license' => \&_license_1, + 'name' => \&_keep, + 'generated_by' => \&_generated_by, + # ADDED MANDATORY + 'abstract' => \&_keep_or_unknown, + 'author' => \&_author_list, + 'meta-spec' => \&_change_meta_spec, + # PRIOR OPTIONAL + 'build_requires' => \&_version_map, + 'conflicts' => \&_version_map, + 'distribution_type' => \&_keep, + 'dynamic_config' => \&_keep_or_one, + 'recommends' => \&_version_map, + 'requires' => \&_version_map, + # ADDED OPTIONAL + 'keywords' => \&_keep, + 'no_index' => \&_no_index_1_2, + 'optional_features' => \&_optional_features_as_map, + 'provides' => \&_provides, + 'resources' => \&_resources_1_2, + + # drop these deprecated fields, but only after we convert + ':drop' => [ qw( + license_url + private + )], + + # other random keys are OK if already valid + ':custom' => \&_keep + }, + '1.1-from-1.0' => { + # CHANGED TO MANDATORY + 'version' => \&_keep, + # IMPLIED MANDATORY + 'name' => \&_keep, + # PRIOR OPTIONAL + 'build_requires' => \&_version_map, + 'conflicts' => \&_version_map, + 'distribution_type' => \&_keep, + 'dynamic_config' => \&_keep_or_one, + 'generated_by' => \&_generated_by, + 'license' => \&_license_1, + 'recommends' => \&_version_map, + 'requires' => \&_version_map, + # ADDED OPTIONAL + 'license_url' => \&_url_or_drop, + 'private' => \&_keep, + + # other random keys are OK if already valid + ':custom' => \&_keep + }, + ); + + my %down_convert = ( + '1.4-from-2' => { + # MANDATORY + 'abstract' => \&_keep_or_unknown, + 'author' => \&_author_list, + 'generated_by' => \&_generated_by, + 'license' => \&_downgrade_license, + 'meta-spec' => \&_change_meta_spec, + 'name' => \&_keep, + 'version' => \&_keep, + # OPTIONAL + 'build_requires' => \&_get_build_requires, + 'configure_requires' => \&_get_configure_requires, + 'conflicts' => \&_get_conflicts, + 'distribution_type' => \&_keep, + 'dynamic_config' => \&_keep_or_one, + 'keywords' => \&_keep, + 'no_index' => \&_no_index_directory, + 'optional_features' => \&_downgrade_optional_features, + 'provides' => \&_provides, + 'recommends' => \&_get_recommends, + 'requires' => \&_get_requires, + 'resources' => \&_downgrade_resources, + + # drop these unsupported fields (after conversion) + ':drop' => [ qw( + description + prereqs + release_status + )], + + # custom keys will be left unchanged + ':custom' => \&_keep + }, + '1.3-from-1.4' => { + # MANDATORY + 'abstract' => \&_keep_or_unknown, + 'author' => \&_author_list, + 'generated_by' => \&_generated_by, + 'license' => \&_license_1, + 'meta-spec' => \&_change_meta_spec, + 'name' => \&_keep, + 'version' => \&_keep, + # OPTIONAL + 'build_requires' => \&_version_map, + 'conflicts' => \&_version_map, + 'distribution_type' => \&_keep, + 'dynamic_config' => \&_keep_or_one, + 'keywords' => \&_keep, + 'no_index' => \&_no_index_directory, + 'optional_features' => \&_optional_features_as_map, + 'provides' => \&_provides, + 'recommends' => \&_version_map, + 'requires' => \&_version_map, + 'resources' => \&_resources_1_3, + + # drop these unsupported fields, but only after we convert + ':drop' => [ qw( + configure_requires + )], + + # other random keys are OK if already valid + ':custom' => \&_keep, + }, + '1.2-from-1.3' => { + # MANDATORY + 'abstract' => \&_keep_or_unknown, + 'author' => \&_author_list, + 'generated_by' => \&_generated_by, + 'license' => \&_license_1, + 'meta-spec' => \&_change_meta_spec, + 'name' => \&_keep, + 'version' => \&_keep, + # OPTIONAL + 'build_requires' => \&_version_map, + 'conflicts' => \&_version_map, + 'distribution_type' => \&_keep, + 'dynamic_config' => \&_keep_or_one, + 'keywords' => \&_keep, + 'no_index' => \&_no_index_1_2, + 'optional_features' => \&_optional_features_as_map, + 'provides' => \&_provides, + 'recommends' => \&_version_map, + 'requires' => \&_version_map, + 'resources' => \&_resources_1_3, + + # other random keys are OK if already valid + ':custom' => \&_keep, + }, + '1.1-from-1.2' => { + # MANDATORY + 'version' => \&_keep, + # IMPLIED MANDATORY + 'name' => \&_keep, + 'meta-spec' => \&_change_meta_spec, + # OPTIONAL + 'build_requires' => \&_version_map, + 'conflicts' => \&_version_map, + 'distribution_type' => \&_keep, + 'dynamic_config' => \&_keep_or_one, + 'generated_by' => \&_generated_by, + 'license' => \&_license_1, + 'private' => \&_keep, + 'recommends' => \&_version_map, + 'requires' => \&_version_map, + + # drop unsupported fields + ':drop' => [ qw( + abstract + author + provides + no_index + keywords + resources + )], + + # other random keys are OK if already valid + ':custom' => \&_keep, + }, + '1.0-from-1.1' => { + # IMPLIED MANDATORY + 'name' => \&_keep, + 'meta-spec' => \&_change_meta_spec, + 'version' => \&_keep, + # PRIOR OPTIONAL + 'build_requires' => \&_version_map, + 'conflicts' => \&_version_map, + 'distribution_type' => \&_keep, + 'dynamic_config' => \&_keep_or_one, + 'generated_by' => \&_generated_by, + 'license' => \&_license_1, + 'recommends' => \&_version_map, + 'requires' => \&_version_map, + + # other random keys are OK if already valid + ':custom' => \&_keep, + }, + ); + + my %cleanup = ( + '2' => { + # PRIOR MANDATORY + 'abstract' => \&_keep_or_unknown, + 'author' => \&_author_list, + 'generated_by' => \&_generated_by, + 'license' => \&_license_2, + 'meta-spec' => \&_change_meta_spec, + 'name' => \&_keep, + 'version' => \&_keep, + # CHANGED TO MANDATORY + 'dynamic_config' => \&_keep_or_one, + # ADDED MANDATORY + 'release_status' => \&_release_status, + # PRIOR OPTIONAL + 'keywords' => \&_keep, + 'no_index' => \&_no_index_directory, + 'optional_features' => \&_cleanup_optional_features_2, + 'provides' => \&_provides, + 'resources' => \&_cleanup_resources_2, + # ADDED OPTIONAL + 'description' => \&_keep, + 'prereqs' => \&_cleanup_prereqs, + + # drop these deprecated fields, but only after we convert + ':drop' => [ qw( + build_requires + configure_requires + conflicts + distribution_type + license_url + private + recommends + requires + ) ], + + # other random keys need x_ prefixing + ':custom' => \&_prefix_custom, + }, + '1.4' => { + # PRIOR MANDATORY + 'abstract' => \&_keep_or_unknown, + 'author' => \&_author_list, + 'generated_by' => \&_generated_by, + 'license' => \&_license_1, + 'meta-spec' => \&_change_meta_spec, + 'name' => \&_keep, + 'version' => \&_keep, + # PRIOR OPTIONAL + 'build_requires' => \&_version_map, + 'conflicts' => \&_version_map, + 'distribution_type' => \&_keep, + 'dynamic_config' => \&_keep_or_one, + 'keywords' => \&_keep, + 'no_index' => \&_no_index_directory, + 'optional_features' => \&_optional_features_1_4, + 'provides' => \&_provides, + 'recommends' => \&_version_map, + 'requires' => \&_version_map, + 'resources' => \&_resources_1_4, + # ADDED OPTIONAL + 'configure_requires' => \&_keep, + + # other random keys are OK if already valid + ':custom' => \&_keep + }, + '1.3' => { + # PRIOR MANDATORY + 'abstract' => \&_keep_or_unknown, + 'author' => \&_author_list, + 'generated_by' => \&_generated_by, + 'license' => \&_license_1, + 'meta-spec' => \&_change_meta_spec, + 'name' => \&_keep, + 'version' => \&_keep, + # PRIOR OPTIONAL + 'build_requires' => \&_version_map, + 'conflicts' => \&_version_map, + 'distribution_type' => \&_keep, + 'dynamic_config' => \&_keep_or_one, + 'keywords' => \&_keep, + 'no_index' => \&_no_index_directory, + 'optional_features' => \&_optional_features_as_map, + 'provides' => \&_provides, + 'recommends' => \&_version_map, + 'requires' => \&_version_map, + 'resources' => \&_resources_1_3, + + # other random keys are OK if already valid + ':custom' => \&_keep + }, + '1.2' => { + # PRIOR MANDATORY + 'version' => \&_keep, + # CHANGED TO MANDATORY + 'license' => \&_license_1, + 'name' => \&_keep, + 'generated_by' => \&_generated_by, + # ADDED MANDATORY + 'abstract' => \&_keep_or_unknown, + 'author' => \&_author_list, + 'meta-spec' => \&_change_meta_spec, + # PRIOR OPTIONAL + 'build_requires' => \&_version_map, + 'conflicts' => \&_version_map, + 'distribution_type' => \&_keep, + 'dynamic_config' => \&_keep_or_one, + 'recommends' => \&_version_map, + 'requires' => \&_version_map, + # ADDED OPTIONAL + 'keywords' => \&_keep, + 'no_index' => \&_no_index_1_2, + 'optional_features' => \&_optional_features_as_map, + 'provides' => \&_provides, + 'resources' => \&_resources_1_2, + + # other random keys are OK if already valid + ':custom' => \&_keep + }, + '1.1' => { + # CHANGED TO MANDATORY + 'version' => \&_keep, + # IMPLIED MANDATORY + 'name' => \&_keep, + 'meta-spec' => \&_change_meta_spec, + # PRIOR OPTIONAL + 'build_requires' => \&_version_map, + 'conflicts' => \&_version_map, + 'distribution_type' => \&_keep, + 'dynamic_config' => \&_keep_or_one, + 'generated_by' => \&_generated_by, + 'license' => \&_license_1, + 'recommends' => \&_version_map, + 'requires' => \&_version_map, + # ADDED OPTIONAL + 'license_url' => \&_url_or_drop, + 'private' => \&_keep, + + # other random keys are OK if already valid + ':custom' => \&_keep + }, + '1.0' => { + # IMPLIED MANDATORY + 'name' => \&_keep, + 'meta-spec' => \&_change_meta_spec, + 'version' => \&_keep, + # IMPLIED OPTIONAL + 'build_requires' => \&_version_map, + 'conflicts' => \&_version_map, + 'distribution_type' => \&_keep, + 'dynamic_config' => \&_keep_or_one, + 'generated_by' => \&_generated_by, + 'license' => \&_license_1, + 'recommends' => \&_version_map, + 'requires' => \&_version_map, + + # other random keys are OK if already valid + ':custom' => \&_keep, + }, + ); + + # for a given field in a spec version, what fields will it feed + # into in the *latest* spec (i.e. v2); meta-spec omitted because + # we always expect a meta-spec to be generated + my %fragments_generate = ( + '2' => { + 'abstract' => 'abstract', + 'author' => 'author', + 'generated_by' => 'generated_by', + 'license' => 'license', + 'name' => 'name', + 'version' => 'version', + 'dynamic_config' => 'dynamic_config', + 'release_status' => 'release_status', + 'keywords' => 'keywords', + 'no_index' => 'no_index', + 'optional_features' => 'optional_features', + 'provides' => 'provides', + 'resources' => 'resources', + 'description' => 'description', + 'prereqs' => 'prereqs', + }, + '1.4' => { + 'abstract' => 'abstract', + 'author' => 'author', + 'generated_by' => 'generated_by', + 'license' => 'license', + 'name' => 'name', + 'version' => 'version', + 'build_requires' => 'prereqs', + 'conflicts' => 'prereqs', + 'distribution_type' => 'distribution_type', + 'dynamic_config' => 'dynamic_config', + 'keywords' => 'keywords', + 'no_index' => 'no_index', + 'optional_features' => 'optional_features', + 'provides' => 'provides', + 'recommends' => 'prereqs', + 'requires' => 'prereqs', + 'resources' => 'resources', + 'configure_requires' => 'prereqs', + }, + ); + # this is not quite true but will work well enough + # as 1.4 is a superset of earlier ones + $fragments_generate{$_} = $fragments_generate{'1.4'} for qw/1.3 1.2 1.1 1.0/; + + #--------------------------------------------------------------------------# + # Code + #--------------------------------------------------------------------------# + + #pod =method new + #pod + #pod my $cmc = CPAN::Meta::Converter->new( $struct ); + #pod + #pod The constructor should be passed a valid metadata structure but invalid + #pod structures are accepted. If no meta-spec version is provided, version 1.0 will + #pod be assumed. + #pod + #pod Optionally, you can provide a C argument after C<$struct>: + #pod + #pod my $cmc = CPAN::Meta::Converter->new( $struct, default_version => "1.4" ); + #pod + #pod This is only needed when converting a metadata fragment that does not include a + #pod C field. + #pod + #pod =cut + + sub new { + my ($class,$data,%args) = @_; + + # create an attributes hash + my $self = { + 'data' => $data, + 'spec' => _extract_spec_version($data, $args{default_version}), + }; + + # create the object + return bless $self, $class; + } + + sub _extract_spec_version { + my ($data, $default) = @_; + my $spec = $data->{'meta-spec'}; + + # is meta-spec there and valid? + return( $default || "1.0" ) unless defined $spec && ref $spec eq 'HASH'; # before meta-spec? + + # does the version key look like a valid version? + my $v = $spec->{version}; + if ( defined $v && $v =~ /^\d+(?:\.\d+)?$/ ) { + return $v if defined $v && grep { $v eq $_ } keys %known_specs; # known spec + return $v+0 if defined $v && grep { $v == $_ } keys %known_specs; # 2.0 => 2 + } + + # otherwise, use heuristics: look for 1.x vs 2.0 fields + return "2" if exists $data->{prereqs}; + return "1.4" if exists $data->{configure_requires}; + return( $default || "1.2" ); # when meta-spec was first defined + } + + #pod =method convert + #pod + #pod my $new_struct = $cmc->convert( version => "2" ); + #pod + #pod Returns a new hash reference with the metadata converted to a different form. + #pod C will die if any conversion/standardization still results in an + #pod invalid structure. + #pod + #pod Valid parameters include: + #pod + #pod =over + #pod + #pod =item * + #pod + #pod C -- Indicates the desired specification version (e.g. "1.0", "1.1" ... "1.4", "2"). + #pod Defaults to the latest version of the CPAN Meta Spec. + #pod + #pod =back + #pod + #pod Conversion proceeds through each version in turn. For example, a version 1.2 + #pod structure might be converted to 1.3 then 1.4 then finally to version 2. The + #pod conversion process attempts to clean-up simple errors and standardize data. + #pod For example, if C is given as a scalar, it will converted to an array + #pod reference containing the item. (Converting a structure to its own version will + #pod also clean-up and standardize.) + #pod + #pod When data are cleaned and standardized, missing or invalid fields will be + #pod replaced with sensible defaults when possible. This may be lossy or imprecise. + #pod For example, some badly structured META.yml files on CPAN have prerequisite + #pod modules listed as both keys and values: + #pod + #pod requires => { 'Foo::Bar' => 'Bam::Baz' } + #pod + #pod These would be split and each converted to a prerequisite with a minimum + #pod version of zero. + #pod + #pod When some mandatory fields are missing or invalid, the conversion will attempt + #pod to provide a sensible default or will fill them with a value of 'unknown'. For + #pod example a missing or unrecognized C field will result in a C + #pod field of 'unknown'. Fields that may get an 'unknown' include: + #pod + #pod =for :list + #pod * abstract + #pod * author + #pod * license + #pod + #pod =cut + + sub convert { + my ($self, %args) = @_; + my $args = { %args }; + + my $new_version = $args->{version} || $HIGHEST; + my $is_fragment = $args->{is_fragment}; + + my ($old_version) = $self->{spec}; + my $converted = _dclone($self->{data}); + + if ( $old_version == $new_version ) { + $converted = _convert( $converted, $cleanup{$old_version}, $old_version, $is_fragment ); + unless ( $args->{is_fragment} ) { + my $cmv = CPAN::Meta::Validator->new( $converted ); + unless ( $cmv->is_valid ) { + my $errs = join("\n", $cmv->errors); + die "Failed to clean-up $old_version metadata. Errors:\n$errs\n"; + } + } + return $converted; + } + elsif ( $old_version > $new_version ) { + my @vers = sort { $b <=> $a } keys %known_specs; + for my $i ( 0 .. $#vers-1 ) { + next if $vers[$i] > $old_version; + last if $vers[$i+1] < $new_version; + my $spec_string = "$vers[$i+1]-from-$vers[$i]"; + $converted = _convert( $converted, $down_convert{$spec_string}, $vers[$i+1], $is_fragment ); + unless ( $args->{is_fragment} ) { + my $cmv = CPAN::Meta::Validator->new( $converted ); + unless ( $cmv->is_valid ) { + my $errs = join("\n", $cmv->errors); + die "Failed to downconvert metadata to $vers[$i+1]. Errors:\n$errs\n"; + } + } + } + return $converted; + } + else { + my @vers = sort { $a <=> $b } keys %known_specs; + for my $i ( 0 .. $#vers-1 ) { + next if $vers[$i] < $old_version; + last if $vers[$i+1] > $new_version; + my $spec_string = "$vers[$i+1]-from-$vers[$i]"; + $converted = _convert( $converted, $up_convert{$spec_string}, $vers[$i+1], $is_fragment ); + unless ( $args->{is_fragment} ) { + my $cmv = CPAN::Meta::Validator->new( $converted ); + unless ( $cmv->is_valid ) { + my $errs = join("\n", $cmv->errors); + die "Failed to upconvert metadata to $vers[$i+1]. Errors:\n$errs\n"; + } + } + } + return $converted; + } + } + + #pod =method upgrade_fragment + #pod + #pod my $new_struct = $cmc->upgrade_fragment; + #pod + #pod Returns a new hash reference with the metadata converted to the latest version + #pod of the CPAN Meta Spec. No validation is done on the result -- you must + #pod validate after merging fragments into a complete metadata document. + #pod + #pod Available since version 2.141170. + #pod + #pod =cut + + sub upgrade_fragment { + my ($self) = @_; + my ($old_version) = $self->{spec}; + my %expected = + map {; $_ => 1 } + grep { defined } + map { $fragments_generate{$old_version}{$_} } + keys %{ $self->{data} }; + my $converted = $self->convert( version => $HIGHEST, is_fragment => 1 ); + for my $key ( keys %$converted ) { + next if $key =~ /^x_/i || $key eq 'meta-spec'; + delete $converted->{$key} unless $expected{$key}; + } + return $converted; + } + + 1; + + # ABSTRACT: Convert CPAN distribution metadata structures + + =pod + + =encoding UTF-8 + + =head1 NAME + + CPAN::Meta::Converter - Convert CPAN distribution metadata structures + + =head1 VERSION + + version 2.150005 + + =head1 SYNOPSIS + + my $struct = decode_json_file('META.json'); + + my $cmc = CPAN::Meta::Converter->new( $struct ); + + my $new_struct = $cmc->convert( version => "2" ); + + =head1 DESCRIPTION + + This module converts CPAN Meta structures from one form to another. The + primary use is to convert older structures to the most modern version of + the specification, but other transformations may be implemented in the + future as needed. (E.g. stripping all custom fields or stripping all + optional fields.) + + =head1 METHODS + + =head2 new + + my $cmc = CPAN::Meta::Converter->new( $struct ); + + The constructor should be passed a valid metadata structure but invalid + structures are accepted. If no meta-spec version is provided, version 1.0 will + be assumed. + + Optionally, you can provide a C argument after C<$struct>: + + my $cmc = CPAN::Meta::Converter->new( $struct, default_version => "1.4" ); + + This is only needed when converting a metadata fragment that does not include a + C field. + + =head2 convert + + my $new_struct = $cmc->convert( version => "2" ); + + Returns a new hash reference with the metadata converted to a different form. + C will die if any conversion/standardization still results in an + invalid structure. + + Valid parameters include: + + =over + + =item * + + C -- Indicates the desired specification version (e.g. "1.0", "1.1" ... "1.4", "2"). + Defaults to the latest version of the CPAN Meta Spec. + + =back + + Conversion proceeds through each version in turn. For example, a version 1.2 + structure might be converted to 1.3 then 1.4 then finally to version 2. The + conversion process attempts to clean-up simple errors and standardize data. + For example, if C is given as a scalar, it will converted to an array + reference containing the item. (Converting a structure to its own version will + also clean-up and standardize.) + + When data are cleaned and standardized, missing or invalid fields will be + replaced with sensible defaults when possible. This may be lossy or imprecise. + For example, some badly structured META.yml files on CPAN have prerequisite + modules listed as both keys and values: + + requires => { 'Foo::Bar' => 'Bam::Baz' } + + These would be split and each converted to a prerequisite with a minimum + version of zero. + + When some mandatory fields are missing or invalid, the conversion will attempt + to provide a sensible default or will fill them with a value of 'unknown'. For + example a missing or unrecognized C field will result in a C + field of 'unknown'. Fields that may get an 'unknown' include: + + =over 4 + + =item * + + abstract + + =item * + + author + + =item * + + license + + =back + + =head2 upgrade_fragment + + my $new_struct = $cmc->upgrade_fragment; + + Returns a new hash reference with the metadata converted to the latest version + of the CPAN Meta Spec. No validation is done on the result -- you must + validate after merging fragments into a complete metadata document. + + Available since version 2.141170. + + =head1 BUGS + + Please report any bugs or feature using the CPAN Request Tracker. + Bugs can be submitted through the web interface at + L + + When submitting a bug or request, please include a test-file or a patch to an + existing test-file that illustrates the bug or desired feature. + + =head1 AUTHORS + + =over 4 + + =item * + + David Golden + + =item * + + Ricardo Signes + + =back + + =head1 COPYRIGHT AND LICENSE + + This software is copyright (c) 2010 by David Golden and Ricardo Signes. + + This is free software; you can redistribute it and/or modify it under + the same terms as the Perl 5 programming language system itself. + + =cut + + __END__ + + + # vim: ts=2 sts=2 sw=2 et : + CPAN_META_CONVERTER + + $fatpacked{"CPAN/Meta/Feature.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_FEATURE'; + use 5.006; + use strict; + use warnings; + package CPAN::Meta::Feature; + + our $VERSION = '2.150005'; + + use CPAN::Meta::Prereqs; + + #pod =head1 DESCRIPTION + #pod + #pod A CPAN::Meta::Feature object describes an optional feature offered by a CPAN + #pod distribution and specified in the distribution's F (or F) + #pod file. + #pod + #pod For the most part, this class will only be used when operating on the result of + #pod the C or C methods on a L object. + #pod + #pod =method new + #pod + #pod my $feature = CPAN::Meta::Feature->new( $identifier => \%spec ); + #pod + #pod This returns a new Feature object. The C<%spec> argument to the constructor + #pod should be the same as the value of the C entry in the + #pod distmeta. It must contain entries for C and C. + #pod + #pod =cut + + sub new { + my ($class, $identifier, $spec) = @_; + + my %guts = ( + identifier => $identifier, + description => $spec->{description}, + prereqs => CPAN::Meta::Prereqs->new($spec->{prereqs}), + ); + + bless \%guts => $class; + } + + #pod =method identifier + #pod + #pod This method returns the feature's identifier. + #pod + #pod =cut + + sub identifier { $_[0]{identifier} } + + #pod =method description + #pod + #pod This method returns the feature's long description. + #pod + #pod =cut + + sub description { $_[0]{description} } + + #pod =method prereqs + #pod + #pod This method returns the feature's prerequisites as a L + #pod object. + #pod + #pod =cut + + sub prereqs { $_[0]{prereqs} } + + 1; + + # ABSTRACT: an optional feature provided by a CPAN distribution + + =pod + + =encoding UTF-8 + + =head1 NAME + + CPAN::Meta::Feature - an optional feature provided by a CPAN distribution + + =head1 VERSION + + version 2.150005 + + =head1 DESCRIPTION + + A CPAN::Meta::Feature object describes an optional feature offered by a CPAN + distribution and specified in the distribution's F (or F) + file. + + For the most part, this class will only be used when operating on the result of + the C or C methods on a L object. + + =head1 METHODS + + =head2 new + + my $feature = CPAN::Meta::Feature->new( $identifier => \%spec ); + + This returns a new Feature object. The C<%spec> argument to the constructor + should be the same as the value of the C entry in the + distmeta. It must contain entries for C and C. + + =head2 identifier + + This method returns the feature's identifier. + + =head2 description + + This method returns the feature's long description. + + =head2 prereqs + + This method returns the feature's prerequisites as a L + object. + + =head1 BUGS + + Please report any bugs or feature using the CPAN Request Tracker. + Bugs can be submitted through the web interface at + L + + When submitting a bug or request, please include a test-file or a patch to an + existing test-file that illustrates the bug or desired feature. + + =head1 AUTHORS + + =over 4 + + =item * + + David Golden + + =item * + + Ricardo Signes + + =back + + =head1 COPYRIGHT AND LICENSE + + This software is copyright (c) 2010 by David Golden and Ricardo Signes. + + This is free software; you can redistribute it and/or modify it under + the same terms as the Perl 5 programming language system itself. + + =cut + + __END__ + + + # vim: ts=2 sts=2 sw=2 et : + CPAN_META_FEATURE + + $fatpacked{"CPAN/Meta/History.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_HISTORY'; + # vi:tw=72 + use 5.006; + use strict; + use warnings; + package CPAN::Meta::History; + + our $VERSION = '2.150005'; + + 1; + + # ABSTRACT: history of CPAN Meta Spec changes + + __END__ + + =pod + + =encoding UTF-8 + + =head1 NAME + + CPAN::Meta::History - history of CPAN Meta Spec changes + + =head1 VERSION + + version 2.150005 + + =head1 DESCRIPTION + + The CPAN Meta Spec has gone through several iterations. It was + originally written in HTML and later revised into POD (though published + in HTML generated from the POD). Fields were added, removed or changed, + sometimes by design and sometimes to reflect real-world usage after the + fact. + + This document reconstructs the history of the CPAN Meta Spec based on + change logs, repository commit messages and the published HTML files. + In some cases, particularly prior to version 1.2, the exact version + when certain fields were introduced or changed is inconsistent between + sources. When in doubt, the published HTML files for versions 1.0 to + 1.4 as they existed when version 2 was developed are used as the + definitive source. + + Starting with version 2, the specification document is part of the + CPAN-Meta distribution and will be published on CPAN as + L. + + Going forward, specification version numbers will be integers and + decimal portions will correspond to a release date for the CPAN::Meta + library. + + =head1 HISTORY + + =head2 Version 2 + + April 2010 + + =over + + =item * + + Revised spec examples as perl data structures rather than YAML + + =item * + + Switched to JSON serialization from YAML + + =item * + + Specified allowed version number formats + + =item * + + Replaced 'requires', 'build_requires', 'configure_requires', + 'recommends' and 'conflicts' with new 'prereqs' data structure divided + by I (configure, build, test, runtime, etc.) and I + (requires, recommends, suggests, conflicts) + + =item * + + Added support for 'develop' phase for requirements for maintaining + a list of authoring tools + + =item * + + Changed 'license' to a list and revised the set of valid licenses + + =item * + + Made 'dynamic_config' mandatory to reduce confusion + + =item * + + Changed 'resources' subkey 'repository' to a hash that clarifies + repository type, url for browsing and url for checkout + + =item * + + Changed 'resources' subkey 'bugtracker' to a hash for either web + or mailto resource + + =item * + + Changed specification of 'optional_features': + + =over + + =item * + + Added formal specification and usage guide instead of just example + + =item * + + Changed to use new prereqs data structure instead of individual keys + + =back + + =item * + + Clarified intended use of 'author' as generalized contact list + + =item * + + Added 'release_status' field to indicate stable, testing or unstable + status to provide hints to indexers + + =item * + + Added 'description' field for a longer description of the distribution + + =item * + + Formalized use of "x_" or "X_" for all custom keys not listed in the + official spec + + =back + + =head2 Version 1.4 + + June 2008 + + =over + + =item * + + Noted explicit support for 'perl' in prerequisites + + =item * + + Added 'configure_requires' prerequisite type + + =item * + + Changed 'optional_features' + + =over + + =item * + + Example corrected to show map of maps instead of list of maps + (though descriptive text said 'map' even in v1.3) + + =item * + + Removed 'requires_packages', 'requires_os' and 'excluded_os' + as valid subkeys + + =back + + =back + + =head2 Version 1.3 + + November 2006 + + =over + + =item * + + Added 'no_index' subkey 'directory' and removed 'dir' to match actual + usage in the wild + + =item * + + Added a 'repository' subkey to 'resources' + + =back + + =head2 Version 1.2 + + August 2005 + + =over + + =item * + + Re-wrote and restructured spec in POD syntax + + =item * + + Changed 'name' to be mandatory + + =item * + + Changed 'generated_by' to be mandatory + + =item * + + Changed 'license' to be mandatory + + =item * + + Added version range specifications for prerequisites + + =item * + + Added required 'abstract' field + + =item * + + Added required 'author' field + + =item * + + Added required 'meta-spec' field to define 'version' (and 'url') of the + CPAN Meta Spec used for metadata + + =item * + + Added 'provides' field + + =item * + + Added 'no_index' field and deprecated 'private' field. 'no_index' + subkeys include 'file', 'dir', 'package' and 'namespace' + + =item * + + Added 'keywords' field + + =item * + + Added 'resources' field with subkeys 'homepage', 'license', and + 'bugtracker' + + =item * + + Added 'optional_features' field as an alternate under 'recommends'. + Includes 'description', 'requires', 'build_requires', 'conflicts', + 'requires_packages', 'requires_os' and 'excluded_os' as valid subkeys + + =item * + + Removed 'license_uri' field + + =back + + =head2 Version 1.1 + + May 2003 + + =over + + =item * + + Changed 'version' to be mandatory + + =item * + + Added 'private' field + + =item * + + Added 'license_uri' field + + =back + + =head2 Version 1.0 + + March 2003 + + =over + + =item * + + Original release (in HTML format only) + + =item * + + Included 'name', 'version', 'license', 'distribution_type', 'requires', + 'recommends', 'build_requires', 'conflicts', 'dynamic_config', + 'generated_by' + + =back + + =head1 AUTHORS + + =over 4 + + =item * + + David Golden + + =item * + + Ricardo Signes + + =back + + =head1 COPYRIGHT AND LICENSE + + This software is copyright (c) 2010 by David Golden and Ricardo Signes. + + This is free software; you can redistribute it and/or modify it under + the same terms as the Perl 5 programming language system itself. + + =cut + CPAN_META_HISTORY + + $fatpacked{"CPAN/Meta/Merge.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_MERGE'; + use strict; + use warnings; + + package CPAN::Meta::Merge; + + our $VERSION = '2.150005'; + + use Carp qw/croak/; + use Scalar::Util qw/blessed/; + use CPAN::Meta::Converter 2.141170; + + sub _is_identical { + my ($left, $right) = @_; + return + (not defined $left and not defined $right) + # if either of these are references, we compare the serialized value + || (defined $left and defined $right and $left eq $right); + } + + sub _identical { + my ($left, $right, $path) = @_; + croak sprintf "Can't merge attribute %s: '%s' does not equal '%s'", join('.', @{$path}), $left, $right + unless _is_identical($left, $right); + return $left; + } + + sub _merge { + my ($current, $next, $mergers, $path) = @_; + for my $key (keys %{$next}) { + if (not exists $current->{$key}) { + $current->{$key} = $next->{$key}; + } + elsif (my $merger = $mergers->{$key}) { + $current->{$key} = $merger->($current->{$key}, $next->{$key}, [ @{$path}, $key ]); + } + elsif ($merger = $mergers->{':default'}) { + $current->{$key} = $merger->($current->{$key}, $next->{$key}, [ @{$path}, $key ]); + } + else { + croak sprintf "Can't merge unknown attribute '%s'", join '.', @{$path}, $key; + } + } + return $current; + } + + sub _uniq { + my %seen = (); + return grep { not $seen{$_}++ } @_; + } + + sub _set_addition { + my ($left, $right) = @_; + return [ +_uniq(@{$left}, @{$right}) ]; + } + + sub _uniq_map { + my ($left, $right, $path) = @_; + for my $key (keys %{$right}) { + if (not exists $left->{$key}) { + $left->{$key} = $right->{$key}; + } + # identical strings or references are merged identically + elsif (_is_identical($left->{$key}, $right->{$key})) { + 1; # do nothing - keep left + } + elsif (ref $left->{$key} eq 'HASH' and ref $right->{$key} eq 'HASH') { + $left->{$key} = _uniq_map($left->{$key}, $right->{$key}, [ @{$path}, $key ]); + } + else { + croak 'Duplication of element ' . join '.', @{$path}, $key; + } + } + return $left; + } + + sub _improvize { + my ($left, $right, $path) = @_; + my ($name) = reverse @{$path}; + if ($name =~ /^x_/) { + if (ref($left) eq 'ARRAY') { + return _set_addition($left, $right, $path); + } + elsif (ref($left) eq 'HASH') { + return _uniq_map($left, $right, $path); + } + else { + return _identical($left, $right, $path); + } + } + croak sprintf "Can't merge '%s'", join '.', @{$path}; + } + + sub _optional_features { + my ($left, $right, $path) = @_; + + for my $key (keys %{$right}) { + if (not exists $left->{$key}) { + $left->{$key} = $right->{$key}; + } + else { + for my $subkey (keys %{ $right->{$key} }) { + next if $subkey eq 'prereqs'; + if (not exists $left->{$key}{$subkey}) { + $left->{$key}{$subkey} = $right->{$key}{$subkey}; + } + else { + Carp::croak "Cannot merge two optional_features named '$key' with different '$subkey' values" + if do { no warnings 'uninitialized'; $left->{$key}{$subkey} ne $right->{$key}{$subkey} }; + } + } + + require CPAN::Meta::Prereqs; + $left->{$key}{prereqs} = + CPAN::Meta::Prereqs->new($left->{$key}{prereqs}) + ->with_merged_prereqs(CPAN::Meta::Prereqs->new($right->{$key}{prereqs})) + ->as_string_hash; + } + } + return $left; + } + + + my %default = ( + abstract => \&_identical, + author => \&_set_addition, + dynamic_config => sub { + my ($left, $right) = @_; + return $left || $right; + }, + generated_by => sub { + my ($left, $right) = @_; + return join ', ', _uniq(split(/, /, $left), split(/, /, $right)); + }, + license => \&_set_addition, + 'meta-spec' => { + version => \&_identical, + url => \&_identical + }, + name => \&_identical, + release_status => \&_identical, + version => \&_identical, + description => \&_identical, + keywords => \&_set_addition, + no_index => { map { ($_ => \&_set_addition) } qw/file directory package namespace/ }, + optional_features => \&_optional_features, + prereqs => sub { + require CPAN::Meta::Prereqs; + my ($left, $right) = map { CPAN::Meta::Prereqs->new($_) } @_[0,1]; + return $left->with_merged_prereqs($right)->as_string_hash; + }, + provides => \&_uniq_map, + resources => { + license => \&_set_addition, + homepage => \&_identical, + bugtracker => \&_uniq_map, + repository => \&_uniq_map, + ':default' => \&_improvize, + }, + ':default' => \&_improvize, + ); + + sub new { + my ($class, %arguments) = @_; + croak 'default version required' if not exists $arguments{default_version}; + my %mapping = %default; + my %extra = %{ $arguments{extra_mappings} || {} }; + for my $key (keys %extra) { + if (ref($mapping{$key}) eq 'HASH') { + $mapping{$key} = { %{ $mapping{$key} }, %{ $extra{$key} } }; + } + else { + $mapping{$key} = $extra{$key}; + } + } + return bless { + default_version => $arguments{default_version}, + mapping => _coerce_mapping(\%mapping, []), + }, $class; + } + + my %coderef_for = ( + set_addition => \&_set_addition, + uniq_map => \&_uniq_map, + identical => \&_identical, + improvize => \&_improvize, + ); + + sub _coerce_mapping { + my ($orig, $map_path) = @_; + my %ret; + for my $key (keys %{$orig}) { + my $value = $orig->{$key}; + if (ref($orig->{$key}) eq 'CODE') { + $ret{$key} = $value; + } + elsif (ref($value) eq 'HASH') { + my $mapping = _coerce_mapping($value, [ @{$map_path}, $key ]); + $ret{$key} = sub { + my ($left, $right, $path) = @_; + return _merge($left, $right, $mapping, [ @{$path} ]); + }; + } + elsif ($coderef_for{$value}) { + $ret{$key} = $coderef_for{$value}; + } + else { + croak "Don't know what to do with " . join '.', @{$map_path}, $key; + } + } + return \%ret; + } + + sub merge { + my ($self, @items) = @_; + my $current = {}; + for my $next (@items) { + if ( blessed($next) && $next->isa('CPAN::Meta') ) { + $next = $next->as_struct; + } + elsif ( ref($next) eq 'HASH' ) { + my $cmc = CPAN::Meta::Converter->new( + $next, default_version => $self->{default_version} + ); + $next = $cmc->upgrade_fragment; + } + else { + croak "Don't know how to merge '$next'"; + } + $current = _merge($current, $next, $self->{mapping}, []); + } + return $current; + } + + 1; + + # ABSTRACT: Merging CPAN Meta fragments + + + # vim: ts=2 sts=2 sw=2 et : + + __END__ + + =pod + + =encoding UTF-8 + + =head1 NAME + + CPAN::Meta::Merge - Merging CPAN Meta fragments + + =head1 VERSION + + version 2.150005 + + =head1 SYNOPSIS + + my $merger = CPAN::Meta::Merge->new(default_version => "2"); + my $meta = $merger->merge($base, @additional); + + =head1 DESCRIPTION + + =head1 METHODS + + =head2 new + + This creates a CPAN::Meta::Merge object. It takes one mandatory named + argument, C, declaring the version of the meta-spec that must be + used for the merge. It can optionally take an C argument + that allows one to add additional merging functions for specific elements. + + =head2 merge(@fragments) + + Merge all C<@fragments> together. It will accept both CPAN::Meta objects and + (possibly incomplete) hashrefs of metadata. + + =head1 AUTHORS + + =over 4 + + =item * + + David Golden + + =item * + + Ricardo Signes + + =back + + =head1 COPYRIGHT AND LICENSE + + This software is copyright (c) 2010 by David Golden and Ricardo Signes. + + This is free software; you can redistribute it and/or modify it under + the same terms as the Perl 5 programming language system itself. + + =cut + CPAN_META_MERGE + + $fatpacked{"CPAN/Meta/Prereqs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_PREREQS'; + use 5.006; + use strict; + use warnings; + package CPAN::Meta::Prereqs; + + our $VERSION = '2.150005'; + + #pod =head1 DESCRIPTION + #pod + #pod A CPAN::Meta::Prereqs object represents the prerequisites for a CPAN + #pod distribution or one of its optional features. Each set of prereqs is + #pod organized by phase and type, as described in L. + #pod + #pod =cut + + use Carp qw(confess); + use Scalar::Util qw(blessed); + use CPAN::Meta::Requirements 2.121; + + #pod =method new + #pod + #pod my $prereq = CPAN::Meta::Prereqs->new( \%prereq_spec ); + #pod + #pod This method returns a new set of Prereqs. The input should look like the + #pod contents of the C field described in L, meaning + #pod something more or less like this: + #pod + #pod my $prereq = CPAN::Meta::Prereqs->new({ + #pod runtime => { + #pod requires => { + #pod 'Some::Module' => '1.234', + #pod ..., + #pod }, + #pod ..., + #pod }, + #pod ..., + #pod }); + #pod + #pod You can also construct an empty set of prereqs with: + #pod + #pod my $prereqs = CPAN::Meta::Prereqs->new; + #pod + #pod This empty set of prereqs is useful for accumulating new prereqs before finally + #pod dumping the whole set into a structure or string. + #pod + #pod =cut + + sub __legal_phases { qw(configure build test runtime develop) } + sub __legal_types { qw(requires recommends suggests conflicts) } + + # expect a prereq spec from META.json -- rjbs, 2010-04-11 + sub new { + my ($class, $prereq_spec) = @_; + $prereq_spec ||= {}; + + my %is_legal_phase = map {; $_ => 1 } $class->__legal_phases; + my %is_legal_type = map {; $_ => 1 } $class->__legal_types; + + my %guts; + PHASE: for my $phase (keys %$prereq_spec) { + next PHASE unless $phase =~ /\Ax_/i or $is_legal_phase{$phase}; + + my $phase_spec = $prereq_spec->{ $phase }; + next PHASE unless keys %$phase_spec; + + TYPE: for my $type (keys %$phase_spec) { + next TYPE unless $type =~ /\Ax_/i or $is_legal_type{$type}; + + my $spec = $phase_spec->{ $type }; + + next TYPE unless keys %$spec; + + $guts{prereqs}{$phase}{$type} = CPAN::Meta::Requirements->from_string_hash( + $spec + ); + } + } + + return bless \%guts => $class; + } + + #pod =method requirements_for + #pod + #pod my $requirements = $prereqs->requirements_for( $phase, $type ); + #pod + #pod This method returns a L object for the given + #pod phase/type combination. If no prerequisites are registered for that + #pod combination, a new CPAN::Meta::Requirements object will be returned, and it may + #pod be added to as needed. + #pod + #pod If C<$phase> or C<$type> are undefined or otherwise invalid, an exception will + #pod be raised. + #pod + #pod =cut + + sub requirements_for { + my ($self, $phase, $type) = @_; + + confess "requirements_for called without phase" unless defined $phase; + confess "requirements_for called without type" unless defined $type; + + unless ($phase =~ /\Ax_/i or grep { $phase eq $_ } $self->__legal_phases) { + confess "requested requirements for unknown phase: $phase"; + } + + unless ($type =~ /\Ax_/i or grep { $type eq $_ } $self->__legal_types) { + confess "requested requirements for unknown type: $type"; + } + + my $req = ($self->{prereqs}{$phase}{$type} ||= CPAN::Meta::Requirements->new); + + $req->finalize if $self->is_finalized; + + return $req; + } + + #pod =method with_merged_prereqs + #pod + #pod my $new_prereqs = $prereqs->with_merged_prereqs( $other_prereqs ); + #pod + #pod my $new_prereqs = $prereqs->with_merged_prereqs( \@other_prereqs ); + #pod + #pod This method returns a new CPAN::Meta::Prereqs objects in which all the + #pod other prerequisites given are merged into the current set. This is primarily + #pod provided for combining a distribution's core prereqs with the prereqs of one of + #pod its optional features. + #pod + #pod The new prereqs object has no ties to the originals, and altering it further + #pod will not alter them. + #pod + #pod =cut + + sub with_merged_prereqs { + my ($self, $other) = @_; + + my @other = blessed($other) ? $other : @$other; + + my @prereq_objs = ($self, @other); + + my %new_arg; + + for my $phase ($self->__legal_phases) { + for my $type ($self->__legal_types) { + my $req = CPAN::Meta::Requirements->new; + + for my $prereq (@prereq_objs) { + my $this_req = $prereq->requirements_for($phase, $type); + next unless $this_req->required_modules; + + $req->add_requirements($this_req); + } + + next unless $req->required_modules; + + $new_arg{ $phase }{ $type } = $req->as_string_hash; + } + } + + return (ref $self)->new(\%new_arg); + } + + #pod =method merged_requirements + #pod + #pod my $new_reqs = $prereqs->merged_requirements( \@phases, \@types ); + #pod my $new_reqs = $prereqs->merged_requirements( \@phases ); + #pod my $new_reqs = $prereqs->merged_requirements(); + #pod + #pod This method joins together all requirements across a number of phases + #pod and types into a new L object. If arguments + #pod are omitted, it defaults to "runtime", "build" and "test" for phases + #pod and "requires" and "recommends" for types. + #pod + #pod =cut + + sub merged_requirements { + my ($self, $phases, $types) = @_; + $phases = [qw/runtime build test/] unless defined $phases; + $types = [qw/requires recommends/] unless defined $types; + + confess "merged_requirements phases argument must be an arrayref" + unless ref $phases eq 'ARRAY'; + confess "merged_requirements types argument must be an arrayref" + unless ref $types eq 'ARRAY'; + + my $req = CPAN::Meta::Requirements->new; + + for my $phase ( @$phases ) { + unless ($phase =~ /\Ax_/i or grep { $phase eq $_ } $self->__legal_phases) { + confess "requested requirements for unknown phase: $phase"; + } + for my $type ( @$types ) { + unless ($type =~ /\Ax_/i or grep { $type eq $_ } $self->__legal_types) { + confess "requested requirements for unknown type: $type"; + } + $req->add_requirements( $self->requirements_for($phase, $type) ); + } + } + + $req->finalize if $self->is_finalized; + + return $req; + } + + + #pod =method as_string_hash + #pod + #pod This method returns a hashref containing structures suitable for dumping into a + #pod distmeta data structure. It is made up of hashes and strings, only; there will + #pod be no Prereqs, CPAN::Meta::Requirements, or C objects inside it. + #pod + #pod =cut + + sub as_string_hash { + my ($self) = @_; + + my %hash; + + for my $phase ($self->__legal_phases) { + for my $type ($self->__legal_types) { + my $req = $self->requirements_for($phase, $type); + next unless $req->required_modules; + + $hash{ $phase }{ $type } = $req->as_string_hash; + } + } + + return \%hash; + } + + #pod =method is_finalized + #pod + #pod This method returns true if the set of prereqs has been marked "finalized," and + #pod cannot be altered. + #pod + #pod =cut + + sub is_finalized { $_[0]{finalized} } + + #pod =method finalize + #pod + #pod Calling C on a Prereqs object will close it for further modification. + #pod Attempting to make any changes that would actually alter the prereqs will + #pod result in an exception being thrown. + #pod + #pod =cut + + sub finalize { + my ($self) = @_; + + $self->{finalized} = 1; + + for my $phase (keys %{ $self->{prereqs} }) { + $_->finalize for values %{ $self->{prereqs}{$phase} }; + } + } + + #pod =method clone + #pod + #pod my $cloned_prereqs = $prereqs->clone; + #pod + #pod This method returns a Prereqs object that is identical to the original object, + #pod but can be altered without affecting the original object. Finalization does + #pod not survive cloning, meaning that you may clone a finalized set of prereqs and + #pod then modify the clone. + #pod + #pod =cut + + sub clone { + my ($self) = @_; + + my $clone = (ref $self)->new( $self->as_string_hash ); + } + + 1; + + # ABSTRACT: a set of distribution prerequisites by phase and type + + =pod + + =encoding UTF-8 + + =head1 NAME + + CPAN::Meta::Prereqs - a set of distribution prerequisites by phase and type + + =head1 VERSION + + version 2.150005 + + =head1 DESCRIPTION + + A CPAN::Meta::Prereqs object represents the prerequisites for a CPAN + distribution or one of its optional features. Each set of prereqs is + organized by phase and type, as described in L. + + =head1 METHODS + + =head2 new + + my $prereq = CPAN::Meta::Prereqs->new( \%prereq_spec ); + + This method returns a new set of Prereqs. The input should look like the + contents of the C field described in L, meaning + something more or less like this: + + my $prereq = CPAN::Meta::Prereqs->new({ + runtime => { + requires => { + 'Some::Module' => '1.234', + ..., + }, + ..., + }, + ..., + }); + + You can also construct an empty set of prereqs with: + + my $prereqs = CPAN::Meta::Prereqs->new; + + This empty set of prereqs is useful for accumulating new prereqs before finally + dumping the whole set into a structure or string. + + =head2 requirements_for + + my $requirements = $prereqs->requirements_for( $phase, $type ); + + This method returns a L object for the given + phase/type combination. If no prerequisites are registered for that + combination, a new CPAN::Meta::Requirements object will be returned, and it may + be added to as needed. + + If C<$phase> or C<$type> are undefined or otherwise invalid, an exception will + be raised. + + =head2 with_merged_prereqs + + my $new_prereqs = $prereqs->with_merged_prereqs( $other_prereqs ); + + my $new_prereqs = $prereqs->with_merged_prereqs( \@other_prereqs ); + + This method returns a new CPAN::Meta::Prereqs objects in which all the + other prerequisites given are merged into the current set. This is primarily + provided for combining a distribution's core prereqs with the prereqs of one of + its optional features. + + The new prereqs object has no ties to the originals, and altering it further + will not alter them. + + =head2 merged_requirements + + my $new_reqs = $prereqs->merged_requirements( \@phases, \@types ); + my $new_reqs = $prereqs->merged_requirements( \@phases ); + my $new_reqs = $prereqs->merged_requirements(); + + This method joins together all requirements across a number of phases + and types into a new L object. If arguments + are omitted, it defaults to "runtime", "build" and "test" for phases + and "requires" and "recommends" for types. + + =head2 as_string_hash + + This method returns a hashref containing structures suitable for dumping into a + distmeta data structure. It is made up of hashes and strings, only; there will + be no Prereqs, CPAN::Meta::Requirements, or C objects inside it. + + =head2 is_finalized + + This method returns true if the set of prereqs has been marked "finalized," and + cannot be altered. + + =head2 finalize + + Calling C on a Prereqs object will close it for further modification. + Attempting to make any changes that would actually alter the prereqs will + result in an exception being thrown. + + =head2 clone + + my $cloned_prereqs = $prereqs->clone; + + This method returns a Prereqs object that is identical to the original object, + but can be altered without affecting the original object. Finalization does + not survive cloning, meaning that you may clone a finalized set of prereqs and + then modify the clone. + + =head1 BUGS + + Please report any bugs or feature using the CPAN Request Tracker. + Bugs can be submitted through the web interface at + L + + When submitting a bug or request, please include a test-file or a patch to an + existing test-file that illustrates the bug or desired feature. + + =head1 AUTHORS + + =over 4 + + =item * + + David Golden + + =item * + + Ricardo Signes + + =back + + =head1 COPYRIGHT AND LICENSE + + This software is copyright (c) 2010 by David Golden and Ricardo Signes. + + This is free software; you can redistribute it and/or modify it under + the same terms as the Perl 5 programming language system itself. + + =cut + + __END__ + + + # vim: ts=2 sts=2 sw=2 et : + CPAN_META_PREREQS + + $fatpacked{"CPAN/Meta/Requirements.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_REQUIREMENTS'; + use strict; + use warnings; + package CPAN::Meta::Requirements; + # ABSTRACT: a set of version requirements for a CPAN dist + + our $VERSION = '2.133'; + + #pod =head1 SYNOPSIS + #pod + #pod use CPAN::Meta::Requirements; + #pod + #pod my $build_requires = CPAN::Meta::Requirements->new; + #pod + #pod $build_requires->add_minimum('Library::Foo' => 1.208); + #pod + #pod $build_requires->add_minimum('Library::Foo' => 2.602); + #pod + #pod $build_requires->add_minimum('Module::Bar' => 'v1.2.3'); + #pod + #pod $METAyml->{build_requires} = $build_requires->as_string_hash; + #pod + #pod =head1 DESCRIPTION + #pod + #pod A CPAN::Meta::Requirements object models a set of version constraints like + #pod those specified in the F or F files in CPAN distributions, + #pod and as defined by L; + #pod It can be built up by adding more and more constraints, and it will reduce them + #pod to the simplest representation. + #pod + #pod Logically impossible constraints will be identified immediately by thrown + #pod exceptions. + #pod + #pod =cut + + use Carp (); + + # To help ExtUtils::MakeMaker bootstrap CPAN::Meta::Requirements on perls + # before 5.10, we fall back to the EUMM bundled compatibility version module if + # that's the only thing available. This shouldn't ever happen in a normal CPAN + # install of CPAN::Meta::Requirements, as version.pm will be picked up from + # prereqs and be available at runtime. + + BEGIN { + eval "use version ()"; ## no critic + if ( my $err = $@ ) { + eval "use ExtUtils::MakeMaker::version" or die $err; ## no critic + } + } + + # Perl 5.10.0 didn't have "is_qv" in version.pm + *_is_qv = version->can('is_qv') ? sub { $_[0]->is_qv } : sub { exists $_[0]->{qv} }; + + # construct once, reuse many times + my $V0 = version->new(0); + + #pod =method new + #pod + #pod my $req = CPAN::Meta::Requirements->new; + #pod + #pod This returns a new CPAN::Meta::Requirements object. It takes an optional + #pod hash reference argument. Currently, only one key is supported: + #pod + #pod =for :list + #pod * C -- if provided, when a version cannot be parsed into + #pod a version object, this code reference will be called with the invalid + #pod version string as first argument, and the module name as second + #pod argument. It must return a valid version object. + #pod + #pod All other keys are ignored. + #pod + #pod =cut + + my @valid_options = qw( bad_version_hook ); + + sub new { + my ($class, $options) = @_; + $options ||= {}; + Carp::croak "Argument to $class\->new() must be a hash reference" + unless ref $options eq 'HASH'; + my %self = map {; $_ => $options->{$_}} @valid_options; + + return bless \%self => $class; + } + + # from version::vpp + sub _find_magic_vstring { + my $value = shift; + my $tvalue = ''; + require B; + my $sv = B::svref_2object(\$value); + my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef; + while ( $magic ) { + if ( $magic->TYPE eq 'V' ) { + $tvalue = $magic->PTR; + $tvalue =~ s/^v?(.+)$/v$1/; + last; + } + else { + $magic = $magic->MOREMAGIC; + } + } + return $tvalue; + } + + # safe if given an unblessed reference + sub _isa_version { + UNIVERSAL::isa( $_[0], 'UNIVERSAL' ) && $_[0]->isa('version') + } + + sub _version_object { + my ($self, $module, $version) = @_; + + my ($vobj, $err); + + if (not defined $version or (!ref($version) && $version eq '0')) { + return $V0; + } + elsif ( ref($version) eq 'version' || _isa_version($version) ) { + $vobj = $version; + } + else { + # hack around version::vpp not handling <3 character vstring literals + if ( $INC{'version/vpp.pm'} || $INC{'ExtUtils/MakeMaker/version/vpp.pm'} ) { + my $magic = _find_magic_vstring( $version ); + $version = $magic if length $magic; + } + eval { + local $SIG{__WARN__} = sub { die "Invalid version: $_[0]" }; + $vobj = version->new($version); + }; + if ( my $err = $@ ) { + my $hook = $self->{bad_version_hook}; + $vobj = eval { $hook->($version, $module) } + if ref $hook eq 'CODE'; + unless (eval { $vobj->isa("version") }) { + $err =~ s{ at .* line \d+.*$}{}; + die "Can't convert '$version': $err"; + } + } + } + + # ensure no leading '.' + if ( $vobj =~ m{\A\.} ) { + $vobj = version->new("0$vobj"); + } + + # ensure normal v-string form + if ( _is_qv($vobj) ) { + $vobj = version->new($vobj->normal); + } + + return $vobj; + } + + #pod =method add_minimum + #pod + #pod $req->add_minimum( $module => $version ); + #pod + #pod This adds a new minimum version requirement. If the new requirement is + #pod redundant to the existing specification, this has no effect. + #pod + #pod Minimum requirements are inclusive. C<$version> is required, along with any + #pod greater version number. + #pod + #pod This method returns the requirements object. + #pod + #pod =method add_maximum + #pod + #pod $req->add_maximum( $module => $version ); + #pod + #pod This adds a new maximum version requirement. If the new requirement is + #pod redundant to the existing specification, this has no effect. + #pod + #pod Maximum requirements are inclusive. No version strictly greater than the given + #pod version is allowed. + #pod + #pod This method returns the requirements object. + #pod + #pod =method add_exclusion + #pod + #pod $req->add_exclusion( $module => $version ); + #pod + #pod This adds a new excluded version. For example, you might use these three + #pod method calls: + #pod + #pod $req->add_minimum( $module => '1.00' ); + #pod $req->add_maximum( $module => '1.82' ); + #pod + #pod $req->add_exclusion( $module => '1.75' ); + #pod + #pod Any version between 1.00 and 1.82 inclusive would be acceptable, except for + #pod 1.75. + #pod + #pod This method returns the requirements object. + #pod + #pod =method exact_version + #pod + #pod $req->exact_version( $module => $version ); + #pod + #pod This sets the version required for the given module to I the given + #pod version. No other version would be considered acceptable. + #pod + #pod This method returns the requirements object. + #pod + #pod =cut + + BEGIN { + for my $type (qw(maximum exclusion exact_version)) { + my $method = "with_$type"; + my $to_add = $type eq 'exact_version' ? $type : "add_$type"; + + my $code = sub { + my ($self, $name, $version) = @_; + + $version = $self->_version_object( $name, $version ); + + $self->__modify_entry_for($name, $method, $version); + + return $self; + }; + + no strict 'refs'; + *$to_add = $code; + } + } + + # add_minimum is optimized compared to generated subs above because + # it is called frequently and with "0" or equivalent input + sub add_minimum { + my ($self, $name, $version) = @_; + + # stringify $version so that version->new("0.00")->stringify ne "0" + # which preserves the user's choice of "0.00" as the requirement + if (not defined $version or "$version" eq '0') { + return $self if $self->__entry_for($name); + Carp::confess("can't add new requirements to finalized requirements") + if $self->is_finalized; + + $self->{requirements}{ $name } = + CPAN::Meta::Requirements::_Range::Range->with_minimum($V0); + } + else { + $version = $self->_version_object( $name, $version ); + + $self->__modify_entry_for($name, 'with_minimum', $version); + } + return $self; + } + + #pod =method add_requirements + #pod + #pod $req->add_requirements( $another_req_object ); + #pod + #pod This method adds all the requirements in the given CPAN::Meta::Requirements object + #pod to the requirements object on which it was called. If there are any conflicts, + #pod an exception is thrown. + #pod + #pod This method returns the requirements object. + #pod + #pod =cut + + sub add_requirements { + my ($self, $req) = @_; + + for my $module ($req->required_modules) { + my $modifiers = $req->__entry_for($module)->as_modifiers; + for my $modifier (@$modifiers) { + my ($method, @args) = @$modifier; + $self->$method($module => @args); + }; + } + + return $self; + } + + #pod =method accepts_module + #pod + #pod my $bool = $req->accepts_module($module => $version); + #pod + #pod Given an module and version, this method returns true if the version + #pod specification for the module accepts the provided version. In other words, + #pod given: + #pod + #pod Module => '>= 1.00, < 2.00' + #pod + #pod We will accept 1.00 and 1.75 but not 0.50 or 2.00. + #pod + #pod For modules that do not appear in the requirements, this method will return + #pod true. + #pod + #pod =cut + + sub accepts_module { + my ($self, $module, $version) = @_; + + $version = $self->_version_object( $module, $version ); + + return 1 unless my $range = $self->__entry_for($module); + return $range->_accepts($version); + } + + #pod =method clear_requirement + #pod + #pod $req->clear_requirement( $module ); + #pod + #pod This removes the requirement for a given module from the object. + #pod + #pod This method returns the requirements object. + #pod + #pod =cut + + sub clear_requirement { + my ($self, $module) = @_; + + return $self unless $self->__entry_for($module); + + Carp::confess("can't clear requirements on finalized requirements") + if $self->is_finalized; + + delete $self->{requirements}{ $module }; + + return $self; + } + + #pod =method requirements_for_module + #pod + #pod $req->requirements_for_module( $module ); + #pod + #pod This returns a string containing the version requirements for a given module in + #pod the format described in L or undef if the given module has no + #pod requirements. This should only be used for informational purposes such as error + #pod messages and should not be interpreted or used for comparison (see + #pod L instead.) + #pod + #pod =cut + + sub requirements_for_module { + my ($self, $module) = @_; + my $entry = $self->__entry_for($module); + return unless $entry; + return $entry->as_string; + } + + #pod =method required_modules + #pod + #pod This method returns a list of all the modules for which requirements have been + #pod specified. + #pod + #pod =cut + + sub required_modules { keys %{ $_[0]{requirements} } } + + #pod =method clone + #pod + #pod $req->clone; + #pod + #pod This method returns a clone of the invocant. The clone and the original object + #pod can then be changed independent of one another. + #pod + #pod =cut + + sub clone { + my ($self) = @_; + my $new = (ref $self)->new; + + return $new->add_requirements($self); + } + + sub __entry_for { $_[0]{requirements}{ $_[1] } } + + sub __modify_entry_for { + my ($self, $name, $method, $version) = @_; + + my $fin = $self->is_finalized; + my $old = $self->__entry_for($name); + + Carp::confess("can't add new requirements to finalized requirements") + if $fin and not $old; + + my $new = ($old || 'CPAN::Meta::Requirements::_Range::Range') + ->$method($version); + + Carp::confess("can't modify finalized requirements") + if $fin and $old->as_string ne $new->as_string; + + $self->{requirements}{ $name } = $new; + } + + #pod =method is_simple + #pod + #pod This method returns true if and only if all requirements are inclusive minimums + #pod -- that is, if their string expression is just the version number. + #pod + #pod =cut + + sub is_simple { + my ($self) = @_; + for my $module ($self->required_modules) { + # XXX: This is a complete hack, but also entirely correct. + return if $self->__entry_for($module)->as_string =~ /\s/; + } + + return 1; + } + + #pod =method is_finalized + #pod + #pod This method returns true if the requirements have been finalized by having the + #pod C method called on them. + #pod + #pod =cut + + sub is_finalized { $_[0]{finalized} } + + #pod =method finalize + #pod + #pod This method marks the requirements finalized. Subsequent attempts to change + #pod the requirements will be fatal, I they would result in a change. If they + #pod would not alter the requirements, they have no effect. + #pod + #pod If a finalized set of requirements is cloned, the cloned requirements are not + #pod also finalized. + #pod + #pod =cut + + sub finalize { $_[0]{finalized} = 1 } + + #pod =method as_string_hash + #pod + #pod This returns a reference to a hash describing the requirements using the + #pod strings in the L specification. + #pod + #pod For example after the following program: + #pod + #pod my $req = CPAN::Meta::Requirements->new; + #pod + #pod $req->add_minimum('CPAN::Meta::Requirements' => 0.102); + #pod + #pod $req->add_minimum('Library::Foo' => 1.208); + #pod + #pod $req->add_maximum('Library::Foo' => 2.602); + #pod + #pod $req->add_minimum('Module::Bar' => 'v1.2.3'); + #pod + #pod $req->add_exclusion('Module::Bar' => 'v1.2.8'); + #pod + #pod $req->exact_version('Xyzzy' => '6.01'); + #pod + #pod my $hashref = $req->as_string_hash; + #pod + #pod C<$hashref> would contain: + #pod + #pod { + #pod 'CPAN::Meta::Requirements' => '0.102', + #pod 'Library::Foo' => '>= 1.208, <= 2.206', + #pod 'Module::Bar' => '>= v1.2.3, != v1.2.8', + #pod 'Xyzzy' => '== 6.01', + #pod } + #pod + #pod =cut + + sub as_string_hash { + my ($self) = @_; + + my %hash = map {; $_ => $self->{requirements}{$_}->as_string } + $self->required_modules; + + return \%hash; + } + + #pod =method add_string_requirement + #pod + #pod $req->add_string_requirement('Library::Foo' => '>= 1.208, <= 2.206'); + #pod $req->add_string_requirement('Library::Foo' => v1.208); + #pod + #pod This method parses the passed in string and adds the appropriate requirement + #pod for the given module. A version can be a Perl "v-string". It understands + #pod version ranges as described in the L. For + #pod example: + #pod + #pod =over 4 + #pod + #pod =item 1.3 + #pod + #pod =item >= 1.3 + #pod + #pod =item <= 1.3 + #pod + #pod =item == 1.3 + #pod + #pod =item != 1.3 + #pod + #pod =item > 1.3 + #pod + #pod =item < 1.3 + #pod + #pod =item >= 1.3, != 1.5, <= 2.0 + #pod + #pod A version number without an operator is equivalent to specifying a minimum + #pod (C=>). Extra whitespace is allowed. + #pod + #pod =back + #pod + #pod =cut + + my %methods_for_op = ( + '==' => [ qw(exact_version) ], + '!=' => [ qw(add_exclusion) ], + '>=' => [ qw(add_minimum) ], + '<=' => [ qw(add_maximum) ], + '>' => [ qw(add_minimum add_exclusion) ], + '<' => [ qw(add_maximum add_exclusion) ], + ); + + sub add_string_requirement { + my ($self, $module, $req) = @_; + + unless ( defined $req && length $req ) { + $req = 0; + $self->_blank_carp($module); + } + + my $magic = _find_magic_vstring( $req ); + if (length $magic) { + $self->add_minimum($module => $magic); + return; + } + + my @parts = split qr{\s*,\s*}, $req; + + for my $part (@parts) { + my ($op, $ver) = $part =~ m{\A\s*(==|>=|>|<=|<|!=)\s*(.*)\z}; + + if (! defined $op) { + $self->add_minimum($module => $part); + } else { + Carp::confess("illegal requirement string: $req") + unless my $methods = $methods_for_op{ $op }; + + $self->$_($module => $ver) for @$methods; + } + } + } + + #pod =method from_string_hash + #pod + #pod my $req = CPAN::Meta::Requirements->from_string_hash( \%hash ); + #pod my $req = CPAN::Meta::Requirements->from_string_hash( \%hash, \%opts ); + #pod + #pod This is an alternate constructor for a CPAN::Meta::Requirements + #pod object. It takes a hash of module names and version requirement + #pod strings and returns a new CPAN::Meta::Requirements object. As with + #pod add_string_requirement, a version can be a Perl "v-string". Optionally, + #pod you can supply a hash-reference of options, exactly as with the L + #pod method. + #pod + #pod =cut + + sub _blank_carp { + my ($self, $module) = @_; + Carp::carp("Undefined requirement for $module treated as '0'"); + } + + sub from_string_hash { + my ($class, $hash, $options) = @_; + + my $self = $class->new($options); + + for my $module (keys %$hash) { + my $req = $hash->{$module}; + unless ( defined $req && length $req ) { + $req = 0; + $class->_blank_carp($module); + } + $self->add_string_requirement($module, $req); + } + + return $self; + } + + ############################################################## + + { + package + CPAN::Meta::Requirements::_Range::Exact; + sub _new { bless { version => $_[1] } => $_[0] } + + sub _accepts { return $_[0]{version} == $_[1] } + + sub as_string { return "== $_[0]{version}" } + + sub as_modifiers { return [ [ exact_version => $_[0]{version} ] ] } + + sub _clone { + (ref $_[0])->_new( version->new( $_[0]{version} ) ) + } + + sub with_exact_version { + my ($self, $version) = @_; + + return $self->_clone if $self->_accepts($version); + + Carp::confess("illegal requirements: unequal exact version specified"); + } + + sub with_minimum { + my ($self, $minimum) = @_; + return $self->_clone if $self->{version} >= $minimum; + Carp::confess("illegal requirements: minimum above exact specification"); + } + + sub with_maximum { + my ($self, $maximum) = @_; + return $self->_clone if $self->{version} <= $maximum; + Carp::confess("illegal requirements: maximum below exact specification"); + } + + sub with_exclusion { + my ($self, $exclusion) = @_; + return $self->_clone unless $exclusion == $self->{version}; + Carp::confess("illegal requirements: excluded exact specification"); + } + } + + ############################################################## + + { + package + CPAN::Meta::Requirements::_Range::Range; + + sub _self { ref($_[0]) ? $_[0] : (bless { } => $_[0]) } + + sub _clone { + return (bless { } => $_[0]) unless ref $_[0]; + + my ($s) = @_; + my %guts = ( + (exists $s->{minimum} ? (minimum => version->new($s->{minimum})) : ()), + (exists $s->{maximum} ? (maximum => version->new($s->{maximum})) : ()), + + (exists $s->{exclusions} + ? (exclusions => [ map { version->new($_) } @{ $s->{exclusions} } ]) + : ()), + ); + + bless \%guts => ref($s); + } + + sub as_modifiers { + my ($self) = @_; + my @mods; + push @mods, [ add_minimum => $self->{minimum} ] if exists $self->{minimum}; + push @mods, [ add_maximum => $self->{maximum} ] if exists $self->{maximum}; + push @mods, map {; [ add_exclusion => $_ ] } @{$self->{exclusions} || []}; + return \@mods; + } + + sub as_string { + my ($self) = @_; + + return 0 if ! keys %$self; + + return "$self->{minimum}" if (keys %$self) == 1 and exists $self->{minimum}; + + my @exclusions = @{ $self->{exclusions} || [] }; + + my @parts; + + for my $pair ( + [ qw( >= > minimum ) ], + [ qw( <= < maximum ) ], + ) { + my ($op, $e_op, $k) = @$pair; + if (exists $self->{$k}) { + my @new_exclusions = grep { $_ != $self->{ $k } } @exclusions; + if (@new_exclusions == @exclusions) { + push @parts, "$op $self->{ $k }"; + } else { + push @parts, "$e_op $self->{ $k }"; + @exclusions = @new_exclusions; + } + } + } + + push @parts, map {; "!= $_" } @exclusions; + + return join q{, }, @parts; + } + + sub with_exact_version { + my ($self, $version) = @_; + $self = $self->_clone; + + Carp::confess("illegal requirements: exact specification outside of range") + unless $self->_accepts($version); + + return CPAN::Meta::Requirements::_Range::Exact->_new($version); + } + + sub _simplify { + my ($self) = @_; + + if (defined $self->{minimum} and defined $self->{maximum}) { + if ($self->{minimum} == $self->{maximum}) { + Carp::confess("illegal requirements: excluded all values") + if grep { $_ == $self->{minimum} } @{ $self->{exclusions} || [] }; + + return CPAN::Meta::Requirements::_Range::Exact->_new($self->{minimum}) + } + + Carp::confess("illegal requirements: minimum exceeds maximum") + if $self->{minimum} > $self->{maximum}; + } + + # eliminate irrelevant exclusions + if ($self->{exclusions}) { + my %seen; + @{ $self->{exclusions} } = grep { + (! defined $self->{minimum} or $_ >= $self->{minimum}) + and + (! defined $self->{maximum} or $_ <= $self->{maximum}) + and + ! $seen{$_}++ + } @{ $self->{exclusions} }; + } + + return $self; + } + + sub with_minimum { + my ($self, $minimum) = @_; + $self = $self->_clone; + + if (defined (my $old_min = $self->{minimum})) { + $self->{minimum} = (sort { $b cmp $a } ($minimum, $old_min))[0]; + } else { + $self->{minimum} = $minimum; + } + + return $self->_simplify; + } + + sub with_maximum { + my ($self, $maximum) = @_; + $self = $self->_clone; + + if (defined (my $old_max = $self->{maximum})) { + $self->{maximum} = (sort { $a cmp $b } ($maximum, $old_max))[0]; + } else { + $self->{maximum} = $maximum; + } + + return $self->_simplify; + } + + sub with_exclusion { + my ($self, $exclusion) = @_; + $self = $self->_clone; + + push @{ $self->{exclusions} ||= [] }, $exclusion; + + return $self->_simplify; + } + + sub _accepts { + my ($self, $version) = @_; + + return if defined $self->{minimum} and $version < $self->{minimum}; + return if defined $self->{maximum} and $version > $self->{maximum}; + return if defined $self->{exclusions} + and grep { $version == $_ } @{ $self->{exclusions} }; + + return 1; + } + } + + 1; + # vim: ts=2 sts=2 sw=2 et: + + __END__ + + =pod + + =encoding UTF-8 + + =head1 NAME + + CPAN::Meta::Requirements - a set of version requirements for a CPAN dist + + =head1 VERSION + + version 2.133 + + =head1 SYNOPSIS + + use CPAN::Meta::Requirements; + + my $build_requires = CPAN::Meta::Requirements->new; + + $build_requires->add_minimum('Library::Foo' => 1.208); + + $build_requires->add_minimum('Library::Foo' => 2.602); + + $build_requires->add_minimum('Module::Bar' => 'v1.2.3'); + + $METAyml->{build_requires} = $build_requires->as_string_hash; + + =head1 DESCRIPTION + + A CPAN::Meta::Requirements object models a set of version constraints like + those specified in the F or F files in CPAN distributions, + and as defined by L; + It can be built up by adding more and more constraints, and it will reduce them + to the simplest representation. + + Logically impossible constraints will be identified immediately by thrown + exceptions. + + =head1 METHODS + + =head2 new + + my $req = CPAN::Meta::Requirements->new; + + This returns a new CPAN::Meta::Requirements object. It takes an optional + hash reference argument. Currently, only one key is supported: + + =over 4 + + =item * + + C -- if provided, when a version cannot be parsed into a version object, this code reference will be called with the invalid version string as first argument, and the module name as second argument. It must return a valid version object. + + =back + + All other keys are ignored. + + =head2 add_minimum + + $req->add_minimum( $module => $version ); + + This adds a new minimum version requirement. If the new requirement is + redundant to the existing specification, this has no effect. + + Minimum requirements are inclusive. C<$version> is required, along with any + greater version number. + + This method returns the requirements object. + + =head2 add_maximum + + $req->add_maximum( $module => $version ); + + This adds a new maximum version requirement. If the new requirement is + redundant to the existing specification, this has no effect. + + Maximum requirements are inclusive. No version strictly greater than the given + version is allowed. + + This method returns the requirements object. + + =head2 add_exclusion + + $req->add_exclusion( $module => $version ); + + This adds a new excluded version. For example, you might use these three + method calls: + + $req->add_minimum( $module => '1.00' ); + $req->add_maximum( $module => '1.82' ); + + $req->add_exclusion( $module => '1.75' ); + + Any version between 1.00 and 1.82 inclusive would be acceptable, except for + 1.75. + + This method returns the requirements object. + + =head2 exact_version + + $req->exact_version( $module => $version ); + + This sets the version required for the given module to I the given + version. No other version would be considered acceptable. + + This method returns the requirements object. + + =head2 add_requirements + + $req->add_requirements( $another_req_object ); + + This method adds all the requirements in the given CPAN::Meta::Requirements object + to the requirements object on which it was called. If there are any conflicts, + an exception is thrown. + + This method returns the requirements object. + + =head2 accepts_module + + my $bool = $req->accepts_module($module => $version); + + Given an module and version, this method returns true if the version + specification for the module accepts the provided version. In other words, + given: + + Module => '>= 1.00, < 2.00' + + We will accept 1.00 and 1.75 but not 0.50 or 2.00. + + For modules that do not appear in the requirements, this method will return + true. + + =head2 clear_requirement + + $req->clear_requirement( $module ); + + This removes the requirement for a given module from the object. + + This method returns the requirements object. + + =head2 requirements_for_module + + $req->requirements_for_module( $module ); + + This returns a string containing the version requirements for a given module in + the format described in L or undef if the given module has no + requirements. This should only be used for informational purposes such as error + messages and should not be interpreted or used for comparison (see + L instead.) + + =head2 required_modules + + This method returns a list of all the modules for which requirements have been + specified. + + =head2 clone + + $req->clone; + + This method returns a clone of the invocant. The clone and the original object + can then be changed independent of one another. + + =head2 is_simple + + This method returns true if and only if all requirements are inclusive minimums + -- that is, if their string expression is just the version number. + + =head2 is_finalized + + This method returns true if the requirements have been finalized by having the + C method called on them. + + =head2 finalize + + This method marks the requirements finalized. Subsequent attempts to change + the requirements will be fatal, I they would result in a change. If they + would not alter the requirements, they have no effect. + + If a finalized set of requirements is cloned, the cloned requirements are not + also finalized. + + =head2 as_string_hash + + This returns a reference to a hash describing the requirements using the + strings in the L specification. + + For example after the following program: + + my $req = CPAN::Meta::Requirements->new; + + $req->add_minimum('CPAN::Meta::Requirements' => 0.102); + + $req->add_minimum('Library::Foo' => 1.208); + + $req->add_maximum('Library::Foo' => 2.602); + + $req->add_minimum('Module::Bar' => 'v1.2.3'); + + $req->add_exclusion('Module::Bar' => 'v1.2.8'); + + $req->exact_version('Xyzzy' => '6.01'); + + my $hashref = $req->as_string_hash; + + C<$hashref> would contain: + + { + 'CPAN::Meta::Requirements' => '0.102', + 'Library::Foo' => '>= 1.208, <= 2.206', + 'Module::Bar' => '>= v1.2.3, != v1.2.8', + 'Xyzzy' => '== 6.01', + } + + =head2 add_string_requirement + + $req->add_string_requirement('Library::Foo' => '>= 1.208, <= 2.206'); + $req->add_string_requirement('Library::Foo' => v1.208); + + This method parses the passed in string and adds the appropriate requirement + for the given module. A version can be a Perl "v-string". It understands + version ranges as described in the L. For + example: + + =over 4 + + =item 1.3 + + =item >= 1.3 + + =item <= 1.3 + + =item == 1.3 + + =item != 1.3 + + =item > 1.3 + + =item < 1.3 + + =item >= 1.3, != 1.5, <= 2.0 + + A version number without an operator is equivalent to specifying a minimum + (C=>). Extra whitespace is allowed. + + =back + + =head2 from_string_hash + + my $req = CPAN::Meta::Requirements->from_string_hash( \%hash ); + my $req = CPAN::Meta::Requirements->from_string_hash( \%hash, \%opts ); + + This is an alternate constructor for a CPAN::Meta::Requirements + object. It takes a hash of module names and version requirement + strings and returns a new CPAN::Meta::Requirements object. As with + add_string_requirement, a version can be a Perl "v-string". Optionally, + you can supply a hash-reference of options, exactly as with the L + method. + + =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan + + =head1 SUPPORT + + =head2 Bugs / Feature Requests + + Please report any bugs or feature requests through the issue tracker + at L. + You will be notified automatically of any progress on your issue. + + =head2 Source Code + + This is open source software. The code repository is available for + public review and contribution under the terms of the license. + + L + + git clone https://github.com/dagolden/CPAN-Meta-Requirements.git + + =head1 AUTHORS + + =over 4 + + =item * + + David Golden + + =item * + + Ricardo Signes + + =back + + =head1 CONTRIBUTORS + + =for stopwords Ed J Karen Etheridge Leon Timmermans robario + + =over 4 + + =item * + + Ed J + + =item * + + Karen Etheridge + + =item * + + Leon Timmermans + + =item * + + robario + + =back + + =head1 COPYRIGHT AND LICENSE + + This software is copyright (c) 2010 by David Golden and Ricardo Signes. + + This is free software; you can redistribute it and/or modify it under + the same terms as the Perl 5 programming language system itself. + + =cut + CPAN_META_REQUIREMENTS + + $fatpacked{"CPAN/Meta/Spec.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_SPEC'; + # XXX RULES FOR PATCHING THIS FILE XXX + # Patches that fix typos or formatting are acceptable. Patches + # that change semantics are not acceptable without prior approval + # by David Golden or Ricardo Signes. + + use 5.006; + use strict; + use warnings; + package CPAN::Meta::Spec; + + our $VERSION = '2.150005'; + + 1; + + # ABSTRACT: specification for CPAN distribution metadata + + + # vi:tw=72 + + __END__ + + =pod + + =encoding UTF-8 + + =head1 NAME + + CPAN::Meta::Spec - specification for CPAN distribution metadata + + =head1 VERSION + + version 2.150005 + + =head1 SYNOPSIS + + my $distmeta = { + name => 'Module-Build', + abstract => 'Build and install Perl modules', + description => "Module::Build is a system for " + . "building, testing, and installing Perl modules. " + . "It is meant to ... blah blah blah ...", + version => '0.36', + release_status => 'stable', + author => [ + 'Ken Williams ', + 'Module-Build List ', # additional contact + ], + license => [ 'perl_5' ], + prereqs => { + runtime => { + requires => { + 'perl' => '5.006', + 'ExtUtils::Install' => '0', + 'File::Basename' => '0', + 'File::Compare' => '0', + 'IO::File' => '0', + }, + recommends => { + 'Archive::Tar' => '1.00', + 'ExtUtils::Install' => '0.3', + 'ExtUtils::ParseXS' => '2.02', + }, + }, + build => { + requires => { + 'Test::More' => '0', + }, + } + }, + resources => { + license => ['http://dev.perl.org/licenses/'], + }, + optional_features => { + domination => { + description => 'Take over the world', + prereqs => { + develop => { requires => { 'Genius::Evil' => '1.234' } }, + runtime => { requires => { 'Machine::Weather' => '2.0' } }, + }, + }, + }, + dynamic_config => 1, + keywords => [ qw/ toolchain cpan dual-life / ], + 'meta-spec' => { + version => '2', + url => 'https://metacpan.org/pod/CPAN::Meta::Spec', + }, + generated_by => 'Module::Build version 0.36', + }; + + =head1 DESCRIPTION + + This document describes version 2 of the CPAN distribution metadata + specification, also known as the "CPAN Meta Spec". + + Revisions of this specification for typo corrections and prose + clarifications may be issued as CPAN::Meta::Spec 2.I. These + revisions will never change semantics or add or remove specified + behavior. + + Distribution metadata describe important properties of Perl + distributions. Distribution building tools like Module::Build, + Module::Install, ExtUtils::MakeMaker or Dist::Zilla should create a + metadata file in accordance with this specification and include it with + the distribution for use by automated tools that index, examine, package + or install Perl distributions. + + =head1 TERMINOLOGY + + =over 4 + + =item distribution + + This is the primary object described by the metadata. In the context of + this document it usually refers to a collection of modules, scripts, + and/or documents that are distributed together for other developers to + use. Examples of distributions are C, C, + or C. + + =item module + + This refers to a reusable library of code contained in a single file. + Modules usually contain one or more packages and are often referred + to by the name of a primary package that can be mapped to the file + name. For example, one might refer to C instead of + F + + =item package + + This refers to a namespace declared with the Perl C statement. + In Perl, packages often have a version number property given by the + C<$VERSION> variable in the namespace. + + =item consumer + + This refers to code that reads a metadata file, deserializes it into a + data structure in memory, or interprets a data structure of metadata + elements. + + =item producer + + This refers to code that constructs a metadata data structure, + serializes into a bytestream and/or writes it to disk. + + =item must, should, may, etc. + + These terms are interpreted as described in IETF RFC 2119. + + =back + + =head1 DATA TYPES + + Fields in the L section describe data elements, each of + which has an associated data type as described herein. There are four + primitive types: Boolean, String, List and Map. Other types are + subtypes of primitives and define compound data structures or define + constraints on the values of a data element. + + =head2 Boolean + + A I is used to provide a true or false value. It B be + represented as a defined value. + + =head2 String + + A I is data element containing a non-zero length sequence of + Unicode characters, such as an ordinary Perl scalar that is not a + reference. + + =head2 List + + A I is an ordered collection of zero or more data elements. + Elements of a List may be of mixed types. + + Producers B represent List elements using a data structure which + unambiguously indicates that multiple values are possible, such as a + reference to a Perl array (an "arrayref"). + + Consumers expecting a List B consider a String as equivalent to a + List of length 1. + + =head2 Map + + A I is an unordered collection of zero or more data elements + ("values"), indexed by associated String elements ("keys"). The Map's + value elements may be of mixed types. + + =head2 License String + + A I is a subtype of String with a restricted set of + values. Valid values are described in detail in the description of + the L field. + + =head2 URL + + I is a subtype of String containing a Uniform Resource Locator or + Identifier. [ This type is called URL and not URI for historical reasons. ] + + =head2 Version + + A I is a subtype of String containing a value that describes + the version number of packages or distributions. Restrictions on format + are described in detail in the L section. + + =head2 Version Range + + The I type is a subtype of String. It describes a range + of Versions that may be present or installed to fulfill prerequisites. + It is specified in detail in the L section. + + =head1 STRUCTURE + + The metadata structure is a data element of type Map. This section + describes valid keys within the Map. + + Any keys not described in this specification document (whether top-level + or within compound data structures described herein) are considered + I and B begin with an "x" or "X" and be followed by an + underscore; i.e. they must match the pattern: C<< qr{\Ax_}i >>. If a + custom key refers to a compound data structure, subkeys within it do not + need an "x_" or "X_" prefix. + + Consumers of metadata may ignore any or all custom keys. All other keys + not described herein are invalid and should be ignored by consumers. + Producers must not generate or output invalid keys. + + For each key, an example is provided followed by a description. The + description begins with the version of spec in which the key was added + or in which the definition was modified, whether the key is I + or I and the data type of the corresponding data element. + These items are in parentheses, brackets and braces, respectively. + + If a data type is a Map or Map subtype, valid subkeys will be described + as well. + + Some fields are marked I. These are shown for historical + context and must not be produced in or consumed from any metadata structure + of version 2 or higher. + + =head2 REQUIRED FIELDS + + =head3 abstract + + Example: + + abstract => 'Build and install Perl modules' + + (Spec 1.2) [required] {String} + + This is a short description of the purpose of the distribution. + + =head3 author + + Example: + + author => [ 'Ken Williams ' ] + + (Spec 1.2) [required] {List of one or more Strings} + + This List indicates the person(s) to contact concerning the + distribution. The preferred form of the contact string is: + + contact-name + + This field provides a general contact list independent of other + structured fields provided within the L field, such as + C. The addressee(s) can be contacted for any purpose + including but not limited to (security) problems with the distribution, + questions about the distribution or bugs in the distribution. + + A distribution's original author is usually the contact listed within + this field. Co-maintainers, successor maintainers or mailing lists + devoted to the distribution may also be listed in addition to or instead + of the original author. + + =head3 dynamic_config + + Example: + + dynamic_config => 1 + + (Spec 2) [required] {Boolean} + + A boolean flag indicating whether a F or F (or + similar) must be executed to determine prerequisites. + + This field should be set to a true value if the distribution performs + some dynamic configuration (asking questions, sensing the environment, + etc.) as part of its configuration. This field should be set to a false + value to indicate that prerequisites included in metadata may be + considered final and valid for static analysis. + + Note: when this field is true, post-configuration prerequisites are not + guaranteed to bear any relation whatsoever to those stated in the metadata, + and relying on them doing so is an error. See also + L in the implementors' + notes. + + This field explicitly B indicate whether installation may be + safely performed without using a Makefile or Build file, as there may be + special files to install or custom installation targets (e.g. for + dual-life modules that exist on CPAN as well as in the Perl core). This + field only defines whether or not prerequisites are exactly as given in the + metadata. + + =head3 generated_by + + Example: + + generated_by => 'Module::Build version 0.36' + + (Spec 1.0) [required] {String} + + This field indicates the tool that was used to create this metadata. + There are no defined semantics for this field, but it is traditional to + use a string in the form "Generating::Package version 1.23" or the + author's name, if the file was generated by hand. + + =head3 license + + Example: + + license => [ 'perl_5' ] + + license => [ 'apache_2_0', 'mozilla_1_0' ] + + (Spec 2) [required] {List of one or more License Strings} + + One or more licenses that apply to some or all of the files in the + distribution. If multiple licenses are listed, the distribution + documentation should be consulted to clarify the interpretation of + multiple licenses. + + The following list of license strings are valid: + + string description + ------------- ----------------------------------------------- + agpl_3 GNU Affero General Public License, Version 3 + apache_1_1 Apache Software License, Version 1.1 + apache_2_0 Apache License, Version 2.0 + artistic_1 Artistic License, (Version 1) + artistic_2 Artistic License, Version 2.0 + bsd BSD License (three-clause) + freebsd FreeBSD License (two-clause) + gfdl_1_2 GNU Free Documentation License, Version 1.2 + gfdl_1_3 GNU Free Documentation License, Version 1.3 + gpl_1 GNU General Public License, Version 1 + gpl_2 GNU General Public License, Version 2 + gpl_3 GNU General Public License, Version 3 + lgpl_2_1 GNU Lesser General Public License, Version 2.1 + lgpl_3_0 GNU Lesser General Public License, Version 3.0 + mit MIT (aka X11) License + mozilla_1_0 Mozilla Public License, Version 1.0 + mozilla_1_1 Mozilla Public License, Version 1.1 + openssl OpenSSL License + perl_5 The Perl 5 License (Artistic 1 & GPL 1 or later) + qpl_1_0 Q Public License, Version 1.0 + ssleay Original SSLeay License + sun Sun Internet Standards Source License (SISSL) + zlib zlib License + + The following license strings are also valid and indicate other + licensing not described above: + + string description + ------------- ----------------------------------------------- + open_source Other Open Source Initiative (OSI) approved license + restricted Requires special permission from copyright holder + unrestricted Not an OSI approved license, but not restricted + unknown License not provided in metadata + + All other strings are invalid in the license field. + + =head3 meta-spec + + Example: + + 'meta-spec' => { + version => '2', + url => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec', + } + + (Spec 1.2) [required] {Map} + + This field indicates the version of the CPAN Meta Spec that should be + used to interpret the metadata. Consumers must check this key as soon + as possible and abort further metadata processing if the meta-spec + version is not supported by the consumer. + + The following keys are valid, but only C is required. + + =over + + =item version + + This subkey gives the integer I of the CPAN Meta Spec against + which the document was generated. + + =item url + + This is a I of the metadata specification document corresponding to + the given version. This is strictly for human-consumption and should + not impact the interpretation of the document. + + For the version 2 spec, either of these are recommended: + + =over 4 + + =item * + + C + + =item * + + C + + =back + + =back + + =head3 name + + Example: + + name => 'Module-Build' + + (Spec 1.0) [required] {String} + + This field is the name of the distribution. This is often created by + taking the "main package" in the distribution and changing C<::> to + C<->, but the name may be completely unrelated to the packages within + the distribution. For example, L is distributed as part + of the distribution name "libwww-perl". + + =head3 release_status + + Example: + + release_status => 'stable' + + (Spec 2) [required] {String} + + This field provides the release status of this distribution. If the + C field contains an underscore character, then + C B be "stable." + + The C field B have one of the following values: + + =over + + =item stable + + This indicates an ordinary, "final" release that should be indexed by PAUSE + or other indexers. + + =item testing + + This indicates a "beta" release that is substantially complete, but has an + elevated risk of bugs and requires additional testing. The distribution + should not be installed over a stable release without an explicit request + or other confirmation from a user. This release status may also be used + for "release candidate" versions of a distribution. + + =item unstable + + This indicates an "alpha" release that is under active development, but has + been released for early feedback or testing and may be missing features or + may have serious bugs. The distribution should not be installed over a + stable release without an explicit request or other confirmation from a + user. + + =back + + Consumers B use this field to determine how to index the + distribution for CPAN or other repositories in addition to or in + replacement of heuristics based on version number or file name. + + =head3 version + + Example: + + version => '0.36' + + (Spec 1.0) [required] {Version} + + This field gives the version of the distribution to which the metadata + structure refers. + + =head2 OPTIONAL FIELDS + + =head3 description + + Example: + + description => "Module::Build is a system for " + . "building, testing, and installing Perl modules. " + . "It is meant to ... blah blah blah ...", + + (Spec 2) [optional] {String} + + A longer, more complete description of the purpose or intended use of + the distribution than the one provided by the C key. + + =head3 keywords + + Example: + + keywords => [ qw/ toolchain cpan dual-life / ] + + (Spec 1.1) [optional] {List of zero or more Strings} + + A List of keywords that describe this distribution. Keywords + B include whitespace. + + =head3 no_index + + Example: + + no_index => { + file => [ 'My/Module.pm' ], + directory => [ 'My/Private' ], + package => [ 'My::Module::Secret' ], + namespace => [ 'My::Module::Sample' ], + } + + (Spec 1.2) [optional] {Map} + + This Map describes any files, directories, packages, and namespaces that + are private to the packaging or implementation of the distribution and + should be ignored by indexing or search tools. Note that this is a list of + exclusions, and the spec does not define what to I - see + L in the implementors notes for more + information. + + Valid subkeys are as follows: + + =over + + =item file + + A I of relative paths to files. Paths B specified with + unix conventions. + + =item directory + + A I of relative paths to directories. Paths B specified + with unix conventions. + + [ Note: previous editions of the spec had C instead of C ] + + =item package + + A I of package names. + + =item namespace + + A I of package namespaces, where anything below the namespace + must be ignored, but I the namespace itself. + + In the example above for C, C would + be ignored, but C would not. + + =back + + =head3 optional_features + + Example: + + optional_features => { + sqlite => { + description => 'Provides SQLite support', + prereqs => { + runtime => { + requires => { + 'DBD::SQLite' => '1.25' + } + } + } + } + } + + (Spec 2) [optional] {Map} + + This Map describes optional features with incremental prerequisites. + Each key of the C Map is a String used to identify + the feature and each value is a Map with additional information about + the feature. Valid subkeys include: + + =over + + =item description + + This is a String describing the feature. Every optional feature + should provide a description + + =item prereqs + + This entry is required and has the same structure as that of the + C> key. It provides a list of package requirements + that must be satisfied for the feature to be supported or enabled. + + There is one crucial restriction: the prereqs of an optional feature + B include C phase prereqs. + + =back + + Consumers B include optional features as prerequisites without + explicit instruction from users (whether via interactive prompting, + a function parameter or a configuration value, etc. ). + + If an optional feature is used by a consumer to add additional + prerequisites, the consumer should merge the optional feature + prerequisites into those given by the C key using the same + semantics. See L for details on + merging prerequisites. + + I Because there is currently no way for a + distribution to specify a dependency on an optional feature of another + dependency, the use of C is discouraged. Instead, + create a separate, installable distribution that ensures the desired + feature is available. For example, if C has a C feature, + release a separate C distribution that satisfies + requirements for the feature. + + =head3 prereqs + + Example: + + prereqs => { + runtime => { + requires => { + 'perl' => '5.006', + 'File::Spec' => '0.86', + 'JSON' => '2.16', + }, + recommends => { + 'JSON::XS' => '2.26', + }, + suggests => { + 'Archive::Tar' => '0', + }, + }, + build => { + requires => { + 'Alien::SDL' => '1.00', + }, + }, + test => { + recommends => { + 'Test::Deep' => '0.10', + }, + } + } + + (Spec 2) [optional] {Map} + + This is a Map that describes all the prerequisites of the distribution. + The keys are phases of activity, such as C, C, C + or C. Values are Maps in which the keys name the type of + prerequisite relationship such as C, C, or + C and the value provides a set of prerequisite relations. The + set of relations B be specified as a Map of package names to + version ranges. + + The full definition for this field is given in the L + section. + + =head3 provides + + Example: + + provides => { + 'Foo::Bar' => { + file => 'lib/Foo/Bar.pm', + version => '0.27_02', + }, + 'Foo::Bar::Blah' => { + file => 'lib/Foo/Bar/Blah.pm', + }, + 'Foo::Bar::Baz' => { + file => 'lib/Foo/Bar/Baz.pm', + version => '0.3', + }, + } + + (Spec 1.2) [optional] {Map} + + This describes all packages provided by this distribution. This + information is used by distribution and automation mechanisms like + PAUSE, CPAN, metacpan.org and search.cpan.org to build indexes saying in + which distribution various packages can be found. + + The keys of C are package names that can be found within + the distribution. If a package name key is provided, it must + have a Map with the following valid subkeys: + + =over + + =item file + + This field is required. It must contain a Unix-style relative file path + from the root of the distribution directory to a file that contains or + generates the package. It may be given as C or C + to claim a package for indexing without needing a C<*.pm>. + + =item version + + If it exists, this field must contains a I String for the + package. If the package does not have a C<$VERSION>, this field must + be omitted. + + =back + + =head3 resources + + Example: + + resources => { + license => [ 'http://dev.perl.org/licenses/' ], + homepage => 'http://sourceforge.net/projects/module-build', + bugtracker => { + web => 'http://rt.cpan.org/Public/Dist/Display.html?Name=CPAN-Meta', + mailto => 'meta-bugs@example.com', + }, + repository => { + url => 'git://github.com/dagolden/cpan-meta.git', + web => 'http://github.com/dagolden/cpan-meta', + type => 'git', + }, + x_twitter => 'http://twitter.com/cpan_linked/', + } + + (Spec 2) [optional] {Map} + + This field describes resources related to this distribution. + + Valid subkeys include: + + =over + + =item homepage + + The official home of this project on the web. + + =item license + + A List of I's that relate to this distribution's license. As with the + top-level C field, distribution documentation should be consulted + to clarify the interpretation of multiple licenses provided here. + + =item bugtracker + + This entry describes the bug tracking system for this distribution. It + is a Map with the following valid keys: + + web - a URL pointing to a web front-end for the bug tracker + mailto - an email address to which bugs can be sent + + =item repository + + This entry describes the source control repository for this distribution. It + is a Map with the following valid keys: + + url - a URL pointing to the repository itself + web - a URL pointing to a web front-end for the repository + type - a lowercase string indicating the VCS used + + Because a url like C is ambiguous as to + type, producers should provide a C whenever a C key is given. + The C field should be the name of the most common program used + to work with the repository, e.g. C, C, C, C, + C or C. + + =back + + =head2 DEPRECATED FIELDS + + =head3 build_requires + + I<(Deprecated in Spec 2)> [optional] {String} + + Replaced by C + + =head3 configure_requires + + I<(Deprecated in Spec 2)> [optional] {String} + + Replaced by C + + =head3 conflicts + + I<(Deprecated in Spec 2)> [optional] {String} + + Replaced by C + + =head3 distribution_type + + I<(Deprecated in Spec 2)> [optional] {String} + + This field indicated 'module' or 'script' but was considered + meaningless, since many distributions are hybrids of several kinds of + things. + + =head3 license_uri + + I<(Deprecated in Spec 1.2)> [optional] {URL} + + Replaced by C in C + + =head3 private + + I<(Deprecated in Spec 1.2)> [optional] {Map} + + This field has been renamed to L. + + =head3 recommends + + I<(Deprecated in Spec 2)> [optional] {String} + + Replaced by C + + =head3 requires + + I<(Deprecated in Spec 2)> [optional] {String} + + Replaced by C + + =head1 VERSION NUMBERS + + =head2 Version Formats + + This section defines the Version type, used by several fields in the + CPAN Meta Spec. + + Version numbers must be treated as strings, not numbers. For + example, C<1.200> B be serialized as C<1.2>. Version + comparison should be delegated to the Perl L module, version + 0.80 or newer. + + Unless otherwise specified, version numbers B appear in one of two + formats: + + =over + + =item Decimal versions + + Decimal versions are regular "decimal numbers", with some limitations. + They B be non-negative and B begin and end with a digit. A + single underscore B be included, but B be between two digits. + They B use exponential notation ("1.23e-2"). + + version => '1.234' # OK + version => '1.23_04' # OK + + version => '1.23_04_05' # Illegal + version => '1.' # Illegal + version => '.1' # Illegal + + =item Dotted-integer versions + + Dotted-integer (also known as dotted-decimal) versions consist of + positive integers separated by full stop characters (i.e. "dots", + "periods" or "decimal points"). This are equivalent in format to Perl + "v-strings", with some additional restrictions on form. They must be + given in "normal" form, which has a leading "v" character and at least + three integer components. To retain a one-to-one mapping with decimal + versions, all components after the first B be restricted to the + range 0 to 999. The final component B be separated by an + underscore character instead of a period. + + version => 'v1.2.3' # OK + version => 'v1.2_3' # OK + version => 'v1.2.3.4' # OK + version => 'v1.2.3_4' # OK + version => 'v2009.10.31' # OK + + version => 'v1.2' # Illegal + version => '1.2.3' # Illegal + version => 'v1.2_3_4' # Illegal + version => 'v1.2009.10.31' # Not recommended + + =back + + =head2 Version Ranges + + Some fields (prereq, optional_features) indicate the particular + version(s) of some other module that may be required as a prerequisite. + This section details the Version Range type used to provide this + information. + + The simplest format for a Version Range is just the version + number itself, e.g. C<2.4>. This means that B version 2.4 + must be present. To indicate that B version of a prerequisite is + okay, even if the prerequisite doesn't define a version at all, use + the version C<0>. + + Alternatively, a version range B use the operators E (less than), + E= (less than or equal), E (greater than), E= (greater than + or equal), == (equal), and != (not equal). For example, the + specification C 2.0> means that any version of the prerequisite + less than 2.0 is suitable. + + For more complicated situations, version specifications B be AND-ed + together using commas. The specification C= 1.2, != 1.5, E + 2.0> indicates a version that must be B 1.2, B 2.0, + and B 1.5. + + =head1 PREREQUISITES + + =head2 Prereq Spec + + The C key in the top-level metadata and within + C define the relationship between a distribution and + other packages. The prereq spec structure is a hierarchical data + structure which divides prerequisites into I of activity in the + installation process and I that indicate how + prerequisites should be resolved. + + For example, to specify that C is C during the + C phase, this entry would appear in the distribution metadata: + + prereqs => { + test => { + requires => { + 'Data::Dumper' => '2.00' + } + } + } + + =head3 Phases + + Requirements for regular use must be listed in the C phase. + Other requirements should be listed in the earliest stage in which they + are required and consumers must accumulate and satisfy requirements + across phases before executing the activity. For example, C + requirements must also be available during the C phase. + + before action requirements that must be met + ---------------- -------------------------------- + perl Build.PL configure + perl Makefile.PL + + make configure, runtime, build + Build + + make test configure, runtime, build, test + Build test + + Consumers that install the distribution must ensure that + I requirements are also installed and may install + dependencies from other phases. + + after action requirements that must be met + ---------------- -------------------------------- + make install runtime + Build install + + =over + + =item configure + + The configure phase occurs before any dynamic configuration has been + attempted. Libraries required by the configure phase B be + available for use before the distribution building tool has been + executed. + + =item build + + The build phase is when the distribution's source code is compiled (if + necessary) and otherwise made ready for installation. + + =item test + + The test phase is when the distribution's automated test suite is run. + Any library that is needed only for testing and not for subsequent use + should be listed here. + + =item runtime + + The runtime phase refers not only to when the distribution's contents + are installed, but also to its continued use. Any library that is a + prerequisite for regular use of this distribution should be indicated + here. + + =item develop + + The develop phase's prereqs are libraries needed to work on the + distribution's source code as its author does. These tools might be + needed to build a release tarball, to run author-only tests, or to + perform other tasks related to developing new versions of the + distribution. + + =back + + =head3 Relationships + + =over + + =item requires + + These dependencies B be installed for proper completion of the + phase. + + =item recommends + + Recommended dependencies are I encouraged and should be + satisfied except in resource constrained environments. + + =item suggests + + These dependencies are optional, but are suggested for enhanced operation + of the described distribution. + + =item conflicts + + These libraries cannot be installed when the phase is in operation. + This is a very rare situation, and the C relationship should + be used with great caution, or not at all. + + =back + + =head2 Merging and Resolving Prerequisites + + Whenever metadata consumers merge prerequisites, either from different + phases or from C, they should merged in a way which + preserves the intended semantics of the prerequisite structure. Generally, + this means concatenating the version specifications using commas, as + described in the L section. + + Another subtle error that can occur in resolving prerequisites comes from + the way that modules in prerequisites are indexed to distribution files on + CPAN. When a module is deleted from a distribution, prerequisites calling + for that module could indicate an older distribution should be installed, + potentially overwriting files from a newer distribution. + + For example, as of Oct 31, 2009, the CPAN index file contained these + module-distribution mappings: + + Class::MOP 0.94 D/DR/DROLSKY/Class-MOP-0.94.tar.gz + Class::MOP::Class 0.94 D/DR/DROLSKY/Class-MOP-0.94.tar.gz + Class::MOP::Class::Immutable 0.04 S/ST/STEVAN/Class-MOP-0.36.tar.gz + + Consider the case where "Class::MOP" 0.94 is installed. If a + distribution specified "Class::MOP::Class::Immutable" as a prerequisite, + it could result in Class-MOP-0.36.tar.gz being installed, overwriting + any files from Class-MOP-0.94.tar.gz. + + Consumers of metadata B test whether prerequisites would result + in installed module files being "downgraded" to an older version and + B warn users or ignore the prerequisite that would cause such a + result. + + =head1 SERIALIZATION + + Distribution metadata should be serialized (as a hashref) as + JSON-encoded data and packaged with distributions as the file + F. + + In the past, the distribution metadata structure had been packed with + distributions as F, a file in the YAML Tiny format (for which, + see L). Tools that consume distribution metadata from disk + should be capable of loading F, but should prefer F + if both are found. + + =head1 NOTES FOR IMPLEMENTORS + + =head2 Extracting Version Numbers from Perl Modules + + To get the version number from a Perl module, consumers should use the + C<< MM->parse_version($file) >> method provided by + L or L. For example, for the + module given by C<$mod>, the version may be retrieved in one of the + following ways: + + # via ExtUtils::MakeMaker + my $file = MM->_installed_file_for_module($mod); + my $version = MM->parse_version($file) + + The private C<_installed_file_for_module> method may be replaced with + other methods for locating a module in C<@INC>. + + # via Module::Metadata + my $info = Module::Metadata->new_from_module($mod); + my $version = $info->version; + + If only a filename is available, the following approach may be used: + + # via Module::Build + my $info = Module::Metadata->new_from_file($file); + my $version = $info->version; + + =head2 Comparing Version Numbers + + The L module provides the most reliable way to compare version + numbers in all the various ways they might be provided or might exist + within modules. Given two strings containing version numbers, C<$v1> and + C<$v2>, they should be converted to C objects before using + ordinary comparison operators. For example: + + use version; + if ( version->new($v1) <=> version->new($v2) ) { + print "Versions are not equal\n"; + } + + If the only comparison needed is whether an installed module is of a + sufficiently high version, a direct test may be done using the string + form of C and the C function. For example, for module C<$mod> + and version prerequisite C<$prereq>: + + if ( eval "use $mod $prereq (); 1" ) { + print "Module $mod version is OK.\n"; + } + + If the values of C<$mod> and C<$prereq> have not been scrubbed, however, + this presents security implications. + + =head2 Prerequisites for dynamically configured distributions + + When C is true, it is an error to presume that the + prerequisites given in distribution metadata will have any relationship + whatsoever to the actual prerequisites of the distribution. + + In practice, however, one can generally expect such prerequisites to be + one of two things: + + =over 4 + + =item * + + The minimum prerequisites for the distribution, to which dynamic configuration will only add items + + =item * + + Whatever the distribution configured with on the releaser's machine at release time + + =back + + The second case often turns out to have identical results to the first case, + albeit only by accident. + + As such, consumers may use this data for informational analysis, but + presenting it to the user as canonical or relying on it as such is + invariably the height of folly. + + =head2 Indexing distributions a la PAUSE + + While no_index tells you what must be ignored when indexing, this spec holds + no opinion on how you should get your initial candidate list of things to + possibly index. For "normal" distributions you might consider simply indexing + the contents of lib/, but there are many fascinating oddities on CPAN and + many dists from the days when it was normal to put the main .pm file in the + root of the distribution archive - so PAUSE currently indexes all .pm and .PL + files that are not either (a) specifically excluded by no_index (b) in + C, C, or C directories, or common 'mistake' directories such as + C. + + Or: If you're trying to be PAUSE-like, make sure you skip C, C and + C as well as anything marked as no_index. + + Also remember: If the META file contains a provides field, you shouldn't be + indexing anything in the first place - just use that. + + =head1 SEE ALSO + + =over 4 + + =item * + + CPAN, L + + =item * + + JSON, L + + =item * + + YAML, L + + =item * + + L + + =item * + + L + + =item * + + L + + =item * + + L + + =item * + + L + + =back + + =head1 HISTORY + + Ken Williams wrote the original CPAN Meta Spec (also known as the + "META.yml spec") in 2003 and maintained it through several revisions + with input from various members of the community. In 2005, Randy + Sims redrafted it from HTML to POD for the version 1.2 release. Ken + continued to maintain the spec through version 1.4. + + In late 2009, David Golden organized the version 2 proposal review + process. David and Ricardo Signes drafted the final version 2 spec + in April 2010 based on the version 1.4 spec and patches contributed + during the proposal process. + + =head1 AUTHORS + + =over 4 + + =item * + + David Golden + + =item * + + Ricardo Signes + + =back + + =head1 COPYRIGHT AND LICENSE + + This software is copyright (c) 2010 by David Golden and Ricardo Signes. + + This is free software; you can redistribute it and/or modify it under + the same terms as the Perl 5 programming language system itself. + + =cut + CPAN_META_SPEC + + $fatpacked{"CPAN/Meta/Validator.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_VALIDATOR'; + use 5.006; + use strict; + use warnings; + package CPAN::Meta::Validator; + + our $VERSION = '2.150005'; + + #pod =head1 SYNOPSIS + #pod + #pod my $struct = decode_json_file('META.json'); + #pod + #pod my $cmv = CPAN::Meta::Validator->new( $struct ); + #pod + #pod unless ( $cmv->is_valid ) { + #pod my $msg = "Invalid META structure. Errors found:\n"; + #pod $msg .= join( "\n", $cmv->errors ); + #pod die $msg; + #pod } + #pod + #pod =head1 DESCRIPTION + #pod + #pod This module validates a CPAN Meta structure against the version of the + #pod the specification claimed in the C field of the structure. + #pod + #pod =cut + + #--------------------------------------------------------------------------# + # This code copied and adapted from Test::CPAN::Meta + # by Barbie, for Miss Barbell Productions, + # L + #--------------------------------------------------------------------------# + + #--------------------------------------------------------------------------# + # Specification Definitions + #--------------------------------------------------------------------------# + + my %known_specs = ( + '1.4' => 'http://module-build.sourceforge.net/META-spec-v1.4.html', + '1.3' => 'http://module-build.sourceforge.net/META-spec-v1.3.html', + '1.2' => 'http://module-build.sourceforge.net/META-spec-v1.2.html', + '1.1' => 'http://module-build.sourceforge.net/META-spec-v1.1.html', + '1.0' => 'http://module-build.sourceforge.net/META-spec-v1.0.html' + ); + my %known_urls = map {$known_specs{$_} => $_} keys %known_specs; + + my $module_map1 = { 'map' => { ':key' => { name => \&module, value => \&exversion } } }; + + my $module_map2 = { 'map' => { ':key' => { name => \&module, value => \&version } } }; + + my $no_index_2 = { + 'map' => { file => { list => { value => \&string } }, + directory => { list => { value => \&string } }, + 'package' => { list => { value => \&string } }, + namespace => { list => { value => \&string } }, + ':key' => { name => \&custom_2, value => \&anything }, + } + }; + + my $no_index_1_3 = { + 'map' => { file => { list => { value => \&string } }, + directory => { list => { value => \&string } }, + 'package' => { list => { value => \&string } }, + namespace => { list => { value => \&string } }, + ':key' => { name => \&string, value => \&anything }, + } + }; + + my $no_index_1_2 = { + 'map' => { file => { list => { value => \&string } }, + dir => { list => { value => \&string } }, + 'package' => { list => { value => \&string } }, + namespace => { list => { value => \&string } }, + ':key' => { name => \&string, value => \&anything }, + } + }; + + my $no_index_1_1 = { + 'map' => { ':key' => { name => \&string, list => { value => \&string } }, + } + }; + + my $prereq_map = { + map => { + ':key' => { + name => \&phase, + 'map' => { + ':key' => { + name => \&relation, + %$module_map1, + }, + }, + } + }, + }; + + my %definitions = ( + '2' => { + # REQUIRED + 'abstract' => { mandatory => 1, value => \&string }, + 'author' => { mandatory => 1, list => { value => \&string } }, + 'dynamic_config' => { mandatory => 1, value => \&boolean }, + 'generated_by' => { mandatory => 1, value => \&string }, + 'license' => { mandatory => 1, list => { value => \&license } }, + 'meta-spec' => { + mandatory => 1, + 'map' => { + version => { mandatory => 1, value => \&version}, + url => { value => \&url }, + ':key' => { name => \&custom_2, value => \&anything }, + } + }, + 'name' => { mandatory => 1, value => \&string }, + 'release_status' => { mandatory => 1, value => \&release_status }, + 'version' => { mandatory => 1, value => \&version }, + + # OPTIONAL + 'description' => { value => \&string }, + 'keywords' => { list => { value => \&string } }, + 'no_index' => $no_index_2, + 'optional_features' => { + 'map' => { + ':key' => { + name => \&string, + 'map' => { + description => { value => \&string }, + prereqs => $prereq_map, + ':key' => { name => \&custom_2, value => \&anything }, + } + } + } + }, + 'prereqs' => $prereq_map, + 'provides' => { + 'map' => { + ':key' => { + name => \&module, + 'map' => { + file => { mandatory => 1, value => \&file }, + version => { value => \&version }, + ':key' => { name => \&custom_2, value => \&anything }, + } + } + } + }, + 'resources' => { + 'map' => { + license => { list => { value => \&url } }, + homepage => { value => \&url }, + bugtracker => { + 'map' => { + web => { value => \&url }, + mailto => { value => \&string}, + ':key' => { name => \&custom_2, value => \&anything }, + } + }, + repository => { + 'map' => { + web => { value => \&url }, + url => { value => \&url }, + type => { value => \&string }, + ':key' => { name => \&custom_2, value => \&anything }, + } + }, + ':key' => { value => \&string, name => \&custom_2 }, + } + }, + + # CUSTOM -- additional user defined key/value pairs + # note we can only validate the key name, as the structure is user defined + ':key' => { name => \&custom_2, value => \&anything }, + }, + + '1.4' => { + 'meta-spec' => { + mandatory => 1, + 'map' => { + version => { mandatory => 1, value => \&version}, + url => { mandatory => 1, value => \&urlspec }, + ':key' => { name => \&string, value => \&anything }, + }, + }, + + 'name' => { mandatory => 1, value => \&string }, + 'version' => { mandatory => 1, value => \&version }, + 'abstract' => { mandatory => 1, value => \&string }, + 'author' => { mandatory => 1, list => { value => \&string } }, + 'license' => { mandatory => 1, value => \&license }, + 'generated_by' => { mandatory => 1, value => \&string }, + + 'distribution_type' => { value => \&string }, + 'dynamic_config' => { value => \&boolean }, + + 'requires' => $module_map1, + 'recommends' => $module_map1, + 'build_requires' => $module_map1, + 'configure_requires' => $module_map1, + 'conflicts' => $module_map2, + + 'optional_features' => { + 'map' => { + ':key' => { name => \&string, + 'map' => { description => { value => \&string }, + requires => $module_map1, + recommends => $module_map1, + build_requires => $module_map1, + conflicts => $module_map2, + ':key' => { name => \&string, value => \&anything }, + } + } + } + }, + + 'provides' => { + 'map' => { + ':key' => { name => \&module, + 'map' => { + file => { mandatory => 1, value => \&file }, + version => { value => \&version }, + ':key' => { name => \&string, value => \&anything }, + } + } + } + }, + + 'no_index' => $no_index_1_3, + 'private' => $no_index_1_3, + + 'keywords' => { list => { value => \&string } }, + + 'resources' => { + 'map' => { license => { value => \&url }, + homepage => { value => \&url }, + bugtracker => { value => \&url }, + repository => { value => \&url }, + ':key' => { value => \&string, name => \&custom_1 }, + } + }, + + # additional user defined key/value pairs + # note we can only validate the key name, as the structure is user defined + ':key' => { name => \&string, value => \&anything }, + }, + + '1.3' => { + 'meta-spec' => { + mandatory => 1, + 'map' => { + version => { mandatory => 1, value => \&version}, + url => { mandatory => 1, value => \&urlspec }, + ':key' => { name => \&string, value => \&anything }, + }, + }, + + 'name' => { mandatory => 1, value => \&string }, + 'version' => { mandatory => 1, value => \&version }, + 'abstract' => { mandatory => 1, value => \&string }, + 'author' => { mandatory => 1, list => { value => \&string } }, + 'license' => { mandatory => 1, value => \&license }, + 'generated_by' => { mandatory => 1, value => \&string }, + + 'distribution_type' => { value => \&string }, + 'dynamic_config' => { value => \&boolean }, + + 'requires' => $module_map1, + 'recommends' => $module_map1, + 'build_requires' => $module_map1, + 'conflicts' => $module_map2, + + 'optional_features' => { + 'map' => { + ':key' => { name => \&string, + 'map' => { description => { value => \&string }, + requires => $module_map1, + recommends => $module_map1, + build_requires => $module_map1, + conflicts => $module_map2, + ':key' => { name => \&string, value => \&anything }, + } + } + } + }, + + 'provides' => { + 'map' => { + ':key' => { name => \&module, + 'map' => { + file => { mandatory => 1, value => \&file }, + version => { value => \&version }, + ':key' => { name => \&string, value => \&anything }, + } + } + } + }, + + + 'no_index' => $no_index_1_3, + 'private' => $no_index_1_3, + + 'keywords' => { list => { value => \&string } }, + + 'resources' => { + 'map' => { license => { value => \&url }, + homepage => { value => \&url }, + bugtracker => { value => \&url }, + repository => { value => \&url }, + ':key' => { value => \&string, name => \&custom_1 }, + } + }, + + # additional user defined key/value pairs + # note we can only validate the key name, as the structure is user defined + ':key' => { name => \&string, value => \&anything }, + }, + + # v1.2 is misleading, it seems to assume that a number of fields where created + # within v1.1, when they were created within v1.2. This may have been an + # original mistake, and that a v1.1 was retro fitted into the timeline, when + # v1.2 was originally slated as v1.1. But I could be wrong ;) + '1.2' => { + 'meta-spec' => { + mandatory => 1, + 'map' => { + version => { mandatory => 1, value => \&version}, + url => { mandatory => 1, value => \&urlspec }, + ':key' => { name => \&string, value => \&anything }, + }, + }, + + + 'name' => { mandatory => 1, value => \&string }, + 'version' => { mandatory => 1, value => \&version }, + 'license' => { mandatory => 1, value => \&license }, + 'generated_by' => { mandatory => 1, value => \&string }, + 'author' => { mandatory => 1, list => { value => \&string } }, + 'abstract' => { mandatory => 1, value => \&string }, + + 'distribution_type' => { value => \&string }, + 'dynamic_config' => { value => \&boolean }, + + 'keywords' => { list => { value => \&string } }, + + 'private' => $no_index_1_2, + '$no_index' => $no_index_1_2, + + 'requires' => $module_map1, + 'recommends' => $module_map1, + 'build_requires' => $module_map1, + 'conflicts' => $module_map2, + + 'optional_features' => { + 'map' => { + ':key' => { name => \&string, + 'map' => { description => { value => \&string }, + requires => $module_map1, + recommends => $module_map1, + build_requires => $module_map1, + conflicts => $module_map2, + ':key' => { name => \&string, value => \&anything }, + } + } + } + }, + + 'provides' => { + 'map' => { + ':key' => { name => \&module, + 'map' => { + file => { mandatory => 1, value => \&file }, + version => { value => \&version }, + ':key' => { name => \&string, value => \&anything }, + } + } + } + }, + + 'resources' => { + 'map' => { license => { value => \&url }, + homepage => { value => \&url }, + bugtracker => { value => \&url }, + repository => { value => \&url }, + ':key' => { value => \&string, name => \&custom_1 }, + } + }, + + # additional user defined key/value pairs + # note we can only validate the key name, as the structure is user defined + ':key' => { name => \&string, value => \&anything }, + }, + + # note that the 1.1 spec only specifies 'version' as mandatory + '1.1' => { + 'name' => { value => \&string }, + 'version' => { mandatory => 1, value => \&version }, + 'license' => { value => \&license }, + 'generated_by' => { value => \&string }, + + 'license_uri' => { value => \&url }, + 'distribution_type' => { value => \&string }, + 'dynamic_config' => { value => \&boolean }, + + 'private' => $no_index_1_1, + + 'requires' => $module_map1, + 'recommends' => $module_map1, + 'build_requires' => $module_map1, + 'conflicts' => $module_map2, + + # additional user defined key/value pairs + # note we can only validate the key name, as the structure is user defined + ':key' => { name => \&string, value => \&anything }, + }, + + # note that the 1.0 spec doesn't specify optional or mandatory fields + # but we will treat version as mandatory since otherwise META 1.0 is + # completely arbitrary and pointless + '1.0' => { + 'name' => { value => \&string }, + 'version' => { mandatory => 1, value => \&version }, + 'license' => { value => \&license }, + 'generated_by' => { value => \&string }, + + 'license_uri' => { value => \&url }, + 'distribution_type' => { value => \&string }, + 'dynamic_config' => { value => \&boolean }, + + 'requires' => $module_map1, + 'recommends' => $module_map1, + 'build_requires' => $module_map1, + 'conflicts' => $module_map2, + + # additional user defined key/value pairs + # note we can only validate the key name, as the structure is user defined + ':key' => { name => \&string, value => \&anything }, + }, + ); + + #--------------------------------------------------------------------------# + # Code + #--------------------------------------------------------------------------# + + #pod =method new + #pod + #pod my $cmv = CPAN::Meta::Validator->new( $struct ) + #pod + #pod The constructor must be passed a metadata structure. + #pod + #pod =cut + + sub new { + my ($class,$data) = @_; + + # create an attributes hash + my $self = { + 'data' => $data, + 'spec' => eval { $data->{'meta-spec'}{'version'} } || "1.0", + 'errors' => undef, + }; + + # create the object + return bless $self, $class; + } + + #pod =method is_valid + #pod + #pod if ( $cmv->is_valid ) { + #pod ... + #pod } + #pod + #pod Returns a boolean value indicating whether the metadata provided + #pod is valid. + #pod + #pod =cut + + sub is_valid { + my $self = shift; + my $data = $self->{data}; + my $spec_version = $self->{spec}; + $self->check_map($definitions{$spec_version},$data); + return ! $self->errors; + } + + #pod =method errors + #pod + #pod warn( join "\n", $cmv->errors ); + #pod + #pod Returns a list of errors seen during validation. + #pod + #pod =cut + + sub errors { + my $self = shift; + return () unless(defined $self->{errors}); + return @{$self->{errors}}; + } + + #pod =begin :internals + #pod + #pod =head2 Check Methods + #pod + #pod =over + #pod + #pod =item * + #pod + #pod check_map($spec,$data) + #pod + #pod Checks whether a map (or hash) part of the data structure conforms to the + #pod appropriate specification definition. + #pod + #pod =item * + #pod + #pod check_list($spec,$data) + #pod + #pod Checks whether a list (or array) part of the data structure conforms to + #pod the appropriate specification definition. + #pod + #pod =item * + #pod + #pod =back + #pod + #pod =cut + + my $spec_error = "Missing validation action in specification. " + . "Must be one of 'map', 'list', or 'value'"; + + sub check_map { + my ($self,$spec,$data) = @_; + + if(ref($spec) ne 'HASH') { + $self->_error( "Unknown META specification, cannot validate." ); + return; + } + + if(ref($data) ne 'HASH') { + $self->_error( "Expected a map structure from string or file." ); + return; + } + + for my $key (keys %$spec) { + next unless($spec->{$key}->{mandatory}); + next if(defined $data->{$key}); + push @{$self->{stack}}, $key; + $self->_error( "Missing mandatory field, '$key'" ); + pop @{$self->{stack}}; + } + + for my $key (keys %$data) { + push @{$self->{stack}}, $key; + if($spec->{$key}) { + if($spec->{$key}{value}) { + $spec->{$key}{value}->($self,$key,$data->{$key}); + } elsif($spec->{$key}{'map'}) { + $self->check_map($spec->{$key}{'map'},$data->{$key}); + } elsif($spec->{$key}{'list'}) { + $self->check_list($spec->{$key}{'list'},$data->{$key}); + } else { + $self->_error( "$spec_error for '$key'" ); + } + + } elsif ($spec->{':key'}) { + $spec->{':key'}{name}->($self,$key,$key); + if($spec->{':key'}{value}) { + $spec->{':key'}{value}->($self,$key,$data->{$key}); + } elsif($spec->{':key'}{'map'}) { + $self->check_map($spec->{':key'}{'map'},$data->{$key}); + } elsif($spec->{':key'}{'list'}) { + $self->check_list($spec->{':key'}{'list'},$data->{$key}); + } else { + $self->_error( "$spec_error for ':key'" ); + } + + + } else { + $self->_error( "Unknown key, '$key', found in map structure" ); + } + pop @{$self->{stack}}; + } + } + + sub check_list { + my ($self,$spec,$data) = @_; + + if(ref($data) ne 'ARRAY') { + $self->_error( "Expected a list structure" ); + return; + } + + if(defined $spec->{mandatory}) { + if(!defined $data->[0]) { + $self->_error( "Missing entries from mandatory list" ); + } + } + + for my $value (@$data) { + push @{$self->{stack}}, $value || ""; + if(defined $spec->{value}) { + $spec->{value}->($self,'list',$value); + } elsif(defined $spec->{'map'}) { + $self->check_map($spec->{'map'},$value); + } elsif(defined $spec->{'list'}) { + $self->check_list($spec->{'list'},$value); + } elsif ($spec->{':key'}) { + $self->check_map($spec,$value); + } else { + $self->_error( "$spec_error associated with '$self->{stack}[-2]'" ); + } + pop @{$self->{stack}}; + } + } + + #pod =head2 Validator Methods + #pod + #pod =over + #pod + #pod =item * + #pod + #pod header($self,$key,$value) + #pod + #pod Validates that the header is valid. + #pod + #pod Note: No longer used as we now read the data structure, not the file. + #pod + #pod =item * + #pod + #pod url($self,$key,$value) + #pod + #pod Validates that a given value is in an acceptable URL format + #pod + #pod =item * + #pod + #pod urlspec($self,$key,$value) + #pod + #pod Validates that the URL to a META specification is a known one. + #pod + #pod =item * + #pod + #pod string_or_undef($self,$key,$value) + #pod + #pod Validates that the value is either a string or an undef value. Bit of a + #pod catchall function for parts of the data structure that are completely user + #pod defined. + #pod + #pod =item * + #pod + #pod string($self,$key,$value) + #pod + #pod Validates that a string exists for the given key. + #pod + #pod =item * + #pod + #pod file($self,$key,$value) + #pod + #pod Validate that a file is passed for the given key. This may be made more + #pod thorough in the future. For now it acts like \&string. + #pod + #pod =item * + #pod + #pod exversion($self,$key,$value) + #pod + #pod Validates a list of versions, e.g. '<= 5, >=2, ==3, !=4, >1, <6, 0'. + #pod + #pod =item * + #pod + #pod version($self,$key,$value) + #pod + #pod Validates a single version string. Versions of the type '5.8.8' and '0.00_00' + #pod are both valid. A leading 'v' like 'v1.2.3' is also valid. + #pod + #pod =item * + #pod + #pod boolean($self,$key,$value) + #pod + #pod Validates for a boolean value. Currently these values are '1', '0', 'true', + #pod 'false', however the latter 2 may be removed. + #pod + #pod =item * + #pod + #pod license($self,$key,$value) + #pod + #pod Validates that a value is given for the license. Returns 1 if an known license + #pod type, or 2 if a value is given but the license type is not a recommended one. + #pod + #pod =item * + #pod + #pod custom_1($self,$key,$value) + #pod + #pod Validates that the given key is in CamelCase, to indicate a user defined + #pod keyword and only has characters in the class [-_a-zA-Z]. In version 1.X + #pod of the spec, this was only explicitly stated for 'resources'. + #pod + #pod =item * + #pod + #pod custom_2($self,$key,$value) + #pod + #pod Validates that the given key begins with 'x_' or 'X_', to indicate a user + #pod defined keyword and only has characters in the class [-_a-zA-Z] + #pod + #pod =item * + #pod + #pod identifier($self,$key,$value) + #pod + #pod Validates that key is in an acceptable format for the META specification, + #pod for an identifier, i.e. any that matches the regular expression + #pod qr/[a-z][a-z_]/i. + #pod + #pod =item * + #pod + #pod module($self,$key,$value) + #pod + #pod Validates that a given key is in an acceptable module name format, e.g. + #pod 'Test::CPAN::Meta::Version'. + #pod + #pod =back + #pod + #pod =end :internals + #pod + #pod =cut + + sub header { + my ($self,$key,$value) = @_; + if(defined $value) { + return 1 if($value && $value =~ /^--- #YAML:1.0/); + } + $self->_error( "file does not have a valid YAML header." ); + return 0; + } + + sub release_status { + my ($self,$key,$value) = @_; + if(defined $value) { + my $version = $self->{data}{version} || ''; + if ( $version =~ /_/ ) { + return 1 if ( $value =~ /\A(?:testing|unstable)\z/ ); + $self->_error( "'$value' for '$key' is invalid for version '$version'" ); + } + else { + return 1 if ( $value =~ /\A(?:stable|testing|unstable)\z/ ); + $self->_error( "'$value' for '$key' is invalid" ); + } + } + else { + $self->_error( "'$key' is not defined" ); + } + return 0; + } + + # _uri_split taken from URI::Split by Gisle Aas, Copyright 2003 + sub _uri_split { + return $_[0] =~ m,(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?,; + } + + sub url { + my ($self,$key,$value) = @_; + if(defined $value) { + my ($scheme, $auth, $path, $query, $frag) = _uri_split($value); + unless ( defined $scheme && length $scheme ) { + $self->_error( "'$value' for '$key' does not have a URL scheme" ); + return 0; + } + unless ( defined $auth && length $auth ) { + $self->_error( "'$value' for '$key' does not have a URL authority" ); + return 0; + } + return 1; + } + $value ||= ''; + $self->_error( "'$value' for '$key' is not a valid URL." ); + return 0; + } + + sub urlspec { + my ($self,$key,$value) = @_; + if(defined $value) { + return 1 if($value && $known_specs{$self->{spec}} eq $value); + if($value && $known_urls{$value}) { + $self->_error( 'META specification URL does not match version' ); + return 0; + } + } + $self->_error( 'Unknown META specification' ); + return 0; + } + + sub anything { return 1 } + + sub string { + my ($self,$key,$value) = @_; + if(defined $value) { + return 1 if($value || $value =~ /^0$/); + } + $self->_error( "value is an undefined string" ); + return 0; + } + + sub string_or_undef { + my ($self,$key,$value) = @_; + return 1 unless(defined $value); + return 1 if($value || $value =~ /^0$/); + $self->_error( "No string defined for '$key'" ); + return 0; + } + + sub file { + my ($self,$key,$value) = @_; + return 1 if(defined $value); + $self->_error( "No file defined for '$key'" ); + return 0; + } + + sub exversion { + my ($self,$key,$value) = @_; + if(defined $value && ($value || $value =~ /0/)) { + my $pass = 1; + for(split(",",$value)) { $self->version($key,$_) or ($pass = 0); } + return $pass; + } + $value = '' unless(defined $value); + $self->_error( "'$value' for '$key' is not a valid version." ); + return 0; + } + + sub version { + my ($self,$key,$value) = @_; + if(defined $value) { + return 0 unless($value || $value =~ /0/); + return 1 if($value =~ /^\s*((<|<=|>=|>|!=|==)\s*)?v?\d+((\.\d+((_|\.)\d+)?)?)/); + } else { + $value = ''; + } + $self->_error( "'$value' for '$key' is not a valid version." ); + return 0; + } + + sub boolean { + my ($self,$key,$value) = @_; + if(defined $value) { + return 1 if($value =~ /^(0|1|true|false)$/); + } else { + $value = ''; + } + $self->_error( "'$value' for '$key' is not a boolean value." ); + return 0; + } + + my %v1_licenses = ( + 'perl' => 'http://dev.perl.org/licenses/', + 'gpl' => 'http://www.opensource.org/licenses/gpl-license.php', + 'apache' => 'http://apache.org/licenses/LICENSE-2.0', + 'artistic' => 'http://opensource.org/licenses/artistic-license.php', + 'artistic_2' => 'http://opensource.org/licenses/artistic-license-2.0.php', + 'lgpl' => 'http://www.opensource.org/licenses/lgpl-license.php', + 'bsd' => 'http://www.opensource.org/licenses/bsd-license.php', + 'gpl' => 'http://www.opensource.org/licenses/gpl-license.php', + 'mit' => 'http://opensource.org/licenses/mit-license.php', + 'mozilla' => 'http://opensource.org/licenses/mozilla1.1.php', + 'open_source' => undef, + 'unrestricted' => undef, + 'restrictive' => undef, + 'unknown' => undef, + ); + + my %v2_licenses = map { $_ => 1 } qw( + agpl_3 + apache_1_1 + apache_2_0 + artistic_1 + artistic_2 + bsd + freebsd + gfdl_1_2 + gfdl_1_3 + gpl_1 + gpl_2 + gpl_3 + lgpl_2_1 + lgpl_3_0 + mit + mozilla_1_0 + mozilla_1_1 + openssl + perl_5 + qpl_1_0 + ssleay + sun + zlib + open_source + restricted + unrestricted + unknown + ); + + sub license { + my ($self,$key,$value) = @_; + my $licenses = $self->{spec} < 2 ? \%v1_licenses : \%v2_licenses; + if(defined $value) { + return 1 if($value && exists $licenses->{$value}); + } else { + $value = ''; + } + $self->_error( "License '$value' is invalid" ); + return 0; + } + + sub custom_1 { + my ($self,$key) = @_; + if(defined $key) { + # a valid user defined key should be alphabetic + # and contain at least one capital case letter. + return 1 if($key && $key =~ /^[_a-z]+$/i && $key =~ /[A-Z]/); + } else { + $key = ''; + } + $self->_error( "Custom resource '$key' must be in CamelCase." ); + return 0; + } + + sub custom_2 { + my ($self,$key) = @_; + if(defined $key) { + return 1 if($key && $key =~ /^x_/i); # user defined + } else { + $key = ''; + } + $self->_error( "Custom key '$key' must begin with 'x_' or 'X_'." ); + return 0; + } + + sub identifier { + my ($self,$key) = @_; + if(defined $key) { + return 1 if($key && $key =~ /^([a-z][_a-z]+)$/i); # spec 2.0 defined + } else { + $key = ''; + } + $self->_error( "Key '$key' is not a legal identifier." ); + return 0; + } + + sub module { + my ($self,$key) = @_; + if(defined $key) { + return 1 if($key && $key =~ /^[A-Za-z0-9_]+(::[A-Za-z0-9_]+)*$/); + } else { + $key = ''; + } + $self->_error( "Key '$key' is not a legal module name." ); + return 0; + } + + my @valid_phases = qw/ configure build test runtime develop /; + sub phase { + my ($self,$key) = @_; + if(defined $key) { + return 1 if( length $key && grep { $key eq $_ } @valid_phases ); + return 1 if $key =~ /x_/i; + } else { + $key = ''; + } + $self->_error( "Key '$key' is not a legal phase." ); + return 0; + } + + my @valid_relations = qw/ requires recommends suggests conflicts /; + sub relation { + my ($self,$key) = @_; + if(defined $key) { + return 1 if( length $key && grep { $key eq $_ } @valid_relations ); + return 1 if $key =~ /x_/i; + } else { + $key = ''; + } + $self->_error( "Key '$key' is not a legal prereq relationship." ); + return 0; + } + + sub _error { + my $self = shift; + my $mess = shift; + + $mess .= ' ('.join(' -> ',@{$self->{stack}}).')' if($self->{stack}); + $mess .= " [Validation: $self->{spec}]"; + + push @{$self->{errors}}, $mess; + } + + 1; + + # ABSTRACT: validate CPAN distribution metadata structures + + =pod + + =encoding UTF-8 + + =head1 NAME + + CPAN::Meta::Validator - validate CPAN distribution metadata structures + + =head1 VERSION + + version 2.150005 + + =head1 SYNOPSIS + + my $struct = decode_json_file('META.json'); + + my $cmv = CPAN::Meta::Validator->new( $struct ); + + unless ( $cmv->is_valid ) { + my $msg = "Invalid META structure. Errors found:\n"; + $msg .= join( "\n", $cmv->errors ); + die $msg; + } + + =head1 DESCRIPTION + + This module validates a CPAN Meta structure against the version of the + the specification claimed in the C field of the structure. + + =head1 METHODS + + =head2 new + + my $cmv = CPAN::Meta::Validator->new( $struct ) + + The constructor must be passed a metadata structure. + + =head2 is_valid + + if ( $cmv->is_valid ) { + ... + } + + Returns a boolean value indicating whether the metadata provided + is valid. + + =head2 errors + + warn( join "\n", $cmv->errors ); + + Returns a list of errors seen during validation. + + =begin :internals + + =head2 Check Methods + + =over + + =item * + + check_map($spec,$data) + + Checks whether a map (or hash) part of the data structure conforms to the + appropriate specification definition. + + =item * + + check_list($spec,$data) + + Checks whether a list (or array) part of the data structure conforms to + the appropriate specification definition. + + =item * + + =back + + =head2 Validator Methods + + =over + + =item * + + header($self,$key,$value) + + Validates that the header is valid. + + Note: No longer used as we now read the data structure, not the file. + + =item * + + url($self,$key,$value) + + Validates that a given value is in an acceptable URL format + + =item * + + urlspec($self,$key,$value) + + Validates that the URL to a META specification is a known one. + + =item * + + string_or_undef($self,$key,$value) + + Validates that the value is either a string or an undef value. Bit of a + catchall function for parts of the data structure that are completely user + defined. + + =item * + + string($self,$key,$value) + + Validates that a string exists for the given key. + + =item * + + file($self,$key,$value) + + Validate that a file is passed for the given key. This may be made more + thorough in the future. For now it acts like \&string. + + =item * + + exversion($self,$key,$value) + + Validates a list of versions, e.g. '<= 5, >=2, ==3, !=4, >1, <6, 0'. + + =item * + + version($self,$key,$value) + + Validates a single version string. Versions of the type '5.8.8' and '0.00_00' + are both valid. A leading 'v' like 'v1.2.3' is also valid. + + =item * + + boolean($self,$key,$value) + + Validates for a boolean value. Currently these values are '1', '0', 'true', + 'false', however the latter 2 may be removed. + + =item * + + license($self,$key,$value) + + Validates that a value is given for the license. Returns 1 if an known license + type, or 2 if a value is given but the license type is not a recommended one. + + =item * + + custom_1($self,$key,$value) + + Validates that the given key is in CamelCase, to indicate a user defined + keyword and only has characters in the class [-_a-zA-Z]. In version 1.X + of the spec, this was only explicitly stated for 'resources'. + + =item * + + custom_2($self,$key,$value) + + Validates that the given key begins with 'x_' or 'X_', to indicate a user + defined keyword and only has characters in the class [-_a-zA-Z] + + =item * + + identifier($self,$key,$value) + + Validates that key is in an acceptable format for the META specification, + for an identifier, i.e. any that matches the regular expression + qr/[a-z][a-z_]/i. + + =item * + + module($self,$key,$value) + + Validates that a given key is in an acceptable module name format, e.g. + 'Test::CPAN::Meta::Version'. + + =back + + =end :internals + + =for Pod::Coverage anything boolean check_list custom_1 custom_2 exversion file + identifier license module phase relation release_status string string_or_undef + url urlspec version header check_map + + =head1 BUGS + + Please report any bugs or feature using the CPAN Request Tracker. + Bugs can be submitted through the web interface at + L + + When submitting a bug or request, please include a test-file or a patch to an + existing test-file that illustrates the bug or desired feature. + + =head1 AUTHORS + + =over 4 + + =item * + + David Golden + + =item * + + Ricardo Signes + + =back + + =head1 COPYRIGHT AND LICENSE + + This software is copyright (c) 2010 by David Golden and Ricardo Signes. + + This is free software; you can redistribute it and/or modify it under + the same terms as the Perl 5 programming language system itself. + + =cut + + __END__ + + + # vim: ts=2 sts=2 sw=2 et : + CPAN_META_VALIDATOR + + $fatpacked{"CPAN/Meta/YAML.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_YAML'; + use 5.008001; # sane UTF-8 support + use strict; + use warnings; + package CPAN::Meta::YAML; # git description: v1.66-5-ge09e1ae + # XXX-INGY is 5.8.1 too old/broken for utf8? + # XXX-XDG Lancaster consensus was that it was sufficient until + # proven otherwise + $CPAN::Meta::YAML::VERSION = '0.016'; + ; # original $VERSION removed by Doppelgaenger + + ##################################################################### + # The CPAN::Meta::YAML API. + # + # These are the currently documented API functions/methods and + # exports: + + use Exporter; + our @ISA = qw{ Exporter }; + our @EXPORT = qw{ Load Dump }; + our @EXPORT_OK = qw{ LoadFile DumpFile freeze thaw }; + + ### + # Functional/Export API: + + sub Dump { + return CPAN::Meta::YAML->new(@_)->_dump_string; + } + + # XXX-INGY Returning last document seems a bad behavior. + # XXX-XDG I think first would seem more natural, but I don't know + # that it's worth changing now + sub Load { + my $self = CPAN::Meta::YAML->_load_string(@_); + if ( wantarray ) { + return @$self; + } else { + # To match YAML.pm, return the last document + return $self->[-1]; + } + } + + # XXX-INGY Do we really need freeze and thaw? + # XXX-XDG I don't think so. I'd support deprecating them. + BEGIN { + *freeze = \&Dump; + *thaw = \&Load; + } + + sub DumpFile { + my $file = shift; + return CPAN::Meta::YAML->new(@_)->_dump_file($file); + } + + sub LoadFile { + my $file = shift; + my $self = CPAN::Meta::YAML->_load_file($file); + if ( wantarray ) { + return @$self; + } else { + # Return only the last document to match YAML.pm, + return $self->[-1]; + } + } + + + ### + # Object Oriented API: + + # Create an empty CPAN::Meta::YAML object + # XXX-INGY Why do we use ARRAY object? + # NOTE: I get it now, but I think it's confusing and not needed. + # Will change it on a branch later, for review. + # + # XXX-XDG I don't support changing it yet. It's a very well-documented + # "API" of CPAN::Meta::YAML. I'd support deprecating it, but Adam suggested + # we not change it until YAML.pm's own OO API is established so that + # users only have one API change to digest, not two + sub new { + my $class = shift; + bless [ @_ ], $class; + } + + # XXX-INGY It probably doesn't matter, and it's probably too late to + # change, but 'read/write' are the wrong names. Read and Write + # are actions that take data from storage to memory + # characters/strings. These take the data to/from storage to native + # Perl objects, which the terms dump and load are meant. As long as + # this is a legacy quirk to CPAN::Meta::YAML it's ok, but I'd prefer not + # to add new {read,write}_* methods to this API. + + sub read_string { + my $self = shift; + $self->_load_string(@_); + } + + sub write_string { + my $self = shift; + $self->_dump_string(@_); + } + + sub read { + my $self = shift; + $self->_load_file(@_); + } + + sub write { + my $self = shift; + $self->_dump_file(@_); + } + + + + + ##################################################################### + # Constants + + # Printed form of the unprintable characters in the lowest range + # of ASCII characters, listed by ASCII ordinal position. + my @UNPRINTABLE = qw( + 0 x01 x02 x03 x04 x05 x06 a + b t n v f r x0E x0F + x10 x11 x12 x13 x14 x15 x16 x17 + x18 x19 x1A e x1C x1D x1E x1F + ); + + # Printable characters for escapes + my %UNESCAPES = ( + 0 => "\x00", z => "\x00", N => "\x85", + a => "\x07", b => "\x08", t => "\x09", + n => "\x0a", v => "\x0b", f => "\x0c", + r => "\x0d", e => "\x1b", '\\' => '\\', + ); + + # XXX-INGY + # I(ngy) need to decide if these values should be quoted in + # CPAN::Meta::YAML or not. Probably yes. + + # These 3 values have special meaning when unquoted and using the + # default YAML schema. They need quotes if they are strings. + my %QUOTE = map { $_ => 1 } qw{ + null true false + }; + + # The commented out form is simpler, but overloaded the Perl regex + # engine due to recursion and backtracking problems on strings + # larger than 32,000ish characters. Keep it for reference purposes. + # qr/\"((?:\\.|[^\"])*)\"/ + my $re_capture_double_quoted = qr/\"([^\\"]*(?:\\.[^\\"]*)*)\"/; + my $re_capture_single_quoted = qr/\'([^\']*(?:\'\'[^\']*)*)\'/; + # unquoted re gets trailing space that needs to be stripped + my $re_capture_unquoted_key = qr/([^:]+(?::+\S(?:[^:]*|.*?(?=:)))*)(?=\s*\:(?:\s+|$))/; + my $re_trailing_comment = qr/(?:\s+\#.*)?/; + my $re_key_value_separator = qr/\s*:(?:\s+(?:\#.*)?|$)/; + + + + + + ##################################################################### + # CPAN::Meta::YAML Implementation. + # + # These are the private methods that do all the work. They may change + # at any time. + + + ### + # Loader functions: + + # Create an object from a file + sub _load_file { + my $class = ref $_[0] ? ref shift : shift; + + # Check the file + my $file = shift or $class->_error( 'You did not specify a file name' ); + $class->_error( "File '$file' does not exist" ) + unless -e $file; + $class->_error( "'$file' is a directory, not a file" ) + unless -f _; + $class->_error( "Insufficient permissions to read '$file'" ) + unless -r _; + + # Open unbuffered with strict UTF-8 decoding and no translation layers + open( my $fh, "<:unix:encoding(UTF-8)", $file ); + unless ( $fh ) { + $class->_error("Failed to open file '$file': $!"); + } + + # flock if available (or warn if not possible for OS-specific reasons) + if ( _can_flock() ) { + flock( $fh, Fcntl::LOCK_SH() ) + or warn "Couldn't lock '$file' for reading: $!"; + } + + # slurp the contents + my $contents = eval { + use warnings FATAL => 'utf8'; + local $/; + <$fh> + }; + if ( my $err = $@ ) { + $class->_error("Error reading from file '$file': $err"); + } + + # close the file (release the lock) + unless ( close $fh ) { + $class->_error("Failed to close file '$file': $!"); + } + + $class->_load_string( $contents ); + } + + # Create an object from a string + sub _load_string { + my $class = ref $_[0] ? ref shift : shift; + my $self = bless [], $class; + my $string = $_[0]; + eval { + unless ( defined $string ) { + die \"Did not provide a string to load"; + } + + # Check if Perl has it marked as characters, but it's internally + # inconsistent. E.g. maybe latin1 got read on a :utf8 layer + if ( utf8::is_utf8($string) && ! utf8::valid($string) ) { + die \<<'...'; + Read an invalid UTF-8 string (maybe mixed UTF-8 and 8-bit character set). + Did you decode with lax ":utf8" instead of strict ":encoding(UTF-8)"? + ... + } + + # Ensure Unicode character semantics, even for 0x80-0xff + utf8::upgrade($string); + + # Check for and strip any leading UTF-8 BOM + $string =~ s/^\x{FEFF}//; + + # Check for some special cases + return $self unless length $string; + + # Split the file into lines + my @lines = grep { ! /^\s*(?:\#.*)?\z/ } + split /(?:\015{1,2}\012|\015|\012)/, $string; + + # Strip the initial YAML header + @lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines; + + # A nibbling parser + my $in_document = 0; + while ( @lines ) { + # Do we have a document header? + if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) { + # Handle scalar documents + shift @lines; + if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) { + push @$self, + $self->_load_scalar( "$1", [ undef ], \@lines ); + next; + } + $in_document = 1; + } + + if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) { + # A naked document + push @$self, undef; + while ( @lines and $lines[0] !~ /^---/ ) { + shift @lines; + } + $in_document = 0; + + # XXX The final '-+$' is to look for -- which ends up being an + # error later. + } elsif ( ! $in_document && @$self ) { + # only the first document can be explicit + die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'"; + } elsif ( $lines[0] =~ /^\s*\-(?:\s|$|-+$)/ ) { + # An array at the root + my $document = [ ]; + push @$self, $document; + $self->_load_array( $document, [ 0 ], \@lines ); + + } elsif ( $lines[0] =~ /^(\s*)\S/ ) { + # A hash at the root + my $document = { }; + push @$self, $document; + $self->_load_hash( $document, [ length($1) ], \@lines ); + + } else { + # Shouldn't get here. @lines have whitespace-only lines + # stripped, and previous match is a line with any + # non-whitespace. So this clause should only be reachable via + # a perlbug where \s is not symmetric with \S + + # uncoverable statement + die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'"; + } + } + }; + my $err = $@; + if ( ref $err eq 'SCALAR' ) { + $self->_error(${$err}); + } elsif ( $err ) { + $self->_error($err); + } + + return $self; + } + + sub _unquote_single { + my ($self, $string) = @_; + return '' unless length $string; + $string =~ s/\'\'/\'/g; + return $string; + } + + sub _unquote_double { + my ($self, $string) = @_; + return '' unless length $string; + $string =~ s/\\"/"/g; + $string =~ + s{\\([Nnever\\fartz0b]|x([0-9a-fA-F]{2}))} + {(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}}gex; + return $string; + } + + # Load a YAML scalar string to the actual Perl scalar + sub _load_scalar { + my ($self, $string, $indent, $lines) = @_; + + # Trim trailing whitespace + $string =~ s/\s*\z//; + + # Explitic null/undef + return undef if $string eq '~'; + + # Single quote + if ( $string =~ /^$re_capture_single_quoted$re_trailing_comment\z/ ) { + return $self->_unquote_single($1); + } + + # Double quote. + if ( $string =~ /^$re_capture_double_quoted$re_trailing_comment\z/ ) { + return $self->_unquote_double($1); + } + + # Special cases + if ( $string =~ /^[\'\"!&]/ ) { + die \"CPAN::Meta::YAML does not support a feature in line '$string'"; + } + return {} if $string =~ /^{}(?:\s+\#.*)?\z/; + return [] if $string =~ /^\[\](?:\s+\#.*)?\z/; + + # Regular unquoted string + if ( $string !~ /^[>|]/ ) { + die \"CPAN::Meta::YAML found illegal characters in plain scalar: '$string'" + if $string =~ /^(?:-(?:\s|$)|[\@\%\`])/ or + $string =~ /:(?:\s|$)/; + $string =~ s/\s+#.*\z//; + return $string; + } + + # Error + die \"CPAN::Meta::YAML failed to find multi-line scalar content" unless @$lines; + + # Check the indent depth + $lines->[0] =~ /^(\s*)/; + $indent->[-1] = length("$1"); + if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) { + die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'"; + } + + # Pull the lines + my @multiline = (); + while ( @$lines ) { + $lines->[0] =~ /^(\s*)/; + last unless length($1) >= $indent->[-1]; + push @multiline, substr(shift(@$lines), length($1)); + } + + my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n"; + my $t = (substr($string, 1, 1) eq '-') ? '' : "\n"; + return join( $j, @multiline ) . $t; + } + + # Load an array + sub _load_array { + my ($self, $array, $indent, $lines) = @_; + + while ( @$lines ) { + # Check for a new document + if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) { + while ( @$lines and $lines->[0] !~ /^---/ ) { + shift @$lines; + } + return 1; + } + + # Check the indent level + $lines->[0] =~ /^(\s*)/; + if ( length($1) < $indent->[-1] ) { + return 1; + } elsif ( length($1) > $indent->[-1] ) { + die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'"; + } + + if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) { + # Inline nested hash + my $indent2 = length("$1"); + $lines->[0] =~ s/-/ /; + push @$array, { }; + $self->_load_hash( $array->[-1], [ @$indent, $indent2 ], $lines ); + + } elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) { + shift @$lines; + unless ( @$lines ) { + push @$array, undef; + return 1; + } + if ( $lines->[0] =~ /^(\s*)\-/ ) { + my $indent2 = length("$1"); + if ( $indent->[-1] == $indent2 ) { + # Null array entry + push @$array, undef; + } else { + # Naked indenter + push @$array, [ ]; + $self->_load_array( + $array->[-1], [ @$indent, $indent2 ], $lines + ); + } + + } elsif ( $lines->[0] =~ /^(\s*)\S/ ) { + push @$array, { }; + $self->_load_hash( + $array->[-1], [ @$indent, length("$1") ], $lines + ); + + } else { + die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'"; + } + + } elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) { + # Array entry with a value + shift @$lines; + push @$array, $self->_load_scalar( + "$2", [ @$indent, undef ], $lines + ); + + } elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) { + # This is probably a structure like the following... + # --- + # foo: + # - list + # bar: value + # + # ... so lets return and let the hash parser handle it + return 1; + + } else { + die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'"; + } + } + + return 1; + } + + # Load a hash + sub _load_hash { + my ($self, $hash, $indent, $lines) = @_; + + while ( @$lines ) { + # Check for a new document + if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) { + while ( @$lines and $lines->[0] !~ /^---/ ) { + shift @$lines; + } + return 1; + } + + # Check the indent level + $lines->[0] =~ /^(\s*)/; + if ( length($1) < $indent->[-1] ) { + return 1; + } elsif ( length($1) > $indent->[-1] ) { + die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'"; + } + + # Find the key + my $key; + + # Quoted keys + if ( $lines->[0] =~ + s/^\s*$re_capture_single_quoted$re_key_value_separator// + ) { + $key = $self->_unquote_single($1); + } + elsif ( $lines->[0] =~ + s/^\s*$re_capture_double_quoted$re_key_value_separator// + ) { + $key = $self->_unquote_double($1); + } + elsif ( $lines->[0] =~ + s/^\s*$re_capture_unquoted_key$re_key_value_separator// + ) { + $key = $1; + $key =~ s/\s+$//; + } + elsif ( $lines->[0] =~ /^\s*\?/ ) { + die \"CPAN::Meta::YAML does not support a feature in line '$lines->[0]'"; + } + else { + die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'"; + } + + if ( exists $hash->{$key} ) { + warn "CPAN::Meta::YAML found a duplicate key '$key' in line '$lines->[0]'"; + } + + # Do we have a value? + if ( length $lines->[0] ) { + # Yes + $hash->{$key} = $self->_load_scalar( + shift(@$lines), [ @$indent, undef ], $lines + ); + } else { + # An indent + shift @$lines; + unless ( @$lines ) { + $hash->{$key} = undef; + return 1; + } + if ( $lines->[0] =~ /^(\s*)-/ ) { + $hash->{$key} = []; + $self->_load_array( + $hash->{$key}, [ @$indent, length($1) ], $lines + ); + } elsif ( $lines->[0] =~ /^(\s*)./ ) { + my $indent2 = length("$1"); + if ( $indent->[-1] >= $indent2 ) { + # Null hash entry + $hash->{$key} = undef; + } else { + $hash->{$key} = {}; + $self->_load_hash( + $hash->{$key}, [ @$indent, length($1) ], $lines + ); + } + } + } + } + + return 1; + } + + + ### + # Dumper functions: + + # Save an object to a file + sub _dump_file { + my $self = shift; + + require Fcntl; + + # Check the file + my $file = shift or $self->_error( 'You did not specify a file name' ); + + my $fh; + # flock if available (or warn if not possible for OS-specific reasons) + if ( _can_flock() ) { + # Open without truncation (truncate comes after lock) + my $flags = Fcntl::O_WRONLY()|Fcntl::O_CREAT(); + sysopen( $fh, $file, $flags ); + unless ( $fh ) { + $self->_error("Failed to open file '$file' for writing: $!"); + } + + # Use no translation and strict UTF-8 + binmode( $fh, ":raw:encoding(UTF-8)"); + + flock( $fh, Fcntl::LOCK_EX() ) + or warn "Couldn't lock '$file' for reading: $!"; + + # truncate and spew contents + truncate $fh, 0; + seek $fh, 0, 0; + } + else { + open $fh, ">:unix:encoding(UTF-8)", $file; + } + + # serialize and spew to the handle + print {$fh} $self->_dump_string; + + # close the file (release the lock) + unless ( close $fh ) { + $self->_error("Failed to close file '$file': $!"); + } + + return 1; + } + + # Save an object to a string + sub _dump_string { + my $self = shift; + return '' unless ref $self && @$self; + + # Iterate over the documents + my $indent = 0; + my @lines = (); + + eval { + foreach my $cursor ( @$self ) { + push @lines, '---'; + + # An empty document + if ( ! defined $cursor ) { + # Do nothing + + # A scalar document + } elsif ( ! ref $cursor ) { + $lines[-1] .= ' ' . $self->_dump_scalar( $cursor ); + + # A list at the root + } elsif ( ref $cursor eq 'ARRAY' ) { + unless ( @$cursor ) { + $lines[-1] .= ' []'; + next; + } + push @lines, $self->_dump_array( $cursor, $indent, {} ); + + # A hash at the root + } elsif ( ref $cursor eq 'HASH' ) { + unless ( %$cursor ) { + $lines[-1] .= ' {}'; + next; + } + push @lines, $self->_dump_hash( $cursor, $indent, {} ); + + } else { + die \("Cannot serialize " . ref($cursor)); + } + } + }; + if ( ref $@ eq 'SCALAR' ) { + $self->_error(${$@}); + } elsif ( $@ ) { + $self->_error($@); + } + + join '', map { "$_\n" } @lines; + } + + sub _has_internal_string_value { + my $value = shift; + my $b_obj = B::svref_2object(\$value); # for round trip problem + return $b_obj->FLAGS & B::SVf_POK(); + } + + sub _dump_scalar { + my $string = $_[1]; + my $is_key = $_[2]; + # Check this before checking length or it winds up looking like a string! + my $has_string_flag = _has_internal_string_value($string); + return '~' unless defined $string; + return "''" unless length $string; + if (Scalar::Util::looks_like_number($string)) { + # keys and values that have been used as strings get quoted + if ( $is_key || $has_string_flag ) { + return qq['$string']; + } + else { + return $string; + } + } + if ( $string =~ /[\x00-\x09\x0b-\x0d\x0e-\x1f\x7f-\x9f\'\n]/ ) { + $string =~ s/\\/\\\\/g; + $string =~ s/"/\\"/g; + $string =~ s/\n/\\n/g; + $string =~ s/[\x85]/\\N/g; + $string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g; + $string =~ s/([\x7f-\x9f])/'\x' . sprintf("%X",ord($1))/ge; + return qq|"$string"|; + } + if ( $string =~ /(?:^[~!@#%&*|>?:,'"`{}\[\]]|^-+$|\s|:\z)/ or + $QUOTE{$string} + ) { + return "'$string'"; + } + return $string; + } + + sub _dump_array { + my ($self, $array, $indent, $seen) = @_; + if ( $seen->{refaddr($array)}++ ) { + die \"CPAN::Meta::YAML does not support circular references"; + } + my @lines = (); + foreach my $el ( @$array ) { + my $line = (' ' x $indent) . '-'; + my $type = ref $el; + if ( ! $type ) { + $line .= ' ' . $self->_dump_scalar( $el ); + push @lines, $line; + + } elsif ( $type eq 'ARRAY' ) { + if ( @$el ) { + push @lines, $line; + push @lines, $self->_dump_array( $el, $indent + 1, $seen ); + } else { + $line .= ' []'; + push @lines, $line; + } + + } elsif ( $type eq 'HASH' ) { + if ( keys %$el ) { + push @lines, $line; + push @lines, $self->_dump_hash( $el, $indent + 1, $seen ); + } else { + $line .= ' {}'; + push @lines, $line; + } + + } else { + die \"CPAN::Meta::YAML does not support $type references"; + } + } + + @lines; + } + + sub _dump_hash { + my ($self, $hash, $indent, $seen) = @_; + if ( $seen->{refaddr($hash)}++ ) { + die \"CPAN::Meta::YAML does not support circular references"; + } + my @lines = (); + foreach my $name ( sort keys %$hash ) { + my $el = $hash->{$name}; + my $line = (' ' x $indent) . $self->_dump_scalar($name, 1) . ":"; + my $type = ref $el; + if ( ! $type ) { + $line .= ' ' . $self->_dump_scalar( $el ); + push @lines, $line; + + } elsif ( $type eq 'ARRAY' ) { + if ( @$el ) { + push @lines, $line; + push @lines, $self->_dump_array( $el, $indent + 1, $seen ); + } else { + $line .= ' []'; + push @lines, $line; + } + + } elsif ( $type eq 'HASH' ) { + if ( keys %$el ) { + push @lines, $line; + push @lines, $self->_dump_hash( $el, $indent + 1, $seen ); + } else { + $line .= ' {}'; + push @lines, $line; + } + + } else { + die \"CPAN::Meta::YAML does not support $type references"; + } + } + + @lines; + } + + + + ##################################################################### + # DEPRECATED API methods: + + # Error storage (DEPRECATED as of 1.57) + our $errstr = ''; + + # Set error + sub _error { + require Carp; + $errstr = $_[1]; + $errstr =~ s/ at \S+ line \d+.*//; + Carp::croak( $errstr ); + } + + # Retrieve error + my $errstr_warned; + sub errstr { + require Carp; + Carp::carp( "CPAN::Meta::YAML->errstr and \$CPAN::Meta::YAML::errstr is deprecated" ) + unless $errstr_warned++; + $errstr; + } + + + + + ##################################################################### + # Helper functions. Possibly not needed. + + + # Use to detect nv or iv + use B; + + # XXX-INGY Is flock CPAN::Meta::YAML's responsibility? + # Some platforms can't flock :-( + # XXX-XDG I think it is. When reading and writing files, we ought + # to be locking whenever possible. People (foolishly) use YAML + # files for things like session storage, which has race issues. + my $HAS_FLOCK; + sub _can_flock { + if ( defined $HAS_FLOCK ) { + return $HAS_FLOCK; + } + else { + require Config; + my $c = \%Config::Config; + $HAS_FLOCK = grep { $c->{$_} } qw/d_flock d_fcntl_can_lock d_lockf/; + require Fcntl if $HAS_FLOCK; + return $HAS_FLOCK; + } + } + + + # XXX-INGY Is this core in 5.8.1? Can we remove this? + # XXX-XDG Scalar::Util 1.18 didn't land until 5.8.8, so we need this + ##################################################################### + # Use Scalar::Util if possible, otherwise emulate it + + use Scalar::Util (); + BEGIN { + local $@; + if ( eval { Scalar::Util->VERSION(1.18); } ) { + *refaddr = *Scalar::Util::refaddr; + } + else { + eval <<'END_PERL'; + # Scalar::Util failed to load or too old + sub refaddr { + my $pkg = ref($_[0]) or return undef; + if ( !! UNIVERSAL::can($_[0], 'can') ) { + bless $_[0], 'Scalar::Util::Fake'; + } else { + $pkg = undef; + } + "$_[0]" =~ /0x(\w+)/; + my $i = do { no warnings 'portable'; hex $1 }; + bless $_[0], $pkg if defined $pkg; + $i; + } + END_PERL + } + } + + delete $CPAN::Meta::YAML::{refaddr}; + + 1; + + # XXX-INGY Doc notes I'm putting up here. Changing the doc when it's wrong + # but leaving grey area stuff up here. + # + # I would like to change Read/Write to Load/Dump below without + # changing the actual API names. + # + # It might be better to put Load/Dump API in the SYNOPSIS instead of the + # dubious OO API. + # + # null and bool explanations may be outdated. + + =pod + + =encoding UTF-8 + + =head1 NAME + + CPAN::Meta::YAML - Read and write a subset of YAML for CPAN Meta files + + =head1 VERSION + + version 0.016 + + =head1 SYNOPSIS + + use CPAN::Meta::YAML; + + # reading a META file + open $fh, "<:utf8", "META.yml"; + $yaml_text = do { local $/; <$fh> }; + $yaml = CPAN::Meta::YAML->read_string($yaml_text) + or die CPAN::Meta::YAML->errstr; + + # finding the metadata + $meta = $yaml->[0]; + + # writing a META file + $yaml_text = $yaml->write_string + or die CPAN::Meta::YAML->errstr; + open $fh, ">:utf8", "META.yml"; + print $fh $yaml_text; + + =head1 DESCRIPTION + + This module implements a subset of the YAML specification for use in reading + and writing CPAN metadata files like F and F. It should + not be used for any other general YAML parsing or generation task. + + NOTE: F (and F) files should be UTF-8 encoded. Users are + responsible for proper encoding and decoding. In particular, the C and + C methods do B support UTF-8 and should not be used. + + =head1 SUPPORT + + This module is currently derived from L by Adam Kennedy. If + there are bugs in how it parses a particular META.yml file, please file + a bug report in the YAML::Tiny bugtracker: + L + + =head1 SEE ALSO + + L, L, L + + =head1 AUTHORS + + =over 4 + + =item * + + Adam Kennedy + + =item * + + David Golden + + =back + + =head1 COPYRIGHT AND LICENSE + + This software is copyright (c) 2010 by Adam Kennedy. + + This is free software; you can redistribute it and/or modify it under + the same terms as the Perl 5 programming language system itself. + + =cut + + __END__ + + + # ABSTRACT: Read and write a subset of YAML for CPAN Meta files + + + CPAN_META_YAML + + $fatpacked{"Exporter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXPORTER'; + package Exporter; + + require 5.006; + + # Be lean. + #use strict; + #no strict 'refs'; + + our $Debug = 0; + our $ExportLevel = 0; + our $Verbose ||= 0; + our $VERSION = '5.70'; + our (%Cache); + + sub as_heavy { + require Exporter::Heavy; + # Unfortunately, this does not work if the caller is aliased as *name = \&foo + # Thus the need to create a lot of identical subroutines + my $c = (caller(1))[3]; + $c =~ s/.*:://; + \&{"Exporter::Heavy::heavy_$c"}; + } + + sub export { + goto &{as_heavy()}; + } + + sub import { + my $pkg = shift; + my $callpkg = caller($ExportLevel); + + if ($pkg eq "Exporter" and @_ and $_[0] eq "import") { + *{$callpkg."::import"} = \&import; + return; + } + + # We *need* to treat @{"$pkg\::EXPORT_FAIL"} since Carp uses it :-( + my $exports = \@{"$pkg\::EXPORT"}; + # But, avoid creating things if they don't exist, which saves a couple of + # hundred bytes per package processed. + my $fail = ${$pkg . '::'}{EXPORT_FAIL} && \@{"$pkg\::EXPORT_FAIL"}; + return export $pkg, $callpkg, @_ + if $Verbose or $Debug or $fail && @$fail > 1; + my $export_cache = ($Cache{$pkg} ||= {}); + my $args = @_ or @_ = @$exports; + + if ($args and not %$export_cache) { + s/^&//, $export_cache->{$_} = 1 + foreach (@$exports, @{"$pkg\::EXPORT_OK"}); + } + my $heavy; + # Try very hard not to use {} and hence have to enter scope on the foreach + # We bomb out of the loop with last as soon as heavy is set. + if ($args or $fail) { + ($heavy = (/\W/ or $args and not exists $export_cache->{$_} + or $fail and @$fail and $_ eq $fail->[0])) and last + foreach (@_); + } else { + ($heavy = /\W/) and last + foreach (@_); + } + return export $pkg, $callpkg, ($args ? @_ : ()) if $heavy; + local $SIG{__WARN__} = + sub {require Carp; &Carp::carp} if not $SIG{__WARN__}; + # shortcut for the common case of no type character + *{"$callpkg\::$_"} = \&{"$pkg\::$_"} foreach @_; + } + + # Default methods + + sub export_fail { + my $self = shift; + @_; + } + + # Unfortunately, caller(1)[3] "does not work" if the caller is aliased as + # *name = \&foo. Thus the need to create a lot of identical subroutines + # Otherwise we could have aliased them to export(). + + sub export_to_level { + goto &{as_heavy()}; + } + + sub export_tags { + goto &{as_heavy()}; + } + + sub export_ok_tags { + goto &{as_heavy()}; + } + + sub require_version { + goto &{as_heavy()}; + } + + 1; + __END__ + + =head1 NAME + + Exporter - Implements default import method for modules + + =head1 SYNOPSIS + + In module F: + + package YourModule; + require Exporter; + @ISA = qw(Exporter); + @EXPORT_OK = qw(munge frobnicate); # symbols to export on request + + or + + package YourModule; + use Exporter 'import'; # gives you Exporter's import() method directly + @EXPORT_OK = qw(munge frobnicate); # symbols to export on request + + In other files which wish to use C: + + use YourModule qw(frobnicate); # import listed symbols + frobnicate ($left, $right) # calls YourModule::frobnicate + + Take a look at L for some variants + you will like to use in modern Perl code. + + =head1 DESCRIPTION + + The Exporter module implements an C method which allows a module + to export functions and variables to its users' namespaces. Many modules + use Exporter rather than implementing their own C method because + Exporter provides a highly flexible interface, with an implementation optimised + for the common case. + + Perl automatically calls the C method when processing a + C statement for a module. Modules and C are documented + in L and L. Understanding the concept of + modules and how the C statement operates is important to + understanding the Exporter. + + =head2 How to Export + + The arrays C<@EXPORT> and C<@EXPORT_OK> in a module hold lists of + symbols that are going to be exported into the users name space by + default, or which they can request to be exported, respectively. The + symbols can represent functions, scalars, arrays, hashes, or typeglobs. + The symbols must be given by full name with the exception that the + ampersand in front of a function is optional, e.g. + + @EXPORT = qw(afunc $scalar @array); # afunc is a function + @EXPORT_OK = qw(&bfunc %hash *typeglob); # explicit prefix on &bfunc + + If you are only exporting function names it is recommended to omit the + ampersand, as the implementation is faster this way. + + =head2 Selecting What to Export + + Do B export method names! + + Do B export anything else by default without a good reason! + + Exports pollute the namespace of the module user. If you must export + try to use C<@EXPORT_OK> in preference to C<@EXPORT> and avoid short or + common symbol names to reduce the risk of name clashes. + + Generally anything not exported is still accessible from outside the + module using the C (or C<< $blessed_ref->method >>) + syntax. By convention you can use a leading underscore on names to + informally indicate that they are 'internal' and not for public use. + + (It is actually possible to get private functions by saying: + + my $subref = sub { ... }; + $subref->(@args); # Call it as a function + $obj->$subref(@args); # Use it as a method + + However if you use them for methods it is up to you to figure out + how to make inheritance work.) + + As a general rule, if the module is trying to be object oriented + then export nothing. If it's just a collection of functions then + C<@EXPORT_OK> anything but use C<@EXPORT> with caution. For function and + method names use barewords in preference to names prefixed with + ampersands for the export lists. + + Other module design guidelines can be found in L. + + =head2 How to Import + + In other files which wish to use your module there are three basic ways for + them to load your module and import its symbols: + + =over 4 + + =item C + + This imports all the symbols from YourModule's C<@EXPORT> into the namespace + of the C statement. + + =item C + + This causes perl to load your module but does not import any symbols. + + =item C + + This imports only the symbols listed by the caller into their namespace. + All listed symbols must be in your C<@EXPORT> or C<@EXPORT_OK>, else an error + occurs. The advanced export features of Exporter are accessed like this, + but with list entries that are syntactically distinct from symbol names. + + =back + + Unless you want to use its advanced features, this is probably all you + need to know to use Exporter. + + =head1 Advanced Features + + =head2 Specialised Import Lists + + If any of the entries in an import list begins with !, : or / then + the list is treated as a series of specifications which either add to + or delete from the list of names to import. They are processed left to + right. Specifications are in the form: + + [!]name This name only + [!]:DEFAULT All names in @EXPORT + [!]:tag All names in $EXPORT_TAGS{tag} anonymous list + [!]/pattern/ All names in @EXPORT and @EXPORT_OK which match + + A leading ! indicates that matching names should be deleted from the + list of names to import. If the first specification is a deletion it + is treated as though preceded by :DEFAULT. If you just want to import + extra names in addition to the default set you will still need to + include :DEFAULT explicitly. + + e.g., F defines: + + @EXPORT = qw(A1 A2 A3 A4 A5); + @EXPORT_OK = qw(B1 B2 B3 B4 B5); + %EXPORT_TAGS = (T1 => [qw(A1 A2 B1 B2)], T2 => [qw(A1 A2 B3 B4)]); + + Note that you cannot use tags in @EXPORT or @EXPORT_OK. + + Names in EXPORT_TAGS must also appear in @EXPORT or @EXPORT_OK. + + An application using Module can say something like: + + use Module qw(:DEFAULT :T2 !B3 A3); + + Other examples include: + + use Socket qw(!/^[AP]F_/ !SOMAXCONN !SOL_SOCKET); + use POSIX qw(:errno_h :termios_h !TCSADRAIN !/^EXIT/); + + Remember that most patterns (using //) will need to be anchored + with a leading ^, e.g., C rather than C. + + You can say C to see how the + specifications are being processed and what is actually being imported + into modules. + + =head2 Exporting Without Using Exporter's import Method + + Exporter has a special method, 'export_to_level' which is used in situations + where you can't directly call Exporter's + import method. The export_to_level + method looks like: + + MyPackage->export_to_level( + $where_to_export, $package, @what_to_export + ); + + where C<$where_to_export> is an integer telling how far up the calling stack + to export your symbols, and C<@what_to_export> is an array telling what + symbols *to* export (usually this is C<@_>). The C<$package> argument is + currently unused. + + For example, suppose that you have a module, A, which already has an + import function: + + package A; + + @ISA = qw(Exporter); + @EXPORT_OK = qw($b); + + sub import + { + $A::b = 1; # not a very useful import method + } + + and you want to Export symbol C<$A::b> back to the module that called + package A. Since Exporter relies on the import method to work, via + inheritance, as it stands Exporter::import() will never get called. + Instead, say the following: + + package A; + @ISA = qw(Exporter); + @EXPORT_OK = qw($b); + + sub import + { + $A::b = 1; + A->export_to_level(1, @_); + } + + This will export the symbols one level 'above' the current package - ie: to + the program or module that used package A. + + Note: Be careful not to modify C<@_> at all before you call export_to_level + - or people using your package will get very unexplained results! + + =head2 Exporting Without Inheriting from Exporter + + By including Exporter in your C<@ISA> you inherit an Exporter's import() method + but you also inherit several other helper methods which you probably don't + want. To avoid this you can do: + + package YourModule; + use Exporter qw(import); + + which will export Exporter's own import() method into YourModule. + Everything will work as before but you won't need to include Exporter in + C<@YourModule::ISA>. + + Note: This feature was introduced in version 5.57 + of Exporter, released with perl 5.8.3. + + =head2 Module Version Checking + + The Exporter module will convert an attempt to import a number from a + module into a call to C<< $module_name->VERSION($value) >>. This can + be used to validate that the version of the module being used is + greater than or equal to the required version. + + For historical reasons, Exporter supplies a C method that + simply delegates to C. Originally, before C + existed, Exporter would call C. + + Since the C method treats the C<$VERSION> number as + a simple numeric value it will regard version 1.10 as lower than + 1.9. For this reason it is strongly recommended that you use numbers + with at least two decimal places, e.g., 1.09. + + =head2 Managing Unknown Symbols + + In some situations you may want to prevent certain symbols from being + exported. Typically this applies to extensions which have functions + or constants that may not exist on some systems. + + The names of any symbols that cannot be exported should be listed + in the C<@EXPORT_FAIL> array. + + If a module attempts to import any of these symbols the Exporter + will give the module an opportunity to handle the situation before + generating an error. The Exporter will call an export_fail method + with a list of the failed symbols: + + @failed_symbols = $module_name->export_fail(@failed_symbols); + + If the C method returns an empty list then no error is + recorded and all the requested symbols are exported. If the returned + list is not empty then an error is generated for each symbol and the + export fails. The Exporter provides a default C method which + simply returns the list unchanged. + + Uses for the C method include giving better error messages + for some symbols and performing lazy architectural checks (put more + symbols into C<@EXPORT_FAIL> by default and then take them out if someone + actually tries to use them and an expensive check shows that they are + usable on that platform). + + =head2 Tag Handling Utility Functions + + Since the symbols listed within C<%EXPORT_TAGS> must also appear in either + C<@EXPORT> or C<@EXPORT_OK>, two utility functions are provided which allow + you to easily add tagged sets of symbols to C<@EXPORT> or C<@EXPORT_OK>: + + %EXPORT_TAGS = (foo => [qw(aa bb cc)], bar => [qw(aa cc dd)]); + + Exporter::export_tags('foo'); # add aa, bb and cc to @EXPORT + Exporter::export_ok_tags('bar'); # add aa, cc and dd to @EXPORT_OK + + Any names which are not tags are added to C<@EXPORT> or C<@EXPORT_OK> + unchanged but will trigger a warning (with C<-w>) to avoid misspelt tags + names being silently added to C<@EXPORT> or C<@EXPORT_OK>. Future versions + may make this a fatal error. + + =head2 Generating Combined Tags + + If several symbol categories exist in C<%EXPORT_TAGS>, it's usually + useful to create the utility ":all" to simplify "use" statements. + + The simplest way to do this is: + + %EXPORT_TAGS = (foo => [qw(aa bb cc)], bar => [qw(aa cc dd)]); + + # add all the other ":class" tags to the ":all" class, + # deleting duplicates + { + my %seen; + + push @{$EXPORT_TAGS{all}}, + grep {!$seen{$_}++} @{$EXPORT_TAGS{$_}} foreach keys %EXPORT_TAGS; + } + + F creates an ":all" tag which contains some (but not really + all) of its categories. That could be done with one small + change: + + # add some of the other ":class" tags to the ":all" class, + # deleting duplicates + { + my %seen; + + push @{$EXPORT_TAGS{all}}, + grep {!$seen{$_}++} @{$EXPORT_TAGS{$_}} + foreach qw/html2 html3 netscape form cgi internal/; + } + + Note that the tag names in C<%EXPORT_TAGS> don't have the leading ':'. + + =head2 Ced Constants + + Many modules make use of Cing for constant subroutines to + avoid having to compile and waste memory on rarely used values (see + L for details on constant subroutines). Calls to such + constant subroutines are not optimized away at compile time because + they can't be checked at compile time for constancy. + + Even if a prototype is available at compile time, the body of the + subroutine is not (it hasn't been Ced yet). perl needs to + examine both the C<()> prototype and the body of a subroutine at + compile time to detect that it can safely replace calls to that + subroutine with the constant value. + + A workaround for this is to call the constants once in a C block: + + package My ; + + use Socket ; + + foo( SO_LINGER ); ## SO_LINGER NOT optimized away; called at runtime + BEGIN { SO_LINGER } + foo( SO_LINGER ); ## SO_LINGER optimized away at compile time. + + This forces the C for C to take place before + SO_LINGER is encountered later in C package. + + If you are writing a package that Cs, consider forcing + an C for any constants explicitly imported by other packages + or which are usually used when your package is Cd. + + =head1 Good Practices + + =head2 Declaring C<@EXPORT_OK> and Friends + + When using C with the standard C and C + pragmas, the C keyword is needed to declare the package + variables C<@EXPORT_OK>, C<@EXPORT>, C<@ISA>, etc. + + our @ISA = qw(Exporter); + our @EXPORT_OK = qw(munge frobnicate); + + If backward compatibility for Perls under 5.6 is important, + one must write instead a C statement. + + use vars qw(@ISA @EXPORT_OK); + @ISA = qw(Exporter); + @EXPORT_OK = qw(munge frobnicate); + + =head2 Playing Safe + + There are some caveats with the use of runtime statements + like C and the assignment to package + variables, which can be very subtle for the unaware programmer. + This may happen for instance with mutually recursive + modules, which are affected by the time the relevant + constructions are executed. + + The ideal (but a bit ugly) way to never have to think + about that is to use C blocks. So the first part + of the L code could be rewritten as: + + package YourModule; + + use strict; + use warnings; + + our (@ISA, @EXPORT_OK); + BEGIN { + require Exporter; + @ISA = qw(Exporter); + @EXPORT_OK = qw(munge frobnicate); # symbols to export on request + } + + The C will assure that the loading of F + and the assignments to C<@ISA> and C<@EXPORT_OK> happen + immediately, leaving no room for something to get awry + or just plain wrong. + + With respect to loading C and inheriting, there + are alternatives with the use of modules like C and C. + + use base qw(Exporter); + # or + use parent qw(Exporter); + + Any of these statements are nice replacements for + C + with the same compile-time effect. The basic difference + is that C code interacts with declared C + while C is a streamlined version of the older + C code to just establish the IS-A relationship. + + For more details, see the documentation and code of + L and L. + + Another thorough remedy to that runtime + vs. compile-time trap is to use L, + which is a wrapper of Exporter that allows all + boilerplate code at a single gulp in the + use statement. + + use Exporter::Easy ( + OK => [ qw(munge frobnicate) ], + ); + # @ISA setup is automatic + # all assignments happen at compile time + + =head2 What Not to Export + + You have been warned already in L + to not export: + + =over 4 + + =item * + + method names (because you don't need to + and that's likely to not do what you want), + + =item * + + anything by default (because you don't want to surprise your users... + badly) + + =item * + + anything you don't need to (because less is more) + + =back + + There's one more item to add to this list. Do B + export variable names. Just because C lets you + do that, it does not mean you should. + + @EXPORT_OK = qw($svar @avar %hvar); # DON'T! + + Exporting variables is not a good idea. They can + change under the hood, provoking horrible + effects at-a-distance that are too hard to track + and to fix. Trust me: they are not worth it. + + To provide the capability to set/get class-wide + settings, it is best instead to provide accessors + as subroutines or class methods instead. + + =head1 SEE ALSO + + C is definitely not the only module with + symbol exporter capabilities. At CPAN, you may find + a bunch of them. Some are lighter. Some + provide improved APIs and features. Pick the one + that fits your needs. The following is + a sample list of such modules. + + Exporter::Easy + Exporter::Lite + Exporter::Renaming + Exporter::Tidy + Sub::Exporter / Sub::Installer + Perl6::Export / Perl6::Export::Attrs + + =head1 LICENSE + + This library is free software. You can redistribute it + and/or modify it under the same terms as Perl itself. + + =cut + + + + EXPORTER + + $fatpacked{"Exporter/Heavy.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXPORTER_HEAVY'; + package Exporter::Heavy; + + use strict; + no strict 'refs'; + + # On one line so MakeMaker will see it. + require Exporter; our $VERSION = $Exporter::VERSION; + + =head1 NAME + + Exporter::Heavy - Exporter guts + + =head1 SYNOPSIS + + (internal use only) + + =head1 DESCRIPTION + + No user-serviceable parts inside. + + =cut + + # + # We go to a lot of trouble not to 'require Carp' at file scope, + # because Carp requires Exporter, and something has to give. + # + + sub _rebuild_cache { + my ($pkg, $exports, $cache) = @_; + s/^&// foreach @$exports; + @{$cache}{@$exports} = (1) x @$exports; + my $ok = \@{"${pkg}::EXPORT_OK"}; + if (@$ok) { + s/^&// foreach @$ok; + @{$cache}{@$ok} = (1) x @$ok; + } + } + + sub heavy_export { + + # Save the old __WARN__ handler in case it was defined + my $oldwarn = $SIG{__WARN__}; + + # First make import warnings look like they're coming from the "use". + local $SIG{__WARN__} = sub { + # restore it back so proper stacking occurs + local $SIG{__WARN__} = $oldwarn; + my $text = shift; + if ($text =~ s/ at \S*Exporter\S*.pm line \d+.*\n//) { + require Carp; + local $Carp::CarpLevel = 1; # ignore package calling us too. + Carp::carp($text); + } + else { + warn $text; + } + }; + local $SIG{__DIE__} = sub { + require Carp; + local $Carp::CarpLevel = 1; # ignore package calling us too. + Carp::croak("$_[0]Illegal null symbol in \@${1}::EXPORT") + if $_[0] =~ /^Unable to create sub named "(.*?)::"/; + }; + + my($pkg, $callpkg, @imports) = @_; + my($type, $sym, $cache_is_current, $oops); + my($exports, $export_cache) = (\@{"${pkg}::EXPORT"}, + $Exporter::Cache{$pkg} ||= {}); + + if (@imports) { + if (!%$export_cache) { + _rebuild_cache ($pkg, $exports, $export_cache); + $cache_is_current = 1; + } + + if (grep m{^[/!:]}, @imports) { + my $tagsref = \%{"${pkg}::EXPORT_TAGS"}; + my $tagdata; + my %imports; + my($remove, $spec, @names, @allexports); + # negated first item implies starting with default set: + unshift @imports, ':DEFAULT' if $imports[0] =~ m/^!/; + foreach $spec (@imports){ + $remove = $spec =~ s/^!//; + + if ($spec =~ s/^://){ + if ($spec eq 'DEFAULT'){ + @names = @$exports; + } + elsif ($tagdata = $tagsref->{$spec}) { + @names = @$tagdata; + } + else { + warn qq["$spec" is not defined in %${pkg}::EXPORT_TAGS]; + ++$oops; + next; + } + } + elsif ($spec =~ m:^/(.*)/$:){ + my $patn = $1; + @allexports = keys %$export_cache unless @allexports; # only do keys once + @names = grep(/$patn/, @allexports); # not anchored by default + } + else { + @names = ($spec); # is a normal symbol name + } + + warn "Import ".($remove ? "del":"add").": @names " + if $Exporter::Verbose; + + if ($remove) { + foreach $sym (@names) { delete $imports{$sym} } + } + else { + @imports{@names} = (1) x @names; + } + } + @imports = keys %imports; + } + + my @carp; + foreach $sym (@imports) { + if (!$export_cache->{$sym}) { + if ($sym =~ m/^\d/) { + $pkg->VERSION($sym); # inherit from UNIVERSAL + # If the version number was the only thing specified + # then we should act as if nothing was specified: + if (@imports == 1) { + @imports = @$exports; + last; + } + # We need a way to emulate 'use Foo ()' but still + # allow an easy version check: "use Foo 1.23, ''"; + if (@imports == 2 and !$imports[1]) { + @imports = (); + last; + } + } elsif ($sym !~ s/^&// || !$export_cache->{$sym}) { + # Last chance - see if they've updated EXPORT_OK since we + # cached it. + + unless ($cache_is_current) { + %$export_cache = (); + _rebuild_cache ($pkg, $exports, $export_cache); + $cache_is_current = 1; + } + + if (!$export_cache->{$sym}) { + # accumulate the non-exports + push @carp, + qq["$sym" is not exported by the $pkg module\n]; + $oops++; + } + } + } + } + if ($oops) { + require Carp; + Carp::croak("@{carp}Can't continue after import errors"); + } + } + else { + @imports = @$exports; + } + + my($fail, $fail_cache) = (\@{"${pkg}::EXPORT_FAIL"}, + $Exporter::FailCache{$pkg} ||= {}); + + if (@$fail) { + if (!%$fail_cache) { + # Build cache of symbols. Optimise the lookup by adding + # barewords twice... both with and without a leading &. + # (Technique could be applied to $export_cache at cost of memory) + my @expanded = map { /^\w/ ? ($_, '&'.$_) : $_ } @$fail; + warn "${pkg}::EXPORT_FAIL cached: @expanded" if $Exporter::Verbose; + @{$fail_cache}{@expanded} = (1) x @expanded; + } + my @failed; + foreach $sym (@imports) { push(@failed, $sym) if $fail_cache->{$sym} } + if (@failed) { + @failed = $pkg->export_fail(@failed); + foreach $sym (@failed) { + require Carp; + Carp::carp(qq["$sym" is not implemented by the $pkg module ], + "on this architecture"); + } + if (@failed) { + require Carp; + Carp::croak("Can't continue after import errors"); + } + } + } + + warn "Importing into $callpkg from $pkg: ", + join(", ",sort @imports) if $Exporter::Verbose; + + foreach $sym (@imports) { + # shortcut for the common case of no type character + (*{"${callpkg}::$sym"} = \&{"${pkg}::$sym"}, next) + unless $sym =~ s/^(\W)//; + $type = $1; + no warnings 'once'; + *{"${callpkg}::$sym"} = + $type eq '&' ? \&{"${pkg}::$sym"} : + $type eq '$' ? \${"${pkg}::$sym"} : + $type eq '@' ? \@{"${pkg}::$sym"} : + $type eq '%' ? \%{"${pkg}::$sym"} : + $type eq '*' ? *{"${pkg}::$sym"} : + do { require Carp; Carp::croak("Can't export symbol: $type$sym") }; + } + } + + sub heavy_export_to_level + { + my $pkg = shift; + my $level = shift; + (undef) = shift; # XXX redundant arg + my $callpkg = caller($level); + $pkg->export($callpkg, @_); + } + + # Utility functions + + sub _push_tags { + my($pkg, $var, $syms) = @_; + my @nontag = (); + my $export_tags = \%{"${pkg}::EXPORT_TAGS"}; + push(@{"${pkg}::$var"}, + map { $export_tags->{$_} ? @{$export_tags->{$_}} + : scalar(push(@nontag,$_),$_) } + (@$syms) ? @$syms : keys %$export_tags); + if (@nontag and $^W) { + # This may change to a die one day + require Carp; + Carp::carp(join(", ", @nontag)." are not tags of $pkg"); + } + } + + sub heavy_require_version { + my($self, $wanted) = @_; + my $pkg = ref $self || $self; + return ${pkg}->VERSION($wanted); + } + + sub heavy_export_tags { + _push_tags((caller)[0], "EXPORT", \@_); + } + + sub heavy_export_ok_tags { + _push_tags((caller)[0], "EXPORT_OK", \@_); + } + + 1; + EXPORTER_HEAVY + + $fatpacked{"File/pushd.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'FILE_PUSHD'; + use strict; + use warnings; + + package File::pushd; + # ABSTRACT: change directory temporarily for a limited scope + our $VERSION = '1.009'; # VERSION + + our @EXPORT = qw( pushd tempd ); + our @ISA = qw( Exporter ); + + use Exporter; + use Carp; + use Cwd qw( getcwd abs_path ); + use File::Path qw( rmtree ); + use File::Temp qw(); + use File::Spec; + + use overload + q{""} => sub { File::Spec->canonpath( $_[0]->{_pushd} ) }, + fallback => 1; + + #--------------------------------------------------------------------------# + # pushd() + #--------------------------------------------------------------------------# + + sub pushd { + my ( $target_dir, $options ) = @_; + $options->{untaint_pattern} ||= qr{^([-+@\w./]+)$}; + + $target_dir = "." unless defined $target_dir; + croak "Can't locate directory $target_dir" unless -d $target_dir; + + my $tainted_orig = getcwd; + my $orig; + if ( $tainted_orig =~ $options->{untaint_pattern} ) { + $orig = $1; + } + else { + $orig = $tainted_orig; + } + + my $tainted_dest; + eval { $tainted_dest = $target_dir ? abs_path($target_dir) : $orig }; + croak "Can't locate absolute path for $target_dir: $@" if $@; + + my $dest; + if ( $tainted_dest =~ $options->{untaint_pattern} ) { + $dest = $1; + } + else { + $dest = $tainted_dest; + } + + if ( $dest ne $orig ) { + chdir $dest or croak "Can't chdir to $dest\: $!"; + } + + my $self = bless { + _pushd => $dest, + _original => $orig + }, + __PACKAGE__; + + return $self; + } + + #--------------------------------------------------------------------------# + # tempd() + #--------------------------------------------------------------------------# + + sub tempd { + my ($options) = @_; + my $dir; + eval { $dir = pushd( File::Temp::tempdir( CLEANUP => 0 ), $options ) }; + croak $@ if $@; + $dir->{_tempd} = 1; + return $dir; + } + + #--------------------------------------------------------------------------# + # preserve() + #--------------------------------------------------------------------------# + + sub preserve { + my $self = shift; + return 1 if !$self->{"_tempd"}; + if ( @_ == 0 ) { + return $self->{_preserve} = 1; + } + else { + return $self->{_preserve} = $_[0] ? 1 : 0; + } + } + + #--------------------------------------------------------------------------# + # DESTROY() + # Revert to original directory as object is destroyed and cleanup + # if necessary + #--------------------------------------------------------------------------# + + sub DESTROY { + my ($self) = @_; + my $orig = $self->{_original}; + chdir $orig if $orig; # should always be so, but just in case... + if ( $self->{_tempd} + && !$self->{_preserve} ) + { + # don't destroy existing $@ if there is no error. + my $err = do { + local $@; + eval { rmtree( $self->{_pushd} ) }; + $@; + }; + carp $err if $err; + } + } + + 1; + + =pod + + =encoding UTF-8 + + =head1 NAME + + File::pushd - change directory temporarily for a limited scope + + =head1 VERSION + + version 1.009 + + =head1 SYNOPSIS + + use File::pushd; + + chdir $ENV{HOME}; + + # change directory again for a limited scope + { + my $dir = pushd( '/tmp' ); + # working directory changed to /tmp + } + # working directory has reverted to $ENV{HOME} + + # tempd() is equivalent to pushd( File::Temp::tempdir ) + { + my $dir = tempd(); + } + + # object stringifies naturally as an absolute path + { + my $dir = pushd( '/tmp' ); + my $filename = File::Spec->catfile( $dir, "somefile.txt" ); + # gives /tmp/somefile.txt + } + + =head1 DESCRIPTION + + File::pushd does a temporary C that is easily and automatically + reverted, similar to C in some Unix command shells. It works by + creating an object that caches the original working directory. When the object + is destroyed, the destructor calls C to revert to the original working + directory. By storing the object in a lexical variable with a limited scope, + this happens automatically at the end of the scope. + + This is very handy when working with temporary directories for tasks like + testing; a function is provided to streamline getting a temporary + directory from L. + + For convenience, the object stringifies as the canonical form of the absolute + pathname of the directory entered. + + B: if you create multiple C objects in the same lexical scope, + their destruction order is not guaranteed and you might not wind up in the + directory you expect. + + =head1 USAGE + + use File::pushd; + + Using File::pushd automatically imports the C and C functions. + + =head2 pushd + + { + my $dir = pushd( $target_directory ); + } + + Caches the current working directory, calls C to change to the target + directory, and returns a File::pushd object. When the object is + destroyed, the working directory reverts to the original directory. + + The provided target directory can be a relative or absolute path. If + called with no arguments, it uses the current directory as its target and + returns to the current directory when the object is destroyed. + + If the target directory does not exist or if the directory change fails + for some reason, C will die with an error message. + + Can be given a hashref as an optional second argument. The only supported + option is C, which is used to untaint file paths involved. + It defaults to {qr{^(L<-+@\w./>+)$}}, which is reasonably restrictive (e.g. + it does not even allow spaces in the path). Change this to suit your + circumstances and security needs if running under taint mode. *Note*: you + must include the parentheses in the pattern to capture the untainted + portion of the path. + + =head2 tempd + + { + my $dir = tempd(); + } + + This function is like C but automatically creates and calls C to + a temporary directory created by L. Unlike normal L + cleanup which happens at the end of the program, this temporary directory is + removed when the object is destroyed. (But also see C.) A warning + will be issued if the directory cannot be removed. + + As with C, C will die if C fails. + + It may be given a single options hash that will be passed internally + to C. + + =head2 preserve + + { + my $dir = tempd(); + $dir->preserve; # mark to preserve at end of scope + $dir->preserve(0); # mark to delete at end of scope + } + + Controls whether a temporary directory will be cleaned up when the object is + destroyed. With no arguments, C sets the directory to be preserved. + With an argument, the directory will be preserved if the argument is true, or + marked for cleanup if the argument is false. Only C objects may be + marked for cleanup. (Target directories to C are always preserved.) + C returns true if the directory will be preserved, and false + otherwise. + + =head1 SEE ALSO + + =over 4 + + =item * + + L + + =back + + =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan + + =head1 SUPPORT + + =head2 Bugs / Feature Requests + + Please report any bugs or feature requests through the issue tracker + at L. + You will be notified automatically of any progress on your issue. + + =head2 Source Code + + This is open source software. The code repository is available for + public review and contribution under the terms of the license. + + L + + git clone https://github.com/dagolden/File-pushd.git + + =head1 AUTHOR + + David Golden + + =head1 CONTRIBUTORS + + =over 4 + + =item * + + Diab Jerius + + =item * + + Graham Ollis + + =back + + =head1 COPYRIGHT AND LICENSE + + This software is Copyright (c) 2014 by David A Golden. + + This is free software, licensed under: + + The Apache License, Version 2.0, January 2004 + + =cut + + __END__ + + + # vim: ts=4 sts=4 sw=4 et: + FILE_PUSHD + + $fatpacked{"HTTP/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_TINY'; + # vim: ts=4 sts=4 sw=4 et: + package HTTP::Tiny; + use strict; + use warnings; + # ABSTRACT: A small, simple, correct HTTP/1.1 client + + our $VERSION = '0.056'; + + use Carp (); + + #pod =method new + #pod + #pod $http = HTTP::Tiny->new( %attributes ); + #pod + #pod This constructor returns a new HTTP::Tiny object. Valid attributes include: + #pod + #pod =for :list + #pod * C — + #pod A user-agent string (defaults to 'HTTP-Tiny/$VERSION'). If C — ends in a space character, the default user-agent string is appended. + #pod * C — + #pod An instance of L — or equivalent class that supports the C and C methods + #pod * C — + #pod A hashref of default headers to apply to requests + #pod * C — + #pod The local IP address to bind to + #pod * C — + #pod Whether to reuse the last connection (if for the same scheme, host and port) (defaults to 1) + #pod * C — + #pod Maximum number of redirects allowed (defaults to 5) + #pod * C — + #pod Maximum response size in bytes (only when not using a data callback). If defined, responses larger than this will return an exception. + #pod * C — + #pod URL of a proxy server to use for HTTP connections (default is C<$ENV{http_proxy}> — if set) + #pod * C — + #pod URL of a proxy server to use for HTTPS connections (default is C<$ENV{https_proxy}> — if set) + #pod * C — + #pod URL of a generic proxy server for both HTTP and HTTPS connections (default is C<$ENV{all_proxy}> — if set) + #pod * C — + #pod List of domain suffixes that should not be proxied. Must be a comma-separated string or an array reference. (default is C<$ENV{no_proxy}> —) + #pod * C — + #pod Request timeout in seconds (default is 60) + #pod * C — + #pod A boolean that indicates whether to validate the SSL certificate of an C — + #pod connection (default is false) + #pod * C — + #pod A hashref of C — options to pass through to L + #pod + #pod Passing an explicit C for C, C or C will + #pod prevent getting the corresponding proxies from the environment. + #pod + #pod Exceptions from C, C or other errors will result in a + #pod pseudo-HTTP status code of 599 and a reason of "Internal Exception". The + #pod content field in the response will contain the text of the exception. + #pod + #pod The C parameter enables a persistent connection, but only to a + #pod single destination scheme, host and port. Also, if any connection-relevant + #pod attributes are modified, or if the process ID or thread ID change, the + #pod persistent connection will be dropped. If you want persistent connections + #pod across multiple destinations, use multiple HTTP::Tiny objects. + #pod + #pod See L for more on the C and C attributes. + #pod + #pod =cut + + my @attributes; + BEGIN { + @attributes = qw( + cookie_jar default_headers http_proxy https_proxy keep_alive + local_address max_redirect max_size proxy no_proxy timeout + SSL_options verify_SSL + ); + my %persist_ok = map {; $_ => 1 } qw( + cookie_jar default_headers max_redirect max_size + ); + no strict 'refs'; + no warnings 'uninitialized'; + for my $accessor ( @attributes ) { + *{$accessor} = sub { + @_ > 1 + ? do { + delete $_[0]->{handle} if !$persist_ok{$accessor} && $_[1] ne $_[0]->{$accessor}; + $_[0]->{$accessor} = $_[1] + } + : $_[0]->{$accessor}; + }; + } + } + + sub agent { + my($self, $agent) = @_; + if( @_ > 1 ){ + $self->{agent} = + (defined $agent && $agent =~ / $/) ? $agent . $self->_agent : $agent; + } + return $self->{agent}; + } + + sub new { + my($class, %args) = @_; + + my $self = { + max_redirect => 5, + timeout => 60, + keep_alive => 1, + verify_SSL => $args{verify_SSL} || $args{verify_ssl} || 0, # no verification by default + no_proxy => $ENV{no_proxy}, + }; + + bless $self, $class; + + $class->_validate_cookie_jar( $args{cookie_jar} ) if $args{cookie_jar}; + + for my $key ( @attributes ) { + $self->{$key} = $args{$key} if exists $args{$key} + } + + $self->agent( exists $args{agent} ? $args{agent} : $class->_agent ); + + $self->_set_proxies; + + return $self; + } + + sub _set_proxies { + my ($self) = @_; + + # get proxies from %ENV only if not provided; explicit undef will disable + # getting proxies from the environment + + # generic proxy + if (! exists $self->{proxy} ) { + $self->{proxy} = $ENV{all_proxy} || $ENV{ALL_PROXY}; + } + + if ( defined $self->{proxy} ) { + $self->_split_proxy( 'generic proxy' => $self->{proxy} ); # validate + } + else { + delete $self->{proxy}; + } + + # http proxy + if (! exists $self->{http_proxy} ) { + # under CGI, bypass HTTP_PROXY as request sets it from Proxy header + local $ENV{HTTP_PROXY} if $ENV{REQUEST_METHOD}; + $self->{http_proxy} = $ENV{http_proxy} || $ENV{HTTP_PROXY} || $self->{proxy}; + } + + if ( defined $self->{http_proxy} ) { + $self->_split_proxy( http_proxy => $self->{http_proxy} ); # validate + $self->{_has_proxy}{http} = 1; + } + else { + delete $self->{http_proxy}; + } + + # https proxy + if (! exists $self->{https_proxy} ) { + $self->{https_proxy} = $ENV{https_proxy} || $ENV{HTTPS_PROXY} || $self->{proxy}; + } + + if ( $self->{https_proxy} ) { + $self->_split_proxy( https_proxy => $self->{https_proxy} ); # validate + $self->{_has_proxy}{https} = 1; + } + else { + delete $self->{https_proxy}; + } + + # Split no_proxy to array reference if not provided as such + unless ( ref $self->{no_proxy} eq 'ARRAY' ) { + $self->{no_proxy} = + (defined $self->{no_proxy}) ? [ split /\s*,\s*/, $self->{no_proxy} ] : []; + } + + return; + } + + #pod =method get|head|put|post|delete + #pod + #pod $response = $http->get($url); + #pod $response = $http->get($url, \%options); + #pod $response = $http->head($url); + #pod + #pod These methods are shorthand for calling C for the given method. The + #pod URL must have unsafe characters escaped and international domain names encoded. + #pod See C for valid options and a description of the response. + #pod + #pod The C field of the response will be true if the status code is 2XX. + #pod + #pod =cut + + for my $sub_name ( qw/get head put post delete/ ) { + my $req_method = uc $sub_name; + no strict 'refs'; + eval <<"HERE"; ## no critic + sub $sub_name { + my (\$self, \$url, \$args) = \@_; + \@_ == 2 || (\@_ == 3 && ref \$args eq 'HASH') + or Carp::croak(q/Usage: \$http->$sub_name(URL, [HASHREF])/ . "\n"); + return \$self->request('$req_method', \$url, \$args || {}); + } + HERE + } + + #pod =method post_form + #pod + #pod $response = $http->post_form($url, $form_data); + #pod $response = $http->post_form($url, $form_data, \%options); + #pod + #pod This method executes a C request and sends the key/value pairs from a + #pod form data hash or array reference to the given URL with a C of + #pod C. If data is provided as an array + #pod reference, the order is preserved; if provided as a hash reference, the terms + #pod are sorted on key and value for consistency. See documentation for the + #pod C method for details on the encoding. + #pod + #pod The URL must have unsafe characters escaped and international domain names + #pod encoded. See C for valid options and a description of the response. + #pod Any C header or content in the options hashref will be ignored. + #pod + #pod The C field of the response will be true if the status code is 2XX. + #pod + #pod =cut + + sub post_form { + my ($self, $url, $data, $args) = @_; + (@_ == 3 || @_ == 4 && ref $args eq 'HASH') + or Carp::croak(q/Usage: $http->post_form(URL, DATAREF, [HASHREF])/ . "\n"); + + my $headers = {}; + while ( my ($key, $value) = each %{$args->{headers} || {}} ) { + $headers->{lc $key} = $value; + } + delete $args->{headers}; + + return $self->request('POST', $url, { + %$args, + content => $self->www_form_urlencode($data), + headers => { + %$headers, + 'content-type' => 'application/x-www-form-urlencoded' + }, + } + ); + } + + #pod =method mirror + #pod + #pod $response = $http->mirror($url, $file, \%options) + #pod if ( $response->{success} ) { + #pod print "$file is up to date\n"; + #pod } + #pod + #pod Executes a C request for the URL and saves the response body to the file + #pod name provided. The URL must have unsafe characters escaped and international + #pod domain names encoded. If the file already exists, the request will include an + #pod C header with the modification timestamp of the file. You + #pod may specify a different C header yourself in the C<< + #pod $options->{headers} >> hash. + #pod + #pod The C field of the response will be true if the status code is 2XX + #pod or if the status code is 304 (unmodified). + #pod + #pod If the file was modified and the server response includes a properly + #pod formatted C header, the file modification time will + #pod be updated accordingly. + #pod + #pod =cut + + sub mirror { + my ($self, $url, $file, $args) = @_; + @_ == 3 || (@_ == 4 && ref $args eq 'HASH') + or Carp::croak(q/Usage: $http->mirror(URL, FILE, [HASHREF])/ . "\n"); + if ( -e $file and my $mtime = (stat($file))[9] ) { + $args->{headers}{'if-modified-since'} ||= $self->_http_date($mtime); + } + my $tempfile = $file . int(rand(2**31)); + + require Fcntl; + sysopen my $fh, $tempfile, Fcntl::O_CREAT()|Fcntl::O_EXCL()|Fcntl::O_WRONLY() + or Carp::croak(qq/Error: Could not create temporary file $tempfile for downloading: $!\n/); + binmode $fh; + $args->{data_callback} = sub { print {$fh} $_[0] }; + my $response = $self->request('GET', $url, $args); + close $fh + or Carp::croak(qq/Error: Caught error closing temporary file $tempfile: $!\n/); + + if ( $response->{success} ) { + rename $tempfile, $file + or Carp::croak(qq/Error replacing $file with $tempfile: $!\n/); + my $lm = $response->{headers}{'last-modified'}; + if ( $lm and my $mtime = $self->_parse_http_date($lm) ) { + utime $mtime, $mtime, $file; + } + } + $response->{success} ||= $response->{status} eq '304'; + unlink $tempfile; + return $response; + } + + #pod =method request + #pod + #pod $response = $http->request($method, $url); + #pod $response = $http->request($method, $url, \%options); + #pod + #pod Executes an HTTP request of the given method type ('GET', 'HEAD', 'POST', + #pod 'PUT', etc.) on the given URL. The URL must have unsafe characters escaped and + #pod international domain names encoded. + #pod + #pod If the URL includes a "user:password" stanza, they will be used for Basic-style + #pod authorization headers. (Authorization headers will not be included in a + #pod redirected request.) For example: + #pod + #pod $http->request('GET', 'http://Aladdin:open sesame@example.com/'); + #pod + #pod If the "user:password" stanza contains reserved characters, they must + #pod be percent-escaped: + #pod + #pod $http->request('GET', 'http://john%40example.com:password@example.com/'); + #pod + #pod A hashref of options may be appended to modify the request. + #pod + #pod Valid options are: + #pod + #pod =for :list + #pod * C — + #pod A hashref containing headers to include with the request. If the value for + #pod a header is an array reference, the header will be output multiple times with + #pod each value in the array. These headers over-write any default headers. + #pod * C — + #pod A scalar to include as the body of the request OR a code reference + #pod that will be called iteratively to produce the body of the request + #pod * C — + #pod A code reference that will be called if it exists to provide a hashref + #pod of trailing headers (only used with chunked transfer-encoding) + #pod * C — + #pod A code reference that will be called for each chunks of the response + #pod body received. + #pod + #pod The C header is generated from the URL in accordance with RFC 2616. It + #pod is a fatal error to specify C in the C option. Other headers + #pod may be ignored or overwritten if necessary for transport compliance. + #pod + #pod If the C option is a code reference, it will be called iteratively + #pod to provide the content body of the request. It should return the empty + #pod string or undef when the iterator is exhausted. + #pod + #pod If the C option is the empty string, no C or + #pod C headers will be generated. + #pod + #pod If the C option is provided, it will be called iteratively until + #pod the entire response body is received. The first argument will be a string + #pod containing a chunk of the response body, the second argument will be the + #pod in-progress response hash reference, as described below. (This allows + #pod customizing the action of the callback based on the C or C + #pod received prior to the content body.) + #pod + #pod The C method returns a hashref containing the response. The hashref + #pod will have the following keys: + #pod + #pod =for :list + #pod * C — + #pod Boolean indicating whether the operation returned a 2XX status code + #pod * C — + #pod URL that provided the response. This is the URL of the request unless + #pod there were redirections, in which case it is the last URL queried + #pod in a redirection chain + #pod * C — + #pod The HTTP status code of the response + #pod * C — + #pod The response phrase returned by the server + #pod * C — + #pod The body of the response. If the response does not have any content + #pod or if a data callback is provided to consume the response body, + #pod this will be the empty string + #pod * C — + #pod A hashref of header fields. All header field names will be normalized + #pod to be lower case. If a header is repeated, the value will be an arrayref; + #pod it will otherwise be a scalar string containing the value + #pod + #pod On an exception during the execution of the request, the C field will + #pod contain 599, and the C field will contain the text of the exception. + #pod + #pod =cut + + my %idempotent = map { $_ => 1 } qw/GET HEAD PUT DELETE OPTIONS TRACE/; + + sub request { + my ($self, $method, $url, $args) = @_; + @_ == 3 || (@_ == 4 && ref $args eq 'HASH') + or Carp::croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/ . "\n"); + $args ||= {}; # we keep some state in this during _request + + # RFC 2616 Section 8.1.4 mandates a single retry on broken socket + my $response; + for ( 0 .. 1 ) { + $response = eval { $self->_request($method, $url, $args) }; + last unless $@ && $idempotent{$method} + && $@ =~ m{^(?:Socket closed|Unexpected end)}; + } + + if (my $e = $@) { + # maybe we got a response hash thrown from somewhere deep + if ( ref $e eq 'HASH' && exists $e->{status} ) { + return $e; + } + + # otherwise, stringify it + $e = "$e"; + $response = { + url => $url, + success => q{}, + status => 599, + reason => 'Internal Exception', + content => $e, + headers => { + 'content-type' => 'text/plain', + 'content-length' => length $e, + } + }; + } + return $response; + } + + #pod =method www_form_urlencode + #pod + #pod $params = $http->www_form_urlencode( $data ); + #pod $response = $http->get("http://example.com/query?$params"); + #pod + #pod This method converts the key/value pairs from a data hash or array reference + #pod into a C string. The keys and values from the data + #pod reference will be UTF-8 encoded and escaped per RFC 3986. If a value is an + #pod array reference, the key will be repeated with each of the values of the array + #pod reference. If data is provided as a hash reference, the key/value pairs in the + #pod resulting string will be sorted by key and value for consistent ordering. + #pod + #pod =cut + + sub www_form_urlencode { + my ($self, $data) = @_; + (@_ == 2 && ref $data) + or Carp::croak(q/Usage: $http->www_form_urlencode(DATAREF)/ . "\n"); + (ref $data eq 'HASH' || ref $data eq 'ARRAY') + or Carp::croak("form data must be a hash or array reference\n"); + + my @params = ref $data eq 'HASH' ? %$data : @$data; + @params % 2 == 0 + or Carp::croak("form data reference must have an even number of terms\n"); + + my @terms; + while( @params ) { + my ($key, $value) = splice(@params, 0, 2); + if ( ref $value eq 'ARRAY' ) { + unshift @params, map { $key => $_ } @$value; + } + else { + push @terms, join("=", map { $self->_uri_escape($_) } $key, $value); + } + } + + return join("&", (ref $data eq 'ARRAY') ? (@terms) : (sort @terms) ); + } + + #pod =method can_ssl + #pod + #pod $ok = HTTP::Tiny->can_ssl; + #pod ($ok, $why) = HTTP::Tiny->can_ssl; + #pod ($ok, $why) = $http->can_ssl; + #pod + #pod Indicates if SSL support is available. When called as a class object, it + #pod checks for the correct version of L and L. + #pod When called as an object methods, if C is true or if C + #pod is set in C, it checks that a CA file is available. + #pod + #pod In scalar context, returns a boolean indicating if SSL is available. + #pod In list context, returns the boolean and a (possibly multi-line) string of + #pod errors indicating why SSL isn't available. + #pod + #pod =cut + + sub can_ssl { + my ($self) = @_; + + my($ok, $reason) = (1, ''); + + # Need IO::Socket::SSL 1.42 for SSL_create_ctx_callback + unless (eval {require IO::Socket::SSL; IO::Socket::SSL->VERSION(1.42)}) { + $ok = 0; + $reason .= qq/IO::Socket::SSL 1.42 must be installed for https support\n/; + } + + # Need Net::SSLeay 1.49 for MODE_AUTO_RETRY + unless (eval {require Net::SSLeay; Net::SSLeay->VERSION(1.49)}) { + $ok = 0; + $reason .= qq/Net::SSLeay 1.49 must be installed for https support\n/; + } + + # If an object, check that SSL config lets us get a CA if necessary + if ( ref($self) && ( $self->{verify_SSL} || $self->{SSL_options}{SSL_verify_mode} ) ) { + my $handle = HTTP::Tiny::Handle->new( + SSL_options => $self->{SSL_options}, + verify_SSL => $self->{verify_SSL}, + ); + unless ( eval { $handle->_find_CA_file; 1 } ) { + $ok = 0; + $reason .= "$@"; + } + } + + wantarray ? ($ok, $reason) : $ok; + } + + #--------------------------------------------------------------------------# + # private methods + #--------------------------------------------------------------------------# + + my %DefaultPort = ( + http => 80, + https => 443, + ); + + sub _agent { + my $class = ref($_[0]) || $_[0]; + (my $default_agent = $class) =~ s{::}{-}g; + return $default_agent . "/" . $class->VERSION; + } + + sub _request { + my ($self, $method, $url, $args) = @_; + + my ($scheme, $host, $port, $path_query, $auth) = $self->_split_url($url); + + my $request = { + method => $method, + scheme => $scheme, + host => $host, + port => $port, + host_port => ($port == $DefaultPort{$scheme} ? $host : "$host:$port"), + uri => $path_query, + headers => {}, + }; + + # We remove the cached handle so it is not reused in the case of redirect. + # If all is well, it will be recached at the end of _request. We only + # reuse for the same scheme, host and port + my $handle = delete $self->{handle}; + if ( $handle ) { + unless ( $handle->can_reuse( $scheme, $host, $port ) ) { + $handle->close; + undef $handle; + } + } + $handle ||= $self->_open_handle( $request, $scheme, $host, $port ); + + $self->_prepare_headers_and_cb($request, $args, $url, $auth); + $handle->write_request($request); + + my $response; + do { $response = $handle->read_response_header } + until (substr($response->{status},0,1) ne '1'); + + $self->_update_cookie_jar( $url, $response ) if $self->{cookie_jar}; + + if ( my @redir_args = $self->_maybe_redirect($request, $response, $args) ) { + $handle->close; + return $self->_request(@redir_args, $args); + } + + my $known_message_length; + if ($method eq 'HEAD' || $response->{status} =~ /^[23]04/) { + # response has no message body + $known_message_length = 1; + } + else { + my $data_cb = $self->_prepare_data_cb($response, $args); + $known_message_length = $handle->read_body($data_cb, $response); + } + + if ( $self->{keep_alive} + && $known_message_length + && $response->{protocol} eq 'HTTP/1.1' + && ($response->{headers}{connection} || '') ne 'close' + ) { + $self->{handle} = $handle; + } + else { + $handle->close; + } + + $response->{success} = substr( $response->{status}, 0, 1 ) eq '2'; + $response->{url} = $url; + return $response; + } + + sub _open_handle { + my ($self, $request, $scheme, $host, $port) = @_; + + my $handle = HTTP::Tiny::Handle->new( + timeout => $self->{timeout}, + SSL_options => $self->{SSL_options}, + verify_SSL => $self->{verify_SSL}, + local_address => $self->{local_address}, + keep_alive => $self->{keep_alive} + ); + + if ($self->{_has_proxy}{$scheme} && ! grep { $host =~ /\Q$_\E$/ } @{$self->{no_proxy}}) { + return $self->_proxy_connect( $request, $handle ); + } + else { + return $handle->connect($scheme, $host, $port); + } + } + + sub _proxy_connect { + my ($self, $request, $handle) = @_; + + my @proxy_vars; + if ( $request->{scheme} eq 'https' ) { + Carp::croak(qq{No https_proxy defined}) unless $self->{https_proxy}; + @proxy_vars = $self->_split_proxy( https_proxy => $self->{https_proxy} ); + if ( $proxy_vars[0] eq 'https' ) { + Carp::croak(qq{Can't proxy https over https: $request->{uri} via $self->{https_proxy}}); + } + } + else { + Carp::croak(qq{No http_proxy defined}) unless $self->{http_proxy}; + @proxy_vars = $self->_split_proxy( http_proxy => $self->{http_proxy} ); + } + + my ($p_scheme, $p_host, $p_port, $p_auth) = @proxy_vars; + + if ( length $p_auth && ! defined $request->{headers}{'proxy-authorization'} ) { + $self->_add_basic_auth_header( $request, 'proxy-authorization' => $p_auth ); + } + + $handle->connect($p_scheme, $p_host, $p_port); + + if ($request->{scheme} eq 'https') { + $self->_create_proxy_tunnel( $request, $handle ); + } + else { + # non-tunneled proxy requires absolute URI + $request->{uri} = "$request->{scheme}://$request->{host_port}$request->{uri}"; + } + + return $handle; + } + + sub _split_proxy { + my ($self, $type, $proxy) = @_; + + my ($scheme, $host, $port, $path_query, $auth) = eval { $self->_split_url($proxy) }; + + unless( + defined($scheme) && length($scheme) && length($host) && length($port) + && $path_query eq '/' + ) { + Carp::croak(qq{$type URL must be in format http[s]://[auth@]:/\n}); + } + + return ($scheme, $host, $port, $auth); + } + + sub _create_proxy_tunnel { + my ($self, $request, $handle) = @_; + + $handle->_assert_ssl; + + my $agent = exists($request->{headers}{'user-agent'}) + ? $request->{headers}{'user-agent'} : $self->{agent}; + + my $connect_request = { + method => 'CONNECT', + uri => "$request->{host}:$request->{port}", + headers => { + host => "$request->{host}:$request->{port}", + 'user-agent' => $agent, + } + }; + + if ( $request->{headers}{'proxy-authorization'} ) { + $connect_request->{headers}{'proxy-authorization'} = + delete $request->{headers}{'proxy-authorization'}; + } + + $handle->write_request($connect_request); + my $response; + do { $response = $handle->read_response_header } + until (substr($response->{status},0,1) ne '1'); + + # if CONNECT failed, throw the response so it will be + # returned from the original request() method; + unless (substr($response->{status},0,1) eq '2') { + die $response; + } + + # tunnel established, so start SSL handshake + $handle->start_ssl( $request->{host} ); + + return; + } + + sub _prepare_headers_and_cb { + my ($self, $request, $args, $url, $auth) = @_; + + for ($self->{default_headers}, $args->{headers}) { + next unless defined; + while (my ($k, $v) = each %$_) { + $request->{headers}{lc $k} = $v; + } + } + + if (exists $request->{headers}{'host'}) { + die(qq/The 'Host' header must not be provided as header option\n/); + } + + $request->{headers}{'host'} = $request->{host_port}; + $request->{headers}{'user-agent'} ||= $self->{agent}; + $request->{headers}{'connection'} = "close" + unless $self->{keep_alive}; + + if ( defined $args->{content} ) { + if (ref $args->{content} eq 'CODE') { + $request->{headers}{'content-type'} ||= "application/octet-stream"; + $request->{headers}{'transfer-encoding'} = 'chunked' + unless $request->{headers}{'content-length'} + || $request->{headers}{'transfer-encoding'}; + $request->{cb} = $args->{content}; + } + elsif ( length $args->{content} ) { + my $content = $args->{content}; + if ( $] ge '5.008' ) { + utf8::downgrade($content, 1) + or die(qq/Wide character in request message body\n/); + } + $request->{headers}{'content-type'} ||= "application/octet-stream"; + $request->{headers}{'content-length'} = length $content + unless $request->{headers}{'content-length'} + || $request->{headers}{'transfer-encoding'}; + $request->{cb} = sub { substr $content, 0, length $content, '' }; + } + $request->{trailer_cb} = $args->{trailer_callback} + if ref $args->{trailer_callback} eq 'CODE'; + } + + ### If we have a cookie jar, then maybe add relevant cookies + if ( $self->{cookie_jar} ) { + my $cookies = $self->cookie_jar->cookie_header( $url ); + $request->{headers}{cookie} = $cookies if length $cookies; + } + + # if we have Basic auth parameters, add them + if ( length $auth && ! defined $request->{headers}{authorization} ) { + $self->_add_basic_auth_header( $request, 'authorization' => $auth ); + } + + return; + } + + sub _add_basic_auth_header { + my ($self, $request, $header, $auth) = @_; + require MIME::Base64; + $request->{headers}{$header} = + "Basic " . MIME::Base64::encode_base64($auth, ""); + return; + } + + sub _prepare_data_cb { + my ($self, $response, $args) = @_; + my $data_cb = $args->{data_callback}; + $response->{content} = ''; + + if (!$data_cb || $response->{status} !~ /^2/) { + if (defined $self->{max_size}) { + $data_cb = sub { + $_[1]->{content} .= $_[0]; + die(qq/Size of response body exceeds the maximum allowed of $self->{max_size}\n/) + if length $_[1]->{content} > $self->{max_size}; + }; + } + else { + $data_cb = sub { $_[1]->{content} .= $_[0] }; + } + } + return $data_cb; + } + + sub _update_cookie_jar { + my ($self, $url, $response) = @_; + + my $cookies = $response->{headers}->{'set-cookie'}; + return unless defined $cookies; + + my @cookies = ref $cookies ? @$cookies : $cookies; + + $self->cookie_jar->add( $url, $_ ) for @cookies; + + return; + } + + sub _validate_cookie_jar { + my ($class, $jar) = @_; + + # duck typing + for my $method ( qw/add cookie_header/ ) { + Carp::croak(qq/Cookie jar must provide the '$method' method\n/) + unless ref($jar) && ref($jar)->can($method); + } + + return; + } + + sub _maybe_redirect { + my ($self, $request, $response, $args) = @_; + my $headers = $response->{headers}; + my ($status, $method) = ($response->{status}, $request->{method}); + if (($status eq '303' or ($status =~ /^30[1278]/ && $method =~ /^GET|HEAD$/)) + and $headers->{location} + and ++$args->{redirects} <= $self->{max_redirect} + ) { + my $location = ($headers->{location} =~ /^\//) + ? "$request->{scheme}://$request->{host_port}$headers->{location}" + : $headers->{location} ; + return (($status eq '303' ? 'GET' : $method), $location); + } + return; + } + + sub _split_url { + my $url = pop; + + # URI regex adapted from the URI module + my ($scheme, $host, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)> + or die(qq/Cannot parse URL: '$url'\n/); + + $scheme = lc $scheme; + $path_query = "/$path_query" unless $path_query =~ m<\A/>; + + my $auth = ''; + if ( (my $i = index $host, '@') != -1 ) { + # user:pass@host + $auth = substr $host, 0, $i, ''; # take up to the @ for auth + substr $host, 0, 1, ''; # knock the @ off the host + + # userinfo might be percent escaped, so recover real auth info + $auth =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; + } + my $port = $host =~ s/:(\d*)\z// && length $1 ? $1 + : $scheme eq 'http' ? 80 + : $scheme eq 'https' ? 443 + : undef; + + return ($scheme, (length $host ? lc $host : "localhost") , $port, $path_query, $auth); + } + + # Date conversions adapted from HTTP::Date + my $DoW = "Sun|Mon|Tue|Wed|Thu|Fri|Sat"; + my $MoY = "Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec"; + sub _http_date { + my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($_[1]); + return sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT", + substr($DoW,$wday*4,3), + $mday, substr($MoY,$mon*4,3), $year+1900, + $hour, $min, $sec + ); + } + + sub _parse_http_date { + my ($self, $str) = @_; + require Time::Local; + my @tl_parts; + if ($str =~ /^[SMTWF][a-z]+, +(\d{1,2}) ($MoY) +(\d\d\d\d) +(\d\d):(\d\d):(\d\d) +GMT$/) { + @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3); + } + elsif ($str =~ /^[SMTWF][a-z]+, +(\d\d)-($MoY)-(\d{2,4}) +(\d\d):(\d\d):(\d\d) +GMT$/ ) { + @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3); + } + elsif ($str =~ /^[SMTWF][a-z]+ +($MoY) +(\d{1,2}) +(\d\d):(\d\d):(\d\d) +(?:[^0-9]+ +)?(\d\d\d\d)$/ ) { + @tl_parts = ($5, $4, $3, $2, (index($MoY,$1)/4), $6); + } + return eval { + my $t = @tl_parts ? Time::Local::timegm(@tl_parts) : -1; + $t < 0 ? undef : $t; + }; + } + + # URI escaping adapted from URI::Escape + # c.f. http://www.w3.org/TR/html4/interact/forms.html#h-17.13.4.1 + # perl 5.6 ready UTF-8 encoding adapted from JSON::PP + my %escapes = map { chr($_) => sprintf("%%%02X", $_) } 0..255; + $escapes{' '}="+"; + my $unsafe_char = qr/[^A-Za-z0-9\-\._~]/; + + sub _uri_escape { + my ($self, $str) = @_; + if ( $] ge '5.008' ) { + utf8::encode($str); + } + else { + $str = pack("U*", unpack("C*", $str)) # UTF-8 encode a byte string + if ( length $str == do { use bytes; length $str } ); + $str = pack("C*", unpack("C*", $str)); # clear UTF-8 flag + } + $str =~ s/($unsafe_char)/$escapes{$1}/ge; + return $str; + } + + package + HTTP::Tiny::Handle; # hide from PAUSE/indexers + use strict; + use warnings; + + use Errno qw[EINTR EPIPE]; + use IO::Socket qw[SOCK_STREAM]; + + # PERL_HTTP_TINY_IPV4_ONLY is a private environment variable to force old + # behavior if someone is unable to boostrap CPAN from a new perl install; it is + # not intended for general, per-client use and may be removed in the future + my $SOCKET_CLASS = + $ENV{PERL_HTTP_TINY_IPV4_ONLY} ? 'IO::Socket::INET' : + eval { require IO::Socket::IP; IO::Socket::IP->VERSION(0.25) } ? 'IO::Socket::IP' : + 'IO::Socket::INET'; + + sub BUFSIZE () { 32768 } ## no critic + + my $Printable = sub { + local $_ = shift; + s/\r/\\r/g; + s/\n/\\n/g; + s/\t/\\t/g; + s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge; + $_; + }; + + my $Token = qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/; + + sub new { + my ($class, %args) = @_; + return bless { + rbuf => '', + timeout => 60, + max_line_size => 16384, + max_header_lines => 64, + verify_SSL => 0, + SSL_options => {}, + %args + }, $class; + } + + sub connect { + @_ == 4 || die(q/Usage: $handle->connect(scheme, host, port)/ . "\n"); + my ($self, $scheme, $host, $port) = @_; + + if ( $scheme eq 'https' ) { + $self->_assert_ssl; + } + elsif ( $scheme ne 'http' ) { + die(qq/Unsupported URL scheme '$scheme'\n/); + } + $self->{fh} = $SOCKET_CLASS->new( + PeerHost => $host, + PeerPort => $port, + $self->{local_address} ? + ( LocalAddr => $self->{local_address} ) : (), + Proto => 'tcp', + Type => SOCK_STREAM, + Timeout => $self->{timeout}, + KeepAlive => !!$self->{keep_alive} + ) or die(qq/Could not connect to '$host:$port': $@\n/); + + binmode($self->{fh}) + or die(qq/Could not binmode() socket: '$!'\n/); + + $self->start_ssl($host) if $scheme eq 'https'; + + $self->{scheme} = $scheme; + $self->{host} = $host; + $self->{port} = $port; + $self->{pid} = $$; + $self->{tid} = _get_tid(); + + return $self; + } + + sub start_ssl { + my ($self, $host) = @_; + + # As this might be used via CONNECT after an SSL session + # to a proxy, we shut down any existing SSL before attempting + # the handshake + if ( ref($self->{fh}) eq 'IO::Socket::SSL' ) { + unless ( $self->{fh}->stop_SSL ) { + my $ssl_err = IO::Socket::SSL->errstr; + die(qq/Error halting prior SSL connection: $ssl_err/); + } + } + + my $ssl_args = $self->_ssl_args($host); + IO::Socket::SSL->start_SSL( + $self->{fh}, + %$ssl_args, + SSL_create_ctx_callback => sub { + my $ctx = shift; + Net::SSLeay::CTX_set_mode($ctx, Net::SSLeay::MODE_AUTO_RETRY()); + }, + ); + + unless ( ref($self->{fh}) eq 'IO::Socket::SSL' ) { + my $ssl_err = IO::Socket::SSL->errstr; + die(qq/SSL connection failed for $host: $ssl_err\n/); + } + } + + sub close { + @_ == 1 || die(q/Usage: $handle->close()/ . "\n"); + my ($self) = @_; + CORE::close($self->{fh}) + or die(qq/Could not close socket: '$!'\n/); + } + + sub write { + @_ == 2 || die(q/Usage: $handle->write(buf)/ . "\n"); + my ($self, $buf) = @_; + + if ( $] ge '5.008' ) { + utf8::downgrade($buf, 1) + or die(qq/Wide character in write()\n/); + } + + my $len = length $buf; + my $off = 0; + + local $SIG{PIPE} = 'IGNORE'; + + while () { + $self->can_write + or die(qq/Timed out while waiting for socket to become ready for writing\n/); + my $r = syswrite($self->{fh}, $buf, $len, $off); + if (defined $r) { + $len -= $r; + $off += $r; + last unless $len > 0; + } + elsif ($! == EPIPE) { + die(qq/Socket closed by remote server: $!\n/); + } + elsif ($! != EINTR) { + if ($self->{fh}->can('errstr')){ + my $err = $self->{fh}->errstr(); + die (qq/Could not write to SSL socket: '$err'\n /); + } + else { + die(qq/Could not write to socket: '$!'\n/); + } + + } + } + return $off; + } + + sub read { + @_ == 2 || @_ == 3 || die(q/Usage: $handle->read(len [, allow_partial])/ . "\n"); + my ($self, $len, $allow_partial) = @_; + + my $buf = ''; + my $got = length $self->{rbuf}; + + if ($got) { + my $take = ($got < $len) ? $got : $len; + $buf = substr($self->{rbuf}, 0, $take, ''); + $len -= $take; + } + + while ($len > 0) { + $self->can_read + or die(q/Timed out while waiting for socket to become ready for reading/ . "\n"); + my $r = sysread($self->{fh}, $buf, $len, length $buf); + if (defined $r) { + last unless $r; + $len -= $r; + } + elsif ($! != EINTR) { + if ($self->{fh}->can('errstr')){ + my $err = $self->{fh}->errstr(); + die (qq/Could not read from SSL socket: '$err'\n /); + } + else { + die(qq/Could not read from socket: '$!'\n/); + } + } + } + if ($len && !$allow_partial) { + die(qq/Unexpected end of stream\n/); + } + return $buf; + } + + sub readline { + @_ == 1 || die(q/Usage: $handle->readline()/ . "\n"); + my ($self) = @_; + + while () { + if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) { + return $1; + } + if (length $self->{rbuf} >= $self->{max_line_size}) { + die(qq/Line size exceeds the maximum allowed size of $self->{max_line_size}\n/); + } + $self->can_read + or die(qq/Timed out while waiting for socket to become ready for reading\n/); + my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf}); + if (defined $r) { + last unless $r; + } + elsif ($! != EINTR) { + if ($self->{fh}->can('errstr')){ + my $err = $self->{fh}->errstr(); + die (qq/Could not read from SSL socket: '$err'\n /); + } + else { + die(qq/Could not read from socket: '$!'\n/); + } + } + } + die(qq/Unexpected end of stream while looking for line\n/); + } + + sub read_header_lines { + @_ == 1 || @_ == 2 || die(q/Usage: $handle->read_header_lines([headers])/ . "\n"); + my ($self, $headers) = @_; + $headers ||= {}; + my $lines = 0; + my $val; + + while () { + my $line = $self->readline; + + if (++$lines >= $self->{max_header_lines}) { + die(qq/Header lines exceeds maximum number allowed of $self->{max_header_lines}\n/); + } + elsif ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) { + my ($field_name) = lc $1; + if (exists $headers->{$field_name}) { + for ($headers->{$field_name}) { + $_ = [$_] unless ref $_ eq "ARRAY"; + push @$_, $2; + $val = \$_->[-1]; + } + } + else { + $val = \($headers->{$field_name} = $2); + } + } + elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) { + $val + or die(qq/Unexpected header continuation line\n/); + next unless length $1; + $$val .= ' ' if length $$val; + $$val .= $1; + } + elsif ($line =~ /\A \x0D?\x0A \z/x) { + last; + } + else { + die(q/Malformed header line: / . $Printable->($line) . "\n"); + } + } + return $headers; + } + + sub write_request { + @_ == 2 || die(q/Usage: $handle->write_request(request)/ . "\n"); + my($self, $request) = @_; + $self->write_request_header(@{$request}{qw/method uri headers/}); + $self->write_body($request) if $request->{cb}; + return; + } + + my %HeaderCase = ( + 'content-md5' => 'Content-MD5', + 'etag' => 'ETag', + 'te' => 'TE', + 'www-authenticate' => 'WWW-Authenticate', + 'x-xss-protection' => 'X-XSS-Protection', + ); + + # to avoid multiple small writes and hence nagle, you can pass the method line or anything else to + # combine writes. + sub write_header_lines { + (@_ == 2 || @_ == 3 && ref $_[1] eq 'HASH') || die(q/Usage: $handle->write_header_lines(headers[,prefix])/ . "\n"); + my($self, $headers, $prefix_data) = @_; + + my $buf = (defined $prefix_data ? $prefix_data : ''); + while (my ($k, $v) = each %$headers) { + my $field_name = lc $k; + if (exists $HeaderCase{$field_name}) { + $field_name = $HeaderCase{$field_name}; + } + else { + $field_name =~ /\A $Token+ \z/xo + or die(q/Invalid HTTP header field name: / . $Printable->($field_name) . "\n"); + $field_name =~ s/\b(\w)/\u$1/g; + $HeaderCase{lc $field_name} = $field_name; + } + for (ref $v eq 'ARRAY' ? @$v : $v) { + $_ = '' unless defined $_; + $buf .= "$field_name: $_\x0D\x0A"; + } + } + $buf .= "\x0D\x0A"; + return $self->write($buf); + } + + # return value indicates whether message length was defined; this is generally + # true unless there was no content-length header and we just read until EOF. + # Other message length errors are thrown as exceptions + sub read_body { + @_ == 3 || die(q/Usage: $handle->read_body(callback, response)/ . "\n"); + my ($self, $cb, $response) = @_; + my $te = $response->{headers}{'transfer-encoding'} || ''; + my $chunked = grep { /chunked/i } ( ref $te eq 'ARRAY' ? @$te : $te ) ; + return $chunked + ? $self->read_chunked_body($cb, $response) + : $self->read_content_body($cb, $response); + } + + sub write_body { + @_ == 2 || die(q/Usage: $handle->write_body(request)/ . "\n"); + my ($self, $request) = @_; + if ($request->{headers}{'content-length'}) { + return $self->write_content_body($request); + } + else { + return $self->write_chunked_body($request); + } + } + + sub read_content_body { + @_ == 3 || @_ == 4 || die(q/Usage: $handle->read_content_body(callback, response, [read_length])/ . "\n"); + my ($self, $cb, $response, $content_length) = @_; + $content_length ||= $response->{headers}{'content-length'}; + + if ( defined $content_length ) { + my $len = $content_length; + while ($len > 0) { + my $read = ($len > BUFSIZE) ? BUFSIZE : $len; + $cb->($self->read($read, 0), $response); + $len -= $read; + } + return length($self->{rbuf}) == 0; + } + + my $chunk; + $cb->($chunk, $response) while length( $chunk = $self->read(BUFSIZE, 1) ); + + return; + } + + sub write_content_body { + @_ == 2 || die(q/Usage: $handle->write_content_body(request)/ . "\n"); + my ($self, $request) = @_; + + my ($len, $content_length) = (0, $request->{headers}{'content-length'}); + while () { + my $data = $request->{cb}->(); + + defined $data && length $data + or last; + + if ( $] ge '5.008' ) { + utf8::downgrade($data, 1) + or die(qq/Wide character in write_content()\n/); + } + + $len += $self->write($data); + } + + $len == $content_length + or die(qq/Content-Length mismatch (got: $len expected: $content_length)\n/); + + return $len; + } + + sub read_chunked_body { + @_ == 3 || die(q/Usage: $handle->read_chunked_body(callback, $response)/ . "\n"); + my ($self, $cb, $response) = @_; + + while () { + my $head = $self->readline; + + $head =~ /\A ([A-Fa-f0-9]+)/x + or die(q/Malformed chunk head: / . $Printable->($head) . "\n"); + + my $len = hex($1) + or last; + + $self->read_content_body($cb, $response, $len); + + $self->read(2) eq "\x0D\x0A" + or die(qq/Malformed chunk: missing CRLF after chunk data\n/); + } + $self->read_header_lines($response->{headers}); + return 1; + } + + sub write_chunked_body { + @_ == 2 || die(q/Usage: $handle->write_chunked_body(request)/ . "\n"); + my ($self, $request) = @_; + + my $len = 0; + while () { + my $data = $request->{cb}->(); + + defined $data && length $data + or last; + + if ( $] ge '5.008' ) { + utf8::downgrade($data, 1) + or die(qq/Wide character in write_chunked_body()\n/); + } + + $len += length $data; + + my $chunk = sprintf '%X', length $data; + $chunk .= "\x0D\x0A"; + $chunk .= $data; + $chunk .= "\x0D\x0A"; + + $self->write($chunk); + } + $self->write("0\x0D\x0A"); + $self->write_header_lines($request->{trailer_cb}->()) + if ref $request->{trailer_cb} eq 'CODE'; + return $len; + } + + sub read_response_header { + @_ == 1 || die(q/Usage: $handle->read_response_header()/ . "\n"); + my ($self) = @_; + + my $line = $self->readline; + + $line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x + or die(q/Malformed Status-Line: / . $Printable->($line). "\n"); + + my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4); + + die (qq/Unsupported HTTP protocol: $protocol\n/) + unless $version =~ /0*1\.0*[01]/; + + return { + status => $status, + reason => $reason, + headers => $self->read_header_lines, + protocol => $protocol, + }; + } + + sub write_request_header { + @_ == 4 || die(q/Usage: $handle->write_request_header(method, request_uri, headers)/ . "\n"); + my ($self, $method, $request_uri, $headers) = @_; + + return $self->write_header_lines($headers, "$method $request_uri HTTP/1.1\x0D\x0A"); + } + + sub _do_timeout { + my ($self, $type, $timeout) = @_; + $timeout = $self->{timeout} + unless defined $timeout && $timeout >= 0; + + my $fd = fileno $self->{fh}; + defined $fd && $fd >= 0 + or die(qq/select(2): 'Bad file descriptor'\n/); + + my $initial = time; + my $pending = $timeout; + my $nfound; + + vec(my $fdset = '', $fd, 1) = 1; + + while () { + $nfound = ($type eq 'read') + ? select($fdset, undef, undef, $pending) + : select(undef, $fdset, undef, $pending) ; + if ($nfound == -1) { + $! == EINTR + or die(qq/select(2): '$!'\n/); + redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0; + $nfound = 0; + } + last; + } + $! = 0; + return $nfound; + } + + sub can_read { + @_ == 1 || @_ == 2 || die(q/Usage: $handle->can_read([timeout])/ . "\n"); + my $self = shift; + if ( ref($self->{fh}) eq 'IO::Socket::SSL' ) { + return 1 if $self->{fh}->pending; + } + return $self->_do_timeout('read', @_) + } + + sub can_write { + @_ == 1 || @_ == 2 || die(q/Usage: $handle->can_write([timeout])/ . "\n"); + my $self = shift; + return $self->_do_timeout('write', @_) + } + + sub _assert_ssl { + my($ok, $reason) = HTTP::Tiny->can_ssl(); + die $reason unless $ok; + } + + sub can_reuse { + my ($self,$scheme,$host,$port) = @_; + return 0 if + $self->{pid} != $$ + || $self->{tid} != _get_tid() + || length($self->{rbuf}) + || $scheme ne $self->{scheme} + || $host ne $self->{host} + || $port ne $self->{port} + || eval { $self->can_read(0) } + || $@ ; + return 1; + } + + # Try to find a CA bundle to validate the SSL cert, + # prefer Mozilla::CA or fallback to a system file + sub _find_CA_file { + my $self = shift(); + + if ( $self->{SSL_options}->{SSL_ca_file} ) { + unless ( -r $self->{SSL_options}->{SSL_ca_file} ) { + die qq/SSL_ca_file '$self->{SSL_options}->{SSL_ca_file}' not found or not readable\n/; + } + return $self->{SSL_options}->{SSL_ca_file}; + } + + return Mozilla::CA::SSL_ca_file() + if eval { require Mozilla::CA; 1 }; + + # cert list copied from golang src/crypto/x509/root_unix.go + foreach my $ca_bundle ( + "/etc/ssl/certs/ca-certificates.crt", # Debian/Ubuntu/Gentoo etc. + "/etc/pki/tls/certs/ca-bundle.crt", # Fedora/RHEL + "/etc/ssl/ca-bundle.pem", # OpenSUSE + "/etc/openssl/certs/ca-certificates.crt", # NetBSD + "/etc/ssl/cert.pem", # OpenBSD + "/usr/local/share/certs/ca-root-nss.crt", # FreeBSD/DragonFly + "/etc/pki/tls/cacert.pem", # OpenELEC + "/etc/certs/ca-certificates.crt", # Solaris 11.2+ + ) { + return $ca_bundle if -e $ca_bundle; + } + + die qq/Couldn't find a CA bundle with which to verify the SSL certificate.\n/ + . qq/Try installing Mozilla::CA from CPAN\n/; + } + + # for thread safety, we need to know thread id if threads are loaded + sub _get_tid { + no warnings 'reserved'; # for 'threads' + return threads->can("tid") ? threads->tid : 0; + } + + sub _ssl_args { + my ($self, $host) = @_; + + my %ssl_args; + + # This test reimplements IO::Socket::SSL::can_client_sni(), which wasn't + # added until IO::Socket::SSL 1.84 + if ( Net::SSLeay::OPENSSL_VERSION_NUMBER() >= 0x01000000 ) { + $ssl_args{SSL_hostname} = $host, # Sane SNI support + } + + if ($self->{verify_SSL}) { + $ssl_args{SSL_verifycn_scheme} = 'http'; # enable CN validation + $ssl_args{SSL_verifycn_name} = $host; # set validation hostname + $ssl_args{SSL_verify_mode} = 0x01; # enable cert validation + $ssl_args{SSL_ca_file} = $self->_find_CA_file; + } + else { + $ssl_args{SSL_verifycn_scheme} = 'none'; # disable CN validation + $ssl_args{SSL_verify_mode} = 0x00; # disable cert validation + } + + # user options override settings from verify_SSL + for my $k ( keys %{$self->{SSL_options}} ) { + $ssl_args{$k} = $self->{SSL_options}{$k} if $k =~ m/^SSL_/; + } + + return \%ssl_args; + } + + 1; + + __END__ + + =pod + + =encoding UTF-8 + + =head1 NAME + + HTTP::Tiny - A small, simple, correct HTTP/1.1 client + + =head1 VERSION + + version 0.056 + + =head1 SYNOPSIS + + use HTTP::Tiny; + + my $response = HTTP::Tiny->new->get('http://example.com/'); + + die "Failed!\n" unless $response->{success}; + + print "$response->{status} $response->{reason}\n"; + + while (my ($k, $v) = each %{$response->{headers}}) { + for (ref $v eq 'ARRAY' ? @$v : $v) { + print "$k: $_\n"; + } + } + + print $response->{content} if length $response->{content}; + + =head1 DESCRIPTION + + This is a very simple HTTP/1.1 client, designed for doing simple + requests without the overhead of a large framework like L. + + It is more correct and more complete than L. It supports + proxies and redirection. It also correctly resumes after EINTR. + + If L 0.25 or later is installed, HTTP::Tiny will use it instead + of L for transparent support for both IPv4 and IPv6. + + Cookie support requires L or an equivalent class. + + =head1 METHODS + + =head2 new + + $http = HTTP::Tiny->new( %attributes ); + + This constructor returns a new HTTP::Tiny object. Valid attributes include: + + =over 4 + + =item * + + C — A user-agent string (defaults to 'HTTP-Tiny/$VERSION'). If C — ends in a space character, the default user-agent string is appended. + + =item * + + C — An instance of L — or equivalent class that supports the C and C methods + + =item * + + C — A hashref of default headers to apply to requests + + =item * + + C — The local IP address to bind to + + =item * + + C — Whether to reuse the last connection (if for the same scheme, host and port) (defaults to 1) + + =item * + + C — Maximum number of redirects allowed (defaults to 5) + + =item * + + C — Maximum response size in bytes (only when not using a data callback). If defined, responses larger than this will return an exception. + + =item * + + C — URL of a proxy server to use for HTTP connections (default is C<$ENV{http_proxy}> — if set) + + =item * + + C — URL of a proxy server to use for HTTPS connections (default is C<$ENV{https_proxy}> — if set) + + =item * + + C — URL of a generic proxy server for both HTTP and HTTPS connections (default is C<$ENV{all_proxy}> — if set) + + =item * + + C — List of domain suffixes that should not be proxied. Must be a comma-separated string or an array reference. (default is C<$ENV{no_proxy}> —) + + =item * + + C — Request timeout in seconds (default is 60) + + =item * + + C — A boolean that indicates whether to validate the SSL certificate of an C — connection (default is false) + + =item * + + C — A hashref of C — options to pass through to L + + =back + + Passing an explicit C for C, C or C will + prevent getting the corresponding proxies from the environment. + + Exceptions from C, C or other errors will result in a + pseudo-HTTP status code of 599 and a reason of "Internal Exception". The + content field in the response will contain the text of the exception. + + The C parameter enables a persistent connection, but only to a + single destination scheme, host and port. Also, if any connection-relevant + attributes are modified, or if the process ID or thread ID change, the + persistent connection will be dropped. If you want persistent connections + across multiple destinations, use multiple HTTP::Tiny objects. + + See L for more on the C and C attributes. + + =head2 get|head|put|post|delete + + $response = $http->get($url); + $response = $http->get($url, \%options); + $response = $http->head($url); + + These methods are shorthand for calling C for the given method. The + URL must have unsafe characters escaped and international domain names encoded. + See C for valid options and a description of the response. + + The C field of the response will be true if the status code is 2XX. + + =head2 post_form + + $response = $http->post_form($url, $form_data); + $response = $http->post_form($url, $form_data, \%options); + + This method executes a C request and sends the key/value pairs from a + form data hash or array reference to the given URL with a C of + C. If data is provided as an array + reference, the order is preserved; if provided as a hash reference, the terms + are sorted on key and value for consistency. See documentation for the + C method for details on the encoding. + + The URL must have unsafe characters escaped and international domain names + encoded. See C for valid options and a description of the response. + Any C header or content in the options hashref will be ignored. + + The C field of the response will be true if the status code is 2XX. + + =head2 mirror + + $response = $http->mirror($url, $file, \%options) + if ( $response->{success} ) { + print "$file is up to date\n"; + } + + Executes a C request for the URL and saves the response body to the file + name provided. The URL must have unsafe characters escaped and international + domain names encoded. If the file already exists, the request will include an + C header with the modification timestamp of the file. You + may specify a different C header yourself in the C<< + $options->{headers} >> hash. + + The C field of the response will be true if the status code is 2XX + or if the status code is 304 (unmodified). + + If the file was modified and the server response includes a properly + formatted C header, the file modification time will + be updated accordingly. + + =head2 request + + $response = $http->request($method, $url); + $response = $http->request($method, $url, \%options); + + Executes an HTTP request of the given method type ('GET', 'HEAD', 'POST', + 'PUT', etc.) on the given URL. The URL must have unsafe characters escaped and + international domain names encoded. + + If the URL includes a "user:password" stanza, they will be used for Basic-style + authorization headers. (Authorization headers will not be included in a + redirected request.) For example: + + $http->request('GET', 'http://Aladdin:open sesame@example.com/'); + + If the "user:password" stanza contains reserved characters, they must + be percent-escaped: + + $http->request('GET', 'http://john%40example.com:password@example.com/'); + + A hashref of options may be appended to modify the request. + + Valid options are: + + =over 4 + + =item * + + C — A hashref containing headers to include with the request. If the value for a header is an array reference, the header will be output multiple times with each value in the array. These headers over-write any default headers. + + =item * + + C — A scalar to include as the body of the request OR a code reference that will be called iteratively to produce the body of the request + + =item * + + C — A code reference that will be called if it exists to provide a hashref of trailing headers (only used with chunked transfer-encoding) + + =item * + + C — A code reference that will be called for each chunks of the response body received. + + =back + + The C header is generated from the URL in accordance with RFC 2616. It + is a fatal error to specify C in the C option. Other headers + may be ignored or overwritten if necessary for transport compliance. + + If the C option is a code reference, it will be called iteratively + to provide the content body of the request. It should return the empty + string or undef when the iterator is exhausted. + + If the C option is the empty string, no C or + C headers will be generated. + + If the C option is provided, it will be called iteratively until + the entire response body is received. The first argument will be a string + containing a chunk of the response body, the second argument will be the + in-progress response hash reference, as described below. (This allows + customizing the action of the callback based on the C or C + received prior to the content body.) + + The C method returns a hashref containing the response. The hashref + will have the following keys: + + =over 4 + + =item * + + C — Boolean indicating whether the operation returned a 2XX status code + + =item * + + C — URL that provided the response. This is the URL of the request unless there were redirections, in which case it is the last URL queried in a redirection chain + + =item * + + C — The HTTP status code of the response + + =item * + + C — The response phrase returned by the server + + =item * + + C — The body of the response. If the response does not have any content or if a data callback is provided to consume the response body, this will be the empty string + + =item * + + C — A hashref of header fields. All header field names will be normalized to be lower case. If a header is repeated, the value will be an arrayref; it will otherwise be a scalar string containing the value + + =back + + On an exception during the execution of the request, the C field will + contain 599, and the C field will contain the text of the exception. + + =head2 www_form_urlencode + + $params = $http->www_form_urlencode( $data ); + $response = $http->get("http://example.com/query?$params"); + + This method converts the key/value pairs from a data hash or array reference + into a C string. The keys and values from the data + reference will be UTF-8 encoded and escaped per RFC 3986. If a value is an + array reference, the key will be repeated with each of the values of the array + reference. If data is provided as a hash reference, the key/value pairs in the + resulting string will be sorted by key and value for consistent ordering. + + =head2 can_ssl + + $ok = HTTP::Tiny->can_ssl; + ($ok, $why) = HTTP::Tiny->can_ssl; + ($ok, $why) = $http->can_ssl; + + Indicates if SSL support is available. When called as a class object, it + checks for the correct version of L and L. + When called as an object methods, if C is true or if C + is set in C, it checks that a CA file is available. + + In scalar context, returns a boolean indicating if SSL is available. + In list context, returns the boolean and a (possibly multi-line) string of + errors indicating why SSL isn't available. + + =for Pod::Coverage SSL_options + agent + cookie_jar + default_headers + http_proxy + https_proxy + keep_alive + local_address + max_redirect + max_size + no_proxy + proxy + timeout + verify_SSL + + =head1 SSL SUPPORT + + Direct C connections are supported only if L 1.56 or + greater and L 1.49 or greater are installed. An exception will be + thrown if new enough versions of these modules are not installed or if the SSL + encryption fails. You can also use C utility function + that returns boolean to see if the required modules are installed. + + An C connection may be made via an C proxy that supports the CONNECT + command (i.e. RFC 2817). You may not proxy C via a proxy that itself + requires C to communicate. + + SSL provides two distinct capabilities: + + =over 4 + + =item * + + Encrypted communication channel + + =item * + + Verification of server identity + + =back + + B. + + Server identity verification is controversial and potentially tricky because it + depends on a (usually paid) third-party Certificate Authority (CA) trust model + to validate a certificate as legitimate. This discriminates against servers + with self-signed certificates or certificates signed by free, community-driven + CA's such as L. + + By default, HTTP::Tiny does not make any assumptions about your trust model, + threat level or risk tolerance. It just aims to give you an encrypted channel + when you need one. + + Setting the C attribute to a true value will make HTTP::Tiny verify + that an SSL connection has a valid SSL certificate corresponding to the host + name of the connection and that the SSL certificate has been verified by a CA. + Assuming you trust the CA, this will protect against a L. If you are + concerned about security, you should enable this option. + + Certificate verification requires a file containing trusted CA certificates. + If the L module is installed, HTTP::Tiny will use the CA file + included with it as a source of trusted CA's. (This means you trust Mozilla, + the author of Mozilla::CA, the CPAN mirror where you got Mozilla::CA, the + toolchain used to install it, and your operating system security, right?) + + If that module is not available, then HTTP::Tiny will search several + system-specific default locations for a CA certificate file: + + =over 4 + + =item * + + /etc/ssl/certs/ca-certificates.crt + + =item * + + /etc/pki/tls/certs/ca-bundle.crt + + =item * + + /etc/ssl/ca-bundle.pem + + =back + + An exception will be raised if C is true and no CA certificate file + is available. + + If you desire complete control over SSL connections, the C attribute + lets you provide a hash reference that will be passed through to + C, overriding any options set by HTTP::Tiny. For + example, to provide your own trusted CA file: + + SSL_options => { + SSL_ca_file => $file_path, + } + + The C attribute could also be used for such things as providing a + client certificate for authentication to a server or controlling the choice of + cipher used for the SSL connection. See L documentation for + details. + + =head1 PROXY SUPPORT + + HTTP::Tiny can proxy both C and C requests. Only Basic proxy + authorization is supported and it must be provided as part of the proxy URL: + C. + + HTTP::Tiny supports the following proxy environment variables: + + =over 4 + + =item * + + http_proxy or HTTP_PROXY + + =item * + + https_proxy or HTTPS_PROXY + + =item * + + all_proxy or ALL_PROXY + + =back + + If the C environment variable is set, then this might be a CGI + process and C would be set from the C header, which is a + security risk. If C is set, C (the upper case + variant only) is ignored. + + Tunnelling C over an C proxy using the CONNECT method is + supported. If your proxy uses C itself, you can not tunnel C + over it. + + Be warned that proxying an C connection opens you to the risk of a + man-in-the-middle attack by the proxy server. + + The C environment variable is supported in the format of a + comma-separated list of domain extensions proxy should not be used for. + + Proxy arguments passed to C will override their corresponding + environment variables. + + =head1 LIMITATIONS + + HTTP::Tiny is I with the + L: + + =over 4 + + =item * + + "Message Syntax and Routing" [RFC7230] + + =item * + + "Semantics and Content" [RFC7231] + + =item * + + "Conditional Requests" [RFC7232] + + =item * + + "Range Requests" [RFC7233] + + =item * + + "Caching" [RFC7234] + + =item * + + "Authentication" [RFC7235] + + =back + + It attempts to meet all "MUST" requirements of the specification, but does not + implement all "SHOULD" requirements. (Note: it was developed against the + earlier RFC 2616 specification and may not yet meet the revised RFC 7230-7235 + spec.) + + Some particular limitations of note include: + + =over + + =item * + + HTTP::Tiny focuses on correct transport. Users are responsible for ensuring + that user-defined headers and content are compliant with the HTTP/1.1 + specification. + + =item * + + Users must ensure that URLs are properly escaped for unsafe characters and that + international domain names are properly encoded to ASCII. See L, + L and L. + + =item * + + Redirection is very strict against the specification. Redirection is only + automatic for response codes 301, 302, 307 and 308 if the request method is + 'GET' or 'HEAD'. Response code 303 is always converted into a 'GET' + redirection, as mandated by the specification. There is no automatic support + for status 305 ("Use proxy") redirections. + + =item * + + There is no provision for delaying a request body using an C header. + Unexpected C<1XX> responses are silently ignored as per the specification. + + =item * + + Only 'chunked' C is supported. + + =item * + + There is no support for a Request-URI of '*' for the 'OPTIONS' request. + + =back + + Despite the limitations listed above, HTTP::Tiny is considered + feature-complete. New feature requests should be directed to + L. + + =head1 SEE ALSO + + =over 4 + + =item * + + L - Higher level UA features for HTTP::Tiny + + =item * + + L - HTTP::Tiny wrapper with L/L compatibility + + =item * + + L - Wrap L instance in HTTP::Tiny compatible interface + + =item * + + L - Required for IPv6 support + + =item * + + L - Required for SSL support + + =item * + + L - If HTTP::Tiny isn't enough for you, this is the "standard" way to do things + + =item * + + L - Required if you want to validate SSL certificates + + =item * + + L - Required for SSL support + + =back + + =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan + + =head1 SUPPORT + + =head2 Bugs / Feature Requests + + Please report any bugs or feature requests through the issue tracker + at L. + You will be notified automatically of any progress on your issue. + + =head2 Source Code + + This is open source software. The code repository is available for + public review and contribution under the terms of the license. + + L + + git clone https://github.com/chansen/p5-http-tiny.git + + =head1 AUTHORS + + =over 4 + + =item * + + Christian Hansen + + =item * + + David Golden + + =back + + =head1 CONTRIBUTORS + + =for stopwords Alan Gardner Alessandro Ghedini Brad Gilbert Chris Nehren Weyl Claes Jakobsson Clinton Gormley Dean Pearce Edward Zborowski James Raspass Jeremy Mates Jess Robinson Lukas Eklund Martin J. Evans Martin-Louis Bright Mike Doherty Olaf Alders Olivier Mengué Petr Písař Sören Kornetzki Syohei YOSHIDA Tatsuhiko Miyagawa Tom Hukins Tony Cook + + =over 4 + + =item * + + Alan Gardner + + =item * + + Alessandro Ghedini + + =item * + + Brad Gilbert + + =item * + + Chris Nehren + + =item * + + Chris Weyl + + =item * + + Claes Jakobsson + + =item * + + Clinton Gormley + + =item * + + Dean Pearce + + =item * + + Edward Zborowski + + =item * + + James Raspass + + =item * + + Jeremy Mates + + =item * + + Jess Robinson + + =item * + + Lukas Eklund + + =item * + + Martin J. Evans + + =item * + + Martin-Louis Bright + + =item * + + Mike Doherty + + =item * + + Olaf Alders + + =item * + + Olivier Mengué + + =item * + + Petr Písař + + =item * + + Sören Kornetzki + + =item * + + Syohei YOSHIDA + + =item * + + Tatsuhiko Miyagawa + + =item * + + Tom Hukins + + =item * + + Tony Cook + + =back + + =head1 COPYRIGHT AND LICENSE + + This software is copyright (c) 2015 by Christian Hansen. + + This is free software; you can redistribute it and/or modify it under + the same terms as the Perl 5 programming language system itself. + + =cut + HTTP_TINY + + $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP'; + package JSON::PP; + + # JSON-2.0 + + use 5.005; + use strict; + use base qw(Exporter); + use overload (); + + use Carp (); + use B (); + #use Devel::Peek; + + $JSON::PP::VERSION = '2.27300'; + + @JSON::PP::EXPORT = qw(encode_json decode_json from_json to_json); + + # instead of hash-access, i tried index-access for speed. + # but this method is not faster than what i expected. so it will be changed. + + use constant P_ASCII => 0; + use constant P_LATIN1 => 1; + use constant P_UTF8 => 2; + use constant P_INDENT => 3; + use constant P_CANONICAL => 4; + use constant P_SPACE_BEFORE => 5; + use constant P_SPACE_AFTER => 6; + use constant P_ALLOW_NONREF => 7; + use constant P_SHRINK => 8; + use constant P_ALLOW_BLESSED => 9; + use constant P_CONVERT_BLESSED => 10; + use constant P_RELAXED => 11; + + use constant P_LOOSE => 12; + use constant P_ALLOW_BIGNUM => 13; + use constant P_ALLOW_BAREKEY => 14; + use constant P_ALLOW_SINGLEQUOTE => 15; + use constant P_ESCAPE_SLASH => 16; + use constant P_AS_NONBLESSED => 17; + + use constant P_ALLOW_UNKNOWN => 18; + + use constant OLD_PERL => $] < 5.008 ? 1 : 0; + + BEGIN { + my @xs_compati_bit_properties = qw( + latin1 ascii utf8 indent canonical space_before space_after allow_nonref shrink + allow_blessed convert_blessed relaxed allow_unknown + ); + my @pp_bit_properties = qw( + allow_singlequote allow_bignum loose + allow_barekey escape_slash as_nonblessed + ); + + # Perl version check, Unicode handling is enable? + # Helper module sets @JSON::PP::_properties. + if ($] < 5.008 ) { + my $helper = $] >= 5.006 ? 'JSON::PP::Compat5006' : 'JSON::PP::Compat5005'; + eval qq| require $helper |; + if ($@) { Carp::croak $@; } + } + + for my $name (@xs_compati_bit_properties, @pp_bit_properties) { + my $flag_name = 'P_' . uc($name); + + eval qq/ + sub $name { + my \$enable = defined \$_[1] ? \$_[1] : 1; + + if (\$enable) { + \$_[0]->{PROPS}->[$flag_name] = 1; + } + else { + \$_[0]->{PROPS}->[$flag_name] = 0; + } + + \$_[0]; + } + + sub get_$name { + \$_[0]->{PROPS}->[$flag_name] ? 1 : ''; + } + /; + } + + } + + + + # Functions + + my %encode_allow_method + = map {($_ => 1)} qw/utf8 pretty allow_nonref latin1 self_encode escape_slash + allow_blessed convert_blessed indent indent_length allow_bignum + as_nonblessed + /; + my %decode_allow_method + = map {($_ => 1)} qw/utf8 allow_nonref loose allow_singlequote allow_bignum + allow_barekey max_size relaxed/; + + + my $JSON; # cache + + sub encode_json ($) { # encode + ($JSON ||= __PACKAGE__->new->utf8)->encode(@_); + } + + + sub decode_json { # decode + ($JSON ||= __PACKAGE__->new->utf8)->decode(@_); + } + + # Obsoleted + + sub to_json($) { + Carp::croak ("JSON::PP::to_json has been renamed to encode_json."); + } + + + sub from_json($) { + Carp::croak ("JSON::PP::from_json has been renamed to decode_json."); + } + + + # Methods + + sub new { + my $class = shift; + my $self = { + max_depth => 512, + max_size => 0, + indent => 0, + FLAGS => 0, + fallback => sub { encode_error('Invalid value. JSON can only reference.') }, + indent_length => 3, + }; + + bless $self, $class; + } + + + sub encode { + return $_[0]->PP_encode_json($_[1]); + } + + + sub decode { + return $_[0]->PP_decode_json($_[1], 0x00000000); + } + + + sub decode_prefix { + return $_[0]->PP_decode_json($_[1], 0x00000001); + } + + + # accessor + + + # pretty printing + + sub pretty { + my ($self, $v) = @_; + my $enable = defined $v ? $v : 1; + + if ($enable) { # indent_length(3) for JSON::XS compatibility + $self->indent(1)->indent_length(3)->space_before(1)->space_after(1); + } + else { + $self->indent(0)->space_before(0)->space_after(0); + } + + $self; + } + + # etc + + sub max_depth { + my $max = defined $_[1] ? $_[1] : 0x80000000; + $_[0]->{max_depth} = $max; + $_[0]; + } + + + sub get_max_depth { $_[0]->{max_depth}; } + + + sub max_size { + my $max = defined $_[1] ? $_[1] : 0; + $_[0]->{max_size} = $max; + $_[0]; + } + + + sub get_max_size { $_[0]->{max_size}; } + + + sub filter_json_object { + $_[0]->{cb_object} = defined $_[1] ? $_[1] : 0; + $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0; + $_[0]; + } + + sub filter_json_single_key_object { + if (@_ > 1) { + $_[0]->{cb_sk_object}->{$_[1]} = $_[2]; + } + $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0; + $_[0]; + } + + sub indent_length { + if (!defined $_[1] or $_[1] > 15 or $_[1] < 0) { + Carp::carp "The acceptable range of indent_length() is 0 to 15."; + } + else { + $_[0]->{indent_length} = $_[1]; + } + $_[0]; + } + + sub get_indent_length { + $_[0]->{indent_length}; + } + + sub sort_by { + $_[0]->{sort_by} = defined $_[1] ? $_[1] : 1; + $_[0]; + } + + sub allow_bigint { + Carp::carp("allow_bigint() is obsoleted. use allow_bignum() insted."); + } + + ############################### + + ### + ### Perl => JSON + ### + + + { # Convert + + my $max_depth; + my $indent; + my $ascii; + my $latin1; + my $utf8; + my $space_before; + my $space_after; + my $canonical; + my $allow_blessed; + my $convert_blessed; + + my $indent_length; + my $escape_slash; + my $bignum; + my $as_nonblessed; + + my $depth; + my $indent_count; + my $keysort; + + + sub PP_encode_json { + my $self = shift; + my $obj = shift; + + $indent_count = 0; + $depth = 0; + + my $idx = $self->{PROPS}; + + ($ascii, $latin1, $utf8, $indent, $canonical, $space_before, $space_after, $allow_blessed, + $convert_blessed, $escape_slash, $bignum, $as_nonblessed) + = @{$idx}[P_ASCII .. P_SPACE_AFTER, P_ALLOW_BLESSED, P_CONVERT_BLESSED, + P_ESCAPE_SLASH, P_ALLOW_BIGNUM, P_AS_NONBLESSED]; + + ($max_depth, $indent_length) = @{$self}{qw/max_depth indent_length/}; + + $keysort = $canonical ? sub { $a cmp $b } : undef; + + if ($self->{sort_by}) { + $keysort = ref($self->{sort_by}) eq 'CODE' ? $self->{sort_by} + : $self->{sort_by} =~ /\D+/ ? $self->{sort_by} + : sub { $a cmp $b }; + } + + encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)") + if(!ref $obj and !$idx->[ P_ALLOW_NONREF ]); + + my $str = $self->object_to_json($obj); + + $str .= "\n" if ( $indent ); # JSON::XS 2.26 compatible + + unless ($ascii or $latin1 or $utf8) { + utf8::upgrade($str); + } + + if ($idx->[ P_SHRINK ]) { + utf8::downgrade($str, 1); + } + + return $str; + } + + + sub object_to_json { + my ($self, $obj) = @_; + my $type = ref($obj); + + if($type eq 'HASH'){ + return $self->hash_to_json($obj); + } + elsif($type eq 'ARRAY'){ + return $self->array_to_json($obj); + } + elsif ($type) { # blessed object? + if (blessed($obj)) { + + return $self->value_to_json($obj) if ( $obj->isa('JSON::PP::Boolean') ); + + if ( $convert_blessed and $obj->can('TO_JSON') ) { + my $result = $obj->TO_JSON(); + if ( defined $result and ref( $result ) ) { + if ( refaddr( $obj ) eq refaddr( $result ) ) { + encode_error( sprintf( + "%s::TO_JSON method returned same object as was passed instead of a new one", + ref $obj + ) ); + } + } + + return $self->object_to_json( $result ); + } + + return "$obj" if ( $bignum and _is_bignum($obj) ); + return $self->blessed_to_json($obj) if ($allow_blessed and $as_nonblessed); # will be removed. + + encode_error( sprintf("encountered object '%s', but neither allow_blessed " + . "nor convert_blessed settings are enabled", $obj) + ) unless ($allow_blessed); + + return 'null'; + } + else { + return $self->value_to_json($obj); + } + } + else{ + return $self->value_to_json($obj); + } + } + + + sub hash_to_json { + my ($self, $obj) = @_; + my @res; + + encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)") + if (++$depth > $max_depth); + + my ($pre, $post) = $indent ? $self->_up_indent() : ('', ''); + my $del = ($space_before ? ' ' : '') . ':' . ($space_after ? ' ' : ''); + + for my $k ( _sort( $obj ) ) { + if ( OLD_PERL ) { utf8::decode($k) } # key for Perl 5.6 / be optimized + push @res, string_to_json( $self, $k ) + . $del + . ( $self->object_to_json( $obj->{$k} ) || $self->value_to_json( $obj->{$k} ) ); + } + + --$depth; + $self->_down_indent() if ($indent); + + return '{' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . '}'; + } + + + sub array_to_json { + my ($self, $obj) = @_; + my @res; + + encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)") + if (++$depth > $max_depth); + + my ($pre, $post) = $indent ? $self->_up_indent() : ('', ''); + + for my $v (@$obj){ + push @res, $self->object_to_json($v) || $self->value_to_json($v); + } + + --$depth; + $self->_down_indent() if ($indent); + + return '[' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . ']'; + } + + + sub value_to_json { + my ($self, $value) = @_; + + return 'null' if(!defined $value); + + my $b_obj = B::svref_2object(\$value); # for round trip problem + my $flags = $b_obj->FLAGS; + + return $value # as is + if $flags & ( B::SVp_IOK | B::SVp_NOK ) and !( $flags & B::SVp_POK ); # SvTYPE is IV or NV? + + my $type = ref($value); + + if(!$type){ + return string_to_json($self, $value); + } + elsif( blessed($value) and $value->isa('JSON::PP::Boolean') ){ + return $$value == 1 ? 'true' : 'false'; + } + elsif ($type) { + if ((overload::StrVal($value) =~ /=(\w+)/)[0]) { + return $self->value_to_json("$value"); + } + + if ($type eq 'SCALAR' and defined $$value) { + return $$value eq '1' ? 'true' + : $$value eq '0' ? 'false' + : $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ? 'null' + : encode_error("cannot encode reference to scalar"); + } + + if ( $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ) { + return 'null'; + } + else { + if ( $type eq 'SCALAR' or $type eq 'REF' ) { + encode_error("cannot encode reference to scalar"); + } + else { + encode_error("encountered $value, but JSON can only represent references to arrays or hashes"); + } + } + + } + else { + return $self->{fallback}->($value) + if ($self->{fallback} and ref($self->{fallback}) eq 'CODE'); + return 'null'; + } + + } + + + my %esc = ( + "\n" => '\n', + "\r" => '\r', + "\t" => '\t', + "\f" => '\f', + "\b" => '\b', + "\"" => '\"', + "\\" => '\\\\', + "\'" => '\\\'', + ); + + + sub string_to_json { + my ($self, $arg) = @_; + + $arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g; + $arg =~ s/\//\\\//g if ($escape_slash); + $arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg; + + if ($ascii) { + $arg = JSON_PP_encode_ascii($arg); + } + + if ($latin1) { + $arg = JSON_PP_encode_latin1($arg); + } + + if ($utf8) { + utf8::encode($arg); + } + + return '"' . $arg . '"'; + } + + + sub blessed_to_json { + my $reftype = reftype($_[1]) || ''; + if ($reftype eq 'HASH') { + return $_[0]->hash_to_json($_[1]); + } + elsif ($reftype eq 'ARRAY') { + return $_[0]->array_to_json($_[1]); + } + else { + return 'null'; + } + } + + + sub encode_error { + my $error = shift; + Carp::croak "$error"; + } + + + sub _sort { + defined $keysort ? (sort $keysort (keys %{$_[0]})) : keys %{$_[0]}; + } + + + sub _up_indent { + my $self = shift; + my $space = ' ' x $indent_length; + + my ($pre,$post) = ('',''); + + $post = "\n" . $space x $indent_count; + + $indent_count++; + + $pre = "\n" . $space x $indent_count; + + return ($pre,$post); + } + + + sub _down_indent { $indent_count--; } + + + sub PP_encode_box { + { + depth => $depth, + indent_count => $indent_count, + }; + } + + } # Convert + + + sub _encode_ascii { + join('', + map { + $_ <= 127 ? + chr($_) : + $_ <= 65535 ? + sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_)); + } unpack('U*', $_[0]) + ); + } + + + sub _encode_latin1 { + join('', + map { + $_ <= 255 ? + chr($_) : + $_ <= 65535 ? + sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_)); + } unpack('U*', $_[0]) + ); + } + + + sub _encode_surrogates { # from perlunicode + my $uni = $_[0] - 0x10000; + return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00); + } + + + sub _is_bignum { + $_[0]->isa('Math::BigInt') or $_[0]->isa('Math::BigFloat'); + } + + + + # + # JSON => Perl + # + + my $max_intsize; + + BEGIN { + my $checkint = 1111; + for my $d (5..64) { + $checkint .= 1; + my $int = eval qq| $checkint |; + if ($int =~ /[eE]/) { + $max_intsize = $d - 1; + last; + } + } + } + + { # PARSE + + my %escapes = ( # by Jeremy Muhlich + b => "\x8", + t => "\x9", + n => "\xA", + f => "\xC", + r => "\xD", + '\\' => '\\', + '"' => '"', + '/' => '/', + ); + + my $text; # json data + my $at; # offset + my $ch; # 1chracter + my $len; # text length (changed according to UTF8 or NON UTF8) + # INTERNAL + my $depth; # nest counter + my $encoding; # json text encoding + my $is_valid_utf8; # temp variable + my $utf8_len; # utf8 byte length + # FLAGS + my $utf8; # must be utf8 + my $max_depth; # max nest nubmer of objects and arrays + my $max_size; + my $relaxed; + my $cb_object; + my $cb_sk_object; + + my $F_HOOK; + + my $allow_bigint; # using Math::BigInt + my $singlequote; # loosely quoting + my $loose; # + my $allow_barekey; # bareKey + + # $opt flag + # 0x00000001 .... decode_prefix + # 0x10000000 .... incr_parse + + sub PP_decode_json { + my ($self, $opt); # $opt is an effective flag during this decode_json. + + ($self, $text, $opt) = @_; + + ($at, $ch, $depth) = (0, '', 0); + + if ( !defined $text or ref $text ) { + decode_error("malformed JSON string, neither array, object, number, string or atom"); + } + + my $idx = $self->{PROPS}; + + ($utf8, $relaxed, $loose, $allow_bigint, $allow_barekey, $singlequote) + = @{$idx}[P_UTF8, P_RELAXED, P_LOOSE .. P_ALLOW_SINGLEQUOTE]; + + if ( $utf8 ) { + utf8::downgrade( $text, 1 ) or Carp::croak("Wide character in subroutine entry"); + } + else { + utf8::upgrade( $text ); + utf8::encode( $text ); + } + + $len = length $text; + + ($max_depth, $max_size, $cb_object, $cb_sk_object, $F_HOOK) + = @{$self}{qw/max_depth max_size cb_object cb_sk_object F_HOOK/}; + + if ($max_size > 1) { + use bytes; + my $bytes = length $text; + decode_error( + sprintf("attempted decode of JSON text of %s bytes size, but max_size is set to %s" + , $bytes, $max_size), 1 + ) if ($bytes > $max_size); + } + + # Currently no effect + # should use regexp + my @octets = unpack('C4', $text); + $encoding = ( $octets[0] and $octets[1]) ? 'UTF-8' + : (!$octets[0] and $octets[1]) ? 'UTF-16BE' + : (!$octets[0] and !$octets[1]) ? 'UTF-32BE' + : ( $octets[2] ) ? 'UTF-16LE' + : (!$octets[2] ) ? 'UTF-32LE' + : 'unknown'; + + white(); # remove head white space + + my $valid_start = defined $ch; # Is there a first character for JSON structure? + + my $result = value(); + + return undef if ( !$result && ( $opt & 0x10000000 ) ); # for incr_parse + + decode_error("malformed JSON string, neither array, object, number, string or atom") unless $valid_start; + + if ( !$idx->[ P_ALLOW_NONREF ] and !ref $result ) { + decode_error( + 'JSON text must be an object or array (but found number, string, true, false or null,' + . ' use allow_nonref to allow this)', 1); + } + + Carp::croak('something wrong.') if $len < $at; # we won't arrive here. + + my $consumed = defined $ch ? $at - 1 : $at; # consumed JSON text length + + white(); # remove tail white space + + if ( $ch ) { + return ( $result, $consumed ) if ($opt & 0x00000001); # all right if decode_prefix + decode_error("garbage after JSON object"); + } + + ( $opt & 0x00000001 ) ? ( $result, $consumed ) : $result; + } + + + sub next_chr { + return $ch = undef if($at >= $len); + $ch = substr($text, $at++, 1); + } + + + sub value { + white(); + return if(!defined $ch); + return object() if($ch eq '{'); + return array() if($ch eq '['); + return string() if($ch eq '"' or ($singlequote and $ch eq "'")); + return number() if($ch =~ /[0-9]/ or $ch eq '-'); + return word(); + } + + sub string { + my ($i, $s, $t, $u); + my $utf16; + my $is_utf8; + + ($is_valid_utf8, $utf8_len) = ('', 0); + + $s = ''; # basically UTF8 flag on + + if($ch eq '"' or ($singlequote and $ch eq "'")){ + my $boundChar = $ch; + + OUTER: while( defined(next_chr()) ){ + + if($ch eq $boundChar){ + next_chr(); + + if ($utf16) { + decode_error("missing low surrogate character in surrogate pair"); + } + + utf8::decode($s) if($is_utf8); + + return $s; + } + elsif($ch eq '\\'){ + next_chr(); + if(exists $escapes{$ch}){ + $s .= $escapes{$ch}; + } + elsif($ch eq 'u'){ # UNICODE handling + my $u = ''; + + for(1..4){ + $ch = next_chr(); + last OUTER if($ch !~ /[0-9a-fA-F]/); + $u .= $ch; + } + + # U+D800 - U+DBFF + if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/) { # UTF-16 high surrogate? + $utf16 = $u; + } + # U+DC00 - U+DFFF + elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/) { # UTF-16 low surrogate? + unless (defined $utf16) { + decode_error("missing high surrogate character in surrogate pair"); + } + $is_utf8 = 1; + $s .= JSON_PP_decode_surrogates($utf16, $u) || next; + $utf16 = undef; + } + else { + if (defined $utf16) { + decode_error("surrogate pair expected"); + } + + if ( ( my $hex = hex( $u ) ) > 127 ) { + $is_utf8 = 1; + $s .= JSON_PP_decode_unicode($u) || next; + } + else { + $s .= chr $hex; + } + } + + } + else{ + unless ($loose) { + $at -= 2; + decode_error('illegal backslash escape sequence in string'); + } + $s .= $ch; + } + } + else{ + + if ( ord $ch > 127 ) { + unless( $ch = is_valid_utf8($ch) ) { + $at -= 1; + decode_error("malformed UTF-8 character in JSON string"); + } + else { + $at += $utf8_len - 1; + } + + $is_utf8 = 1; + } + + if (!$loose) { + if ($ch =~ /[\x00-\x1f\x22\x5c]/) { # '/' ok + $at--; + decode_error('invalid character encountered while parsing JSON string'); + } + } + + $s .= $ch; + } + } + } + + decode_error("unexpected end of string while parsing JSON string"); + } + + + sub white { + while( defined $ch ){ + if($ch le ' '){ + next_chr(); + } + elsif($ch eq '/'){ + next_chr(); + if(defined $ch and $ch eq '/'){ + 1 while(defined(next_chr()) and $ch ne "\n" and $ch ne "\r"); + } + elsif(defined $ch and $ch eq '*'){ + next_chr(); + while(1){ + if(defined $ch){ + if($ch eq '*'){ + if(defined(next_chr()) and $ch eq '/'){ + next_chr(); + last; + } + } + else{ + next_chr(); + } + } + else{ + decode_error("Unterminated comment"); + } + } + next; + } + else{ + $at--; + decode_error("malformed JSON string, neither array, object, number, string or atom"); + } + } + else{ + if ($relaxed and $ch eq '#') { # correctly? + pos($text) = $at; + $text =~ /\G([^\n]*(?:\r\n|\r|\n|$))/g; + $at = pos($text); + next_chr; + next; + } + + last; + } + } + } + + + sub array { + my $a = $_[0] || []; # you can use this code to use another array ref object. + + decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)') + if (++$depth > $max_depth); + + next_chr(); + white(); + + if(defined $ch and $ch eq ']'){ + --$depth; + next_chr(); + return $a; + } + else { + while(defined($ch)){ + push @$a, value(); + + white(); + + if (!defined $ch) { + last; + } + + if($ch eq ']'){ + --$depth; + next_chr(); + return $a; + } + + if($ch ne ','){ + last; + } + + next_chr(); + white(); + + if ($relaxed and $ch eq ']') { + --$depth; + next_chr(); + return $a; + } + + } + } + + decode_error(", or ] expected while parsing array"); + } + + + sub object { + my $o = $_[0] || {}; # you can use this code to use another hash ref object. + my $k; + + decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)') + if (++$depth > $max_depth); + next_chr(); + white(); + + if(defined $ch and $ch eq '}'){ + --$depth; + next_chr(); + if ($F_HOOK) { + return _json_object_hook($o); + } + return $o; + } + else { + while (defined $ch) { + $k = ($allow_barekey and $ch ne '"' and $ch ne "'") ? bareKey() : string(); + white(); + + if(!defined $ch or $ch ne ':'){ + $at--; + decode_error("':' expected"); + } + + next_chr(); + $o->{$k} = value(); + white(); + + last if (!defined $ch); + + if($ch eq '}'){ + --$depth; + next_chr(); + if ($F_HOOK) { + return _json_object_hook($o); + } + return $o; + } + + if($ch ne ','){ + last; + } + + next_chr(); + white(); + + if ($relaxed and $ch eq '}') { + --$depth; + next_chr(); + if ($F_HOOK) { + return _json_object_hook($o); + } + return $o; + } + + } + + } + + $at--; + decode_error(", or } expected while parsing object/hash"); + } + + + sub bareKey { # doesn't strictly follow Standard ECMA-262 3rd Edition + my $key; + while($ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){ + $key .= $ch; + next_chr(); + } + return $key; + } + + + sub word { + my $word = substr($text,$at-1,4); + + if($word eq 'true'){ + $at += 3; + next_chr; + return $JSON::PP::true; + } + elsif($word eq 'null'){ + $at += 3; + next_chr; + return undef; + } + elsif($word eq 'fals'){ + $at += 3; + if(substr($text,$at,1) eq 'e'){ + $at++; + next_chr; + return $JSON::PP::false; + } + } + + $at--; # for decode_error report + + decode_error("'null' expected") if ($word =~ /^n/); + decode_error("'true' expected") if ($word =~ /^t/); + decode_error("'false' expected") if ($word =~ /^f/); + decode_error("malformed JSON string, neither array, object, number, string or atom"); + } + + + sub number { + my $n = ''; + my $v; + + # According to RFC4627, hex or oct digts are invalid. + if($ch eq '0'){ + my $peek = substr($text,$at,1); + my $hex = $peek =~ /[xX]/; # 0 or 1 + + if($hex){ + decode_error("malformed number (leading zero must not be followed by another digit)"); + ($n) = ( substr($text, $at+1) =~ /^([0-9a-fA-F]+)/); + } + else{ # oct + ($n) = ( substr($text, $at) =~ /^([0-7]+)/); + if (defined $n and length $n > 1) { + decode_error("malformed number (leading zero must not be followed by another digit)"); + } + } + + if(defined $n and length($n)){ + if (!$hex and length($n) == 1) { + decode_error("malformed number (leading zero must not be followed by another digit)"); + } + $at += length($n) + $hex; + next_chr; + return $hex ? hex($n) : oct($n); + } + } + + if($ch eq '-'){ + $n = '-'; + next_chr; + if (!defined $ch or $ch !~ /\d/) { + decode_error("malformed number (no digits after initial minus)"); + } + } + + while(defined $ch and $ch =~ /\d/){ + $n .= $ch; + next_chr; + } + + if(defined $ch and $ch eq '.'){ + $n .= '.'; + + next_chr; + if (!defined $ch or $ch !~ /\d/) { + decode_error("malformed number (no digits after decimal point)"); + } + else { + $n .= $ch; + } + + while(defined(next_chr) and $ch =~ /\d/){ + $n .= $ch; + } + } + + if(defined $ch and ($ch eq 'e' or $ch eq 'E')){ + $n .= $ch; + next_chr; + + if(defined($ch) and ($ch eq '+' or $ch eq '-')){ + $n .= $ch; + next_chr; + if (!defined $ch or $ch =~ /\D/) { + decode_error("malformed number (no digits after exp sign)"); + } + $n .= $ch; + } + elsif(defined($ch) and $ch =~ /\d/){ + $n .= $ch; + } + else { + decode_error("malformed number (no digits after exp sign)"); + } + + while(defined(next_chr) and $ch =~ /\d/){ + $n .= $ch; + } + + } + + $v .= $n; + + if ($v !~ /[.eE]/ and length $v > $max_intsize) { + if ($allow_bigint) { # from Adam Sussman + require Math::BigInt; + return Math::BigInt->new($v); + } + else { + return "$v"; + } + } + elsif ($allow_bigint) { + require Math::BigFloat; + return Math::BigFloat->new($v); + } + + return 0+$v; + } + + + sub is_valid_utf8 { + + $utf8_len = $_[0] =~ /[\x00-\x7F]/ ? 1 + : $_[0] =~ /[\xC2-\xDF]/ ? 2 + : $_[0] =~ /[\xE0-\xEF]/ ? 3 + : $_[0] =~ /[\xF0-\xF4]/ ? 4 + : 0 + ; + + return unless $utf8_len; + + my $is_valid_utf8 = substr($text, $at - 1, $utf8_len); + + return ( $is_valid_utf8 =~ /^(?: + [\x00-\x7F] + |[\xC2-\xDF][\x80-\xBF] + |[\xE0][\xA0-\xBF][\x80-\xBF] + |[\xE1-\xEC][\x80-\xBF][\x80-\xBF] + |[\xED][\x80-\x9F][\x80-\xBF] + |[\xEE-\xEF][\x80-\xBF][\x80-\xBF] + |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF] + |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF] + |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF] + )$/x ) ? $is_valid_utf8 : ''; + } + + + sub decode_error { + my $error = shift; + my $no_rep = shift; + my $str = defined $text ? substr($text, $at) : ''; + my $mess = ''; + my $type = $] >= 5.008 ? 'U*' + : $] < 5.006 ? 'C*' + : utf8::is_utf8( $str ) ? 'U*' # 5.6 + : 'C*' + ; + + for my $c ( unpack( $type, $str ) ) { # emulate pv_uni_display() ? + $mess .= $c == 0x07 ? '\a' + : $c == 0x09 ? '\t' + : $c == 0x0a ? '\n' + : $c == 0x0d ? '\r' + : $c == 0x0c ? '\f' + : $c < 0x20 ? sprintf('\x{%x}', $c) + : $c == 0x5c ? '\\\\' + : $c < 0x80 ? chr($c) + : sprintf('\x{%x}', $c) + ; + if ( length $mess >= 20 ) { + $mess .= '...'; + last; + } + } + + unless ( length $mess ) { + $mess = '(end of string)'; + } + + Carp::croak ( + $no_rep ? "$error" : "$error, at character offset $at (before \"$mess\")" + ); + + } + + + sub _json_object_hook { + my $o = $_[0]; + my @ks = keys %{$o}; + + if ( $cb_sk_object and @ks == 1 and exists $cb_sk_object->{ $ks[0] } and ref $cb_sk_object->{ $ks[0] } ) { + my @val = $cb_sk_object->{ $ks[0] }->( $o->{$ks[0]} ); + if (@val == 1) { + return $val[0]; + } + } + + my @val = $cb_object->($o) if ($cb_object); + if (@val == 0 or @val > 1) { + return $o; + } + else { + return $val[0]; + } + } + + + sub PP_decode_box { + { + text => $text, + at => $at, + ch => $ch, + len => $len, + depth => $depth, + encoding => $encoding, + is_valid_utf8 => $is_valid_utf8, + }; + } + + } # PARSE + + + sub _decode_surrogates { # from perlunicode + my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00); + my $un = pack('U*', $uni); + utf8::encode( $un ); + return $un; + } + + + sub _decode_unicode { + my $un = pack('U', hex shift); + utf8::encode( $un ); + return $un; + } + + # + # Setup for various Perl versions (the code from JSON::PP58) + # + + BEGIN { + + unless ( defined &utf8::is_utf8 ) { + require Encode; + *utf8::is_utf8 = *Encode::is_utf8; + } + + if ( $] >= 5.008 ) { + *JSON::PP::JSON_PP_encode_ascii = \&_encode_ascii; + *JSON::PP::JSON_PP_encode_latin1 = \&_encode_latin1; + *JSON::PP::JSON_PP_decode_surrogates = \&_decode_surrogates; + *JSON::PP::JSON_PP_decode_unicode = \&_decode_unicode; + } + + if ($] >= 5.008 and $] < 5.008003) { # join() in 5.8.0 - 5.8.2 is broken. + package JSON::PP; + require subs; + subs->import('join'); + eval q| + sub join { + return '' if (@_ < 2); + my $j = shift; + my $str = shift; + for (@_) { $str .= $j . $_; } + return $str; + } + |; + } + + + sub JSON::PP::incr_parse { + local $Carp::CarpLevel = 1; + ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ ); + } + + + sub JSON::PP::incr_skip { + ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip; + } + + + sub JSON::PP::incr_reset { + ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset; + } + + eval q{ + sub JSON::PP::incr_text : lvalue { + $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new; + + if ( $_[0]->{_incr_parser}->{incr_parsing} ) { + Carp::croak("incr_text can not be called when the incremental parser already started parsing"); + } + $_[0]->{_incr_parser}->{incr_text}; + } + } if ( $] >= 5.006 ); + + } # Setup for various Perl versions (the code from JSON::PP58) + + + ############################### + # Utilities + # + + BEGIN { + eval 'require Scalar::Util'; + unless($@){ + *JSON::PP::blessed = \&Scalar::Util::blessed; + *JSON::PP::reftype = \&Scalar::Util::reftype; + *JSON::PP::refaddr = \&Scalar::Util::refaddr; + } + else{ # This code is from Sclar::Util. + # warn $@; + eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }'; + *JSON::PP::blessed = sub { + local($@, $SIG{__DIE__}, $SIG{__WARN__}); + ref($_[0]) ? eval { $_[0]->a_sub_not_likely_to_be_here } : undef; + }; + my %tmap = qw( + B::NULL SCALAR + B::HV HASH + B::AV ARRAY + B::CV CODE + B::IO IO + B::GV GLOB + B::REGEXP REGEXP + ); + *JSON::PP::reftype = sub { + my $r = shift; + + return undef unless length(ref($r)); + + my $t = ref(B::svref_2object($r)); + + return + exists $tmap{$t} ? $tmap{$t} + : length(ref($$r)) ? 'REF' + : 'SCALAR'; + }; + *JSON::PP::refaddr = sub { + return undef unless length(ref($_[0])); + + my $addr; + if(defined(my $pkg = blessed($_[0]))) { + $addr .= bless $_[0], 'Scalar::Util::Fake'; + bless $_[0], $pkg; + } + else { + $addr .= $_[0] + } + + $addr =~ /0x(\w+)/; + local $^W; + #no warnings 'portable'; + hex($1); + } + } + } + + + # shamely copied and modified from JSON::XS code. + + $JSON::PP::true = do { bless \(my $dummy = 1), "JSON::PP::Boolean" }; + $JSON::PP::false = do { bless \(my $dummy = 0), "JSON::PP::Boolean" }; + + sub is_bool { defined $_[0] and UNIVERSAL::isa($_[0], "JSON::PP::Boolean"); } + + sub true { $JSON::PP::true } + sub false { $JSON::PP::false } + sub null { undef; } + + ############################### + + package JSON::PP::Boolean; + + use overload ( + "0+" => sub { ${$_[0]} }, + "++" => sub { $_[0] = ${$_[0]} + 1 }, + "--" => sub { $_[0] = ${$_[0]} - 1 }, + fallback => 1, + ); + + + ############################### + + package JSON::PP::IncrParser; + + use strict; + + use constant INCR_M_WS => 0; # initial whitespace skipping + use constant INCR_M_STR => 1; # inside string + use constant INCR_M_BS => 2; # inside backslash + use constant INCR_M_JSON => 3; # outside anything, count nesting + use constant INCR_M_C0 => 4; + use constant INCR_M_C1 => 5; + + $JSON::PP::IncrParser::VERSION = '1.01'; + + my $unpack_format = $] < 5.006 ? 'C*' : 'U*'; + + sub new { + my ( $class ) = @_; + + bless { + incr_nest => 0, + incr_text => undef, + incr_parsing => 0, + incr_p => 0, + }, $class; + } + + + sub incr_parse { + my ( $self, $coder, $text ) = @_; + + $self->{incr_text} = '' unless ( defined $self->{incr_text} ); + + if ( defined $text ) { + if ( utf8::is_utf8( $text ) and !utf8::is_utf8( $self->{incr_text} ) ) { + utf8::upgrade( $self->{incr_text} ) ; + utf8::decode( $self->{incr_text} ) ; + } + $self->{incr_text} .= $text; + } + + + my $max_size = $coder->get_max_size; + + if ( defined wantarray ) { + + $self->{incr_mode} = INCR_M_WS unless defined $self->{incr_mode}; + + if ( wantarray ) { + my @ret; + + $self->{incr_parsing} = 1; + + do { + push @ret, $self->_incr_parse( $coder, $self->{incr_text} ); + + unless ( !$self->{incr_nest} and $self->{incr_mode} == INCR_M_JSON ) { + $self->{incr_mode} = INCR_M_WS if $self->{incr_mode} != INCR_M_STR; + } + + } until ( length $self->{incr_text} >= $self->{incr_p} ); + + $self->{incr_parsing} = 0; + + return @ret; + } + else { # in scalar context + $self->{incr_parsing} = 1; + my $obj = $self->_incr_parse( $coder, $self->{incr_text} ); + $self->{incr_parsing} = 0 if defined $obj; # pointed by Martin J. Evans + return $obj ? $obj : undef; # $obj is an empty string, parsing was completed. + } + + } + + } + + + sub _incr_parse { + my ( $self, $coder, $text, $skip ) = @_; + my $p = $self->{incr_p}; + my $restore = $p; + + my @obj; + my $len = length $text; + + if ( $self->{incr_mode} == INCR_M_WS ) { + while ( $len > $p ) { + my $s = substr( $text, $p, 1 ); + $p++ and next if ( 0x20 >= unpack($unpack_format, $s) ); + $self->{incr_mode} = INCR_M_JSON; + last; + } + } + + while ( $len > $p ) { + my $s = substr( $text, $p++, 1 ); + + if ( $s eq '"' ) { + if (substr( $text, $p - 2, 1 ) eq '\\' ) { + next; + } + + if ( $self->{incr_mode} != INCR_M_STR ) { + $self->{incr_mode} = INCR_M_STR; + } + else { + $self->{incr_mode} = INCR_M_JSON; + unless ( $self->{incr_nest} ) { + last; + } + } + } + + if ( $self->{incr_mode} == INCR_M_JSON ) { + + if ( $s eq '[' or $s eq '{' ) { + if ( ++$self->{incr_nest} > $coder->get_max_depth ) { + Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)'); + } + } + elsif ( $s eq ']' or $s eq '}' ) { + last if ( --$self->{incr_nest} <= 0 ); + } + elsif ( $s eq '#' ) { + while ( $len > $p ) { + last if substr( $text, $p++, 1 ) eq "\n"; + } + } + + } + + } + + $self->{incr_p} = $p; + + return if ( $self->{incr_mode} == INCR_M_STR and not $self->{incr_nest} ); + return if ( $self->{incr_mode} == INCR_M_JSON and $self->{incr_nest} > 0 ); + + return '' unless ( length substr( $self->{incr_text}, 0, $p ) ); + + local $Carp::CarpLevel = 2; + + $self->{incr_p} = $restore; + $self->{incr_c} = $p; + + my ( $obj, $tail ) = $coder->PP_decode_json( substr( $self->{incr_text}, 0, $p ), 0x10000001 ); + + $self->{incr_text} = substr( $self->{incr_text}, $p ); + $self->{incr_p} = 0; + + return $obj || ''; + } + + + sub incr_text { + if ( $_[0]->{incr_parsing} ) { + Carp::croak("incr_text can not be called when the incremental parser already started parsing"); + } + $_[0]->{incr_text}; + } + + + sub incr_skip { + my $self = shift; + $self->{incr_text} = substr( $self->{incr_text}, $self->{incr_c} ); + $self->{incr_p} = 0; + } + + + sub incr_reset { + my $self = shift; + $self->{incr_text} = undef; + $self->{incr_p} = 0; + $self->{incr_mode} = 0; + $self->{incr_nest} = 0; + $self->{incr_parsing} = 0; + } + + ############################### + + + 1; + __END__ + =pod + + =head1 NAME + + JSON::PP - JSON::XS compatible pure-Perl module. + + =head1 SYNOPSIS + + use JSON::PP; + + # exported functions, they croak on error + # and expect/generate UTF-8 + + $utf8_encoded_json_text = encode_json $perl_hash_or_arrayref; + $perl_hash_or_arrayref = decode_json $utf8_encoded_json_text; + + # OO-interface + + $coder = JSON::PP->new->ascii->pretty->allow_nonref; + + $json_text = $json->encode( $perl_scalar ); + $perl_scalar = $json->decode( $json_text ); + + $pretty_printed = $json->pretty->encode( $perl_scalar ); # pretty-printing + + # Note that JSON version 2.0 and above will automatically use + # JSON::XS or JSON::PP, so you should be able to just: + + use JSON; + + + =head1 VERSION + + 2.27300 + + L 2.27 (~2.30) compatible. + + =head1 NOTE + + JSON::PP had been inculded in JSON distribution (CPAN module). + It was a perl core module in Perl 5.14. + + =head1 DESCRIPTION + + This module is L compatible pure Perl module. + (Perl 5.8 or later is recommended) + + JSON::XS is the fastest and most proper JSON module on CPAN. + It is written by Marc Lehmann in C, so must be compiled and + installed in the used environment. + + JSON::PP is a pure-Perl module and has compatibility to JSON::XS. + + + =head2 FEATURES + + =over + + =item * correct unicode handling + + This module knows how to handle Unicode (depending on Perl version). + + See to L and L. + + + =item * round-trip integrity + + When you serialise a perl data structure using only data types supported + by JSON and Perl, the deserialised data structure is identical on the Perl + level. (e.g. the string "2.0" doesn't suddenly become "2" just because + it looks like a number). There I minor exceptions to this, read the + MAPPING section below to learn about those. + + + =item * strict checking of JSON correctness + + There is no guessing, no generating of illegal JSON texts by default, + and only JSON is accepted as input by default (the latter is a security feature). + But when some options are set, loose chcking features are available. + + =back + + =head1 FUNCTIONAL INTERFACE + + Some documents are copied and modified from L. + + =head2 encode_json + + $json_text = encode_json $perl_scalar + + Converts the given Perl data structure to a UTF-8 encoded, binary string. + + This function call is functionally identical to: + + $json_text = JSON::PP->new->utf8->encode($perl_scalar) + + =head2 decode_json + + $perl_scalar = decode_json $json_text + + The opposite of C: expects an UTF-8 (binary) string and tries + to parse that as an UTF-8 encoded JSON text, returning the resulting + reference. + + This function call is functionally identical to: + + $perl_scalar = JSON::PP->new->utf8->decode($json_text) + + =head2 JSON::PP::is_bool + + $is_boolean = JSON::PP::is_bool($scalar) + + Returns true if the passed scalar represents either JSON::PP::true or + JSON::PP::false, two constants that act like C<1> and C<0> respectively + and are also used to represent JSON C and C in Perl strings. + + =head2 JSON::PP::true + + Returns JSON true value which is blessed object. + It C JSON::PP::Boolean object. + + =head2 JSON::PP::false + + Returns JSON false value which is blessed object. + It C JSON::PP::Boolean object. + + =head2 JSON::PP::null + + Returns C. + + See L, below, for more information on how JSON values are mapped to + Perl. + + + =head1 HOW DO I DECODE A DATA FROM OUTER AND ENCODE TO OUTER + + This section supposes that your perl vresion is 5.8 or later. + + If you know a JSON text from an outer world - a network, a file content, and so on, + is encoded in UTF-8, you should use C or C module object + with C enable. And the decoded result will contain UNICODE characters. + + # from network + my $json = JSON::PP->new->utf8; + my $json_text = CGI->new->param( 'json_data' ); + my $perl_scalar = $json->decode( $json_text ); + + # from file content + local $/; + open( my $fh, '<', 'json.data' ); + $json_text = <$fh>; + $perl_scalar = decode_json( $json_text ); + + If an outer data is not encoded in UTF-8, firstly you should C it. + + use Encode; + local $/; + open( my $fh, '<', 'json.data' ); + my $encoding = 'cp932'; + my $unicode_json_text = decode( $encoding, <$fh> ); # UNICODE + + # or you can write the below code. + # + # open( my $fh, "<:encoding($encoding)", 'json.data' ); + # $unicode_json_text = <$fh>; + + In this case, C<$unicode_json_text> is of course UNICODE string. + So you B use C nor C module object with C enable. + Instead of them, you use C module object with C disable. + + $perl_scalar = $json->utf8(0)->decode( $unicode_json_text ); + + Or C and C: + + $perl_scalar = decode_json( encode( 'utf8', $unicode_json_text ) ); + # this way is not efficient. + + And now, you want to convert your C<$perl_scalar> into JSON data and + send it to an outer world - a network or a file content, and so on. + + Your data usually contains UNICODE strings and you want the converted data to be encoded + in UTF-8, you should use C or C module object with C enable. + + print encode_json( $perl_scalar ); # to a network? file? or display? + # or + print $json->utf8->encode( $perl_scalar ); + + If C<$perl_scalar> does not contain UNICODE but C<$encoding>-encoded strings + for some reason, then its characters are regarded as B for perl + (because it does not concern with your $encoding). + You B use C nor C module object with C enable. + Instead of them, you use C module object with C disable. + Note that the resulted text is a UNICODE string but no problem to print it. + + # $perl_scalar contains $encoding encoded string values + $unicode_json_text = $json->utf8(0)->encode( $perl_scalar ); + # $unicode_json_text consists of characters less than 0x100 + print $unicode_json_text; + + Or C all string values and C: + + $perl_scalar->{ foo } = decode( $encoding, $perl_scalar->{ foo } ); + # ... do it to each string values, then encode_json + $json_text = encode_json( $perl_scalar ); + + This method is a proper way but probably not efficient. + + See to L, L. + + + =head1 METHODS + + Basically, check to L or L. + + =head2 new + + $json = JSON::PP->new + + Rturns a new JSON::PP object that can be used to de/encode JSON + strings. + + All boolean flags described below are by default I. + + The mutators for flags all return the JSON object again and thus calls can + be chained: + + my $json = JSON::PP->new->utf8->space_after->encode({a => [1,2]}) + => {"a": [1, 2]} + + =head2 ascii + + $json = $json->ascii([$enable]) + + $enabled = $json->get_ascii + + If $enable is true (or missing), then the encode method will not generate characters outside + the code range 0..127. Any Unicode characters outside that range will be escaped using either + a single \uXXXX or a double \uHHHH\uLLLLL escape sequence, as per RFC4627. + (See to L). + + In Perl 5.005, there is no character having high value (more than 255). + See to L. + + If $enable is false, then the encode method will not escape Unicode characters unless + required by the JSON syntax or other flags. This results in a faster and more compact format. + + JSON::PP->new->ascii(1)->encode([chr 0x10401]) + => ["\ud801\udc01"] + + =head2 latin1 + + $json = $json->latin1([$enable]) + + $enabled = $json->get_latin1 + + If $enable is true (or missing), then the encode method will encode the resulting JSON + text as latin1 (or iso-8859-1), escaping any characters outside the code range 0..255. + + If $enable is false, then the encode method will not escape Unicode characters + unless required by the JSON syntax or other flags. + + JSON::XS->new->latin1->encode (["\x{89}\x{abc}"] + => ["\x{89}\\u0abc"] # (perl syntax, U+abc escaped, U+89 not) + + See to L. + + =head2 utf8 + + $json = $json->utf8([$enable]) + + $enabled = $json->get_utf8 + + If $enable is true (or missing), then the encode method will encode the JSON result + into UTF-8, as required by many protocols, while the decode method expects to be handled + an UTF-8-encoded string. Please note that UTF-8-encoded strings do not contain any + characters outside the range 0..255, they are thus useful for bytewise/binary I/O. + + (In Perl 5.005, any character outside the range 0..255 does not exist. + See to L.) + + In future versions, enabling this option might enable autodetection of the UTF-16 and UTF-32 + encoding families, as described in RFC4627. + + If $enable is false, then the encode method will return the JSON string as a (non-encoded) + Unicode string, while decode expects thus a Unicode string. Any decoding or encoding + (e.g. to UTF-8 or UTF-16) needs to be done yourself, e.g. using the Encode module. + + Example, output UTF-16BE-encoded JSON: + + use Encode; + $jsontext = encode "UTF-16BE", JSON::PP->new->encode ($object); + + Example, decode UTF-32LE-encoded JSON: + + use Encode; + $object = JSON::PP->new->decode (decode "UTF-32LE", $jsontext); + + + =head2 pretty + + $json = $json->pretty([$enable]) + + This enables (or disables) all of the C, C and + C flags in one call to generate the most readable + (or most compact) form possible. + + Equivalent to: + + $json->indent->space_before->space_after + + =head2 indent + + $json = $json->indent([$enable]) + + $enabled = $json->get_indent + + The default indent space length is three. + You can use C to change the length. + + =head2 space_before + + $json = $json->space_before([$enable]) + + $enabled = $json->get_space_before + + If C<$enable> is true (or missing), then the C method will add an extra + optional space before the C<:> separating keys from values in JSON objects. + + If C<$enable> is false, then the C method will not add any extra + space at those places. + + This setting has no effect when decoding JSON texts. + + Example, space_before enabled, space_after and indent disabled: + + {"key" :"value"} + + =head2 space_after + + $json = $json->space_after([$enable]) + + $enabled = $json->get_space_after + + If C<$enable> is true (or missing), then the C method will add an extra + optional space after the C<:> separating keys from values in JSON objects + and extra whitespace after the C<,> separating key-value pairs and array + members. + + If C<$enable> is false, then the C method will not add any extra + space at those places. + + This setting has no effect when decoding JSON texts. + + Example, space_before and indent disabled, space_after enabled: + + {"key": "value"} + + =head2 relaxed + + $json = $json->relaxed([$enable]) + + $enabled = $json->get_relaxed + + If C<$enable> is true (or missing), then C will accept some + extensions to normal JSON syntax (see below). C will not be + affected in anyway. I. I suggest only to use this option to + parse application-specific files written by humans (configuration files, + resource files etc.) + + If C<$enable> is false (the default), then C will only accept + valid JSON texts. + + Currently accepted extensions are: + + =over 4 + + =item * list items can have an end-comma + + JSON I array elements and key-value pairs with commas. This + can be annoying if you write JSON texts manually and want to be able to + quickly append elements, so this extension accepts comma at the end of + such items not just between them: + + [ + 1, + 2, <- this comma not normally allowed + ] + { + "k1": "v1", + "k2": "v2", <- this comma not normally allowed + } + + =item * shell-style '#'-comments + + Whenever JSON allows whitespace, shell-style comments are additionally + allowed. They are terminated by the first carriage-return or line-feed + character, after which more white-space and comments are allowed. + + [ + 1, # this comment not allowed in JSON + # neither this one... + ] + + =back + + =head2 canonical + + $json = $json->canonical([$enable]) + + $enabled = $json->get_canonical + + If C<$enable> is true (or missing), then the C method will output JSON objects + by sorting their keys. This is adding a comparatively high overhead. + + If C<$enable> is false, then the C method will output key-value + pairs in the order Perl stores them (which will likely change between runs + of the same script). + + This option is useful if you want the same data structure to be encoded as + the same JSON text (given the same overall settings). If it is disabled, + the same hash might be encoded differently even if contains the same data, + as key-value pairs have no inherent ordering in Perl. + + This setting has no effect when decoding JSON texts. + + If you want your own sorting routine, you can give a code referece + or a subroutine name to C. See to C. + + =head2 allow_nonref + + $json = $json->allow_nonref([$enable]) + + $enabled = $json->get_allow_nonref + + If C<$enable> is true (or missing), then the C method can convert a + non-reference into its corresponding string, number or null JSON value, + which is an extension to RFC4627. Likewise, C will accept those JSON + values instead of croaking. + + If C<$enable> is false, then the C method will croak if it isn't + passed an arrayref or hashref, as JSON texts must either be an object + or array. Likewise, C will croak if given something that is not a + JSON object or array. + + JSON::PP->new->allow_nonref->encode ("Hello, World!") + => "Hello, World!" + + =head2 allow_unknown + + $json = $json->allow_unknown ([$enable]) + + $enabled = $json->get_allow_unknown + + If $enable is true (or missing), then "encode" will *not* throw an + exception when it encounters values it cannot represent in JSON (for + example, filehandles) but instead will encode a JSON "null" value. + Note that blessed objects are not included here and are handled + separately by c. + + If $enable is false (the default), then "encode" will throw an + exception when it encounters anything it cannot encode as JSON. + + This option does not affect "decode" in any way, and it is + recommended to leave it off unless you know your communications + partner. + + =head2 allow_blessed + + $json = $json->allow_blessed([$enable]) + + $enabled = $json->get_allow_blessed + + If C<$enable> is true (or missing), then the C method will not + barf when it encounters a blessed reference. Instead, the value of the + B option will decide whether C (C + disabled or no C method found) or a representation of the + object (C enabled and C method found) is being + encoded. Has no effect on C. + + If C<$enable> is false (the default), then C will throw an + exception when it encounters a blessed object. + + =head2 convert_blessed + + $json = $json->convert_blessed([$enable]) + + $enabled = $json->get_convert_blessed + + If C<$enable> is true (or missing), then C, upon encountering a + blessed object, will check for the availability of the C method + on the object's class. If found, it will be called in scalar context + and the resulting scalar will be encoded instead of the object. If no + C method is found, the value of C will decide what + to do. + + The C method may safely call die if it wants. If C + returns other blessed objects, those will be handled in the same + way. C must take care of not causing an endless recursion cycle + (== crash) in this case. The name of C was chosen because other + methods called by the Perl core (== not by the user of the object) are + usually in upper case letters and to avoid collisions with the C + function or method. + + This setting does not yet influence C in any way. + + If C<$enable> is false, then the C setting will decide what + to do when a blessed object is found. + + =head2 filter_json_object + + $json = $json->filter_json_object([$coderef]) + + When C<$coderef> is specified, it will be called from C each + time it decodes a JSON object. The only argument passed to the coderef + is a reference to the newly-created hash. If the code references returns + a single scalar (which need not be a reference), this value + (i.e. a copy of that scalar to avoid aliasing) is inserted into the + deserialised data structure. If it returns an empty list + (NOTE: I C, which is a valid scalar), the original deserialised + hash will be inserted. This setting can slow down decoding considerably. + + When C<$coderef> is omitted or undefined, any existing callback will + be removed and C will not change the deserialised hash in any + way. + + Example, convert all JSON objects into the integer 5: + + my $js = JSON::PP->new->filter_json_object (sub { 5 }); + # returns [5] + $js->decode ('[{}]'); # the given subroutine takes a hash reference. + # throw an exception because allow_nonref is not enabled + # so a lone 5 is not allowed. + $js->decode ('{"a":1, "b":2}'); + + =head2 filter_json_single_key_object + + $json = $json->filter_json_single_key_object($key [=> $coderef]) + + Works remotely similar to C, but is only called for + JSON objects having a single key named C<$key>. + + This C<$coderef> is called before the one specified via + C, if any. It gets passed the single value in the JSON + object. If it returns a single value, it will be inserted into the data + structure. If it returns nothing (not even C but the empty list), + the callback from C will be called next, as if no + single-key callback were specified. + + If C<$coderef> is omitted or undefined, the corresponding callback will be + disabled. There can only ever be one callback for a given key. + + As this callback gets called less often then the C + one, decoding speed will not usually suffer as much. Therefore, single-key + objects make excellent targets to serialise Perl objects into, especially + as single-key JSON objects are as close to the type-tagged value concept + as JSON gets (it's basically an ID/VALUE tuple). Of course, JSON does not + support this in any way, so you need to make sure your data never looks + like a serialised Perl hash. + + Typical names for the single object key are C<__class_whatever__>, or + C<$__dollars_are_rarely_used__$> or C<}ugly_brace_placement>, or even + things like C<__class_md5sum(classname)__>, to reduce the risk of clashing + with real hashes. + + Example, decode JSON objects of the form C<< { "__widget__" => } >> + into the corresponding C<< $WIDGET{} >> object: + + # return whatever is in $WIDGET{5}: + JSON::PP + ->new + ->filter_json_single_key_object (__widget__ => sub { + $WIDGET{ $_[0] } + }) + ->decode ('{"__widget__": 5') + + # this can be used with a TO_JSON method in some "widget" class + # for serialisation to json: + sub WidgetBase::TO_JSON { + my ($self) = @_; + + unless ($self->{id}) { + $self->{id} = ..get..some..id..; + $WIDGET{$self->{id}} = $self; + } + + { __widget__ => $self->{id} } + } + + =head2 shrink + + $json = $json->shrink([$enable]) + + $enabled = $json->get_shrink + + In JSON::XS, this flag resizes strings generated by either + C or C to their minimum size possible. + It will also try to downgrade any strings to octet-form if possible. + + In JSON::PP, it is noop about resizing strings but tries + C to the returned string by C. + See to L. + + See to L + + =head2 max_depth + + $json = $json->max_depth([$maximum_nesting_depth]) + + $max_depth = $json->get_max_depth + + Sets the maximum nesting level (default C<512>) accepted while encoding + or decoding. If a higher nesting level is detected in JSON text or a Perl + data structure, then the encoder and decoder will stop and croak at that + point. + + Nesting level is defined by number of hash- or arrayrefs that the encoder + needs to traverse to reach a given point or the number of C<{> or C<[> + characters without their matching closing parenthesis crossed to reach a + given character in a string. + + If no argument is given, the highest possible setting will be used, which + is rarely useful. + + See L for more info on why this is useful. + + When a large value (100 or more) was set and it de/encodes a deep nested object/text, + it may raise a warning 'Deep recursion on subroutin' at the perl runtime phase. + + =head2 max_size + + $json = $json->max_size([$maximum_string_size]) + + $max_size = $json->get_max_size + + Set the maximum length a JSON text may have (in bytes) where decoding is + being attempted. The default is C<0>, meaning no limit. When C + is called on a string that is longer then this many bytes, it will not + attempt to decode the string but throw an exception. This setting has no + effect on C (yet). + + If no argument is given, the limit check will be deactivated (same as when + C<0> is specified). + + See L for more info on why this is useful. + + =head2 encode + + $json_text = $json->encode($perl_scalar) + + Converts the given Perl data structure (a simple scalar or a reference + to a hash or array) to its JSON representation. Simple scalars will be + converted into JSON string or number sequences, while references to arrays + become JSON arrays and references to hashes become JSON objects. Undefined + Perl values (e.g. C) become JSON C values. + References to the integers C<0> and C<1> are converted into C and C. + + =head2 decode + + $perl_scalar = $json->decode($json_text) + + The opposite of C: expects a JSON text and tries to parse it, + returning the resulting simple scalar or reference. Croaks on error. + + JSON numbers and strings become simple Perl scalars. JSON arrays become + Perl arrayrefs and JSON objects become Perl hashrefs. C becomes + C<1> (C), C becomes C<0> (C) and + C becomes C. + + =head2 decode_prefix + + ($perl_scalar, $characters) = $json->decode_prefix($json_text) + + This works like the C method, but instead of raising an exception + when there is trailing garbage after the first JSON object, it will + silently stop parsing there and return the number of characters consumed + so far. + + JSON->new->decode_prefix ("[1] the tail") + => ([], 3) + + =head1 INCREMENTAL PARSING + + Most of this section are copied and modified from L. + + In some cases, there is the need for incremental parsing of JSON texts. + This module does allow you to parse a JSON stream incrementally. + It does so by accumulating text until it has a full JSON object, which + it then can decode. This process is similar to using C + to see if a full JSON object is available, but is much more efficient + (and can be implemented with a minimum of method calls). + + This module will only attempt to parse the JSON text once it is sure it + has enough text to get a decisive result, using a very simple but + truly incremental parser. This means that it sometimes won't stop as + early as the full parser, for example, it doesn't detect parenthese + mismatches. The only thing it guarantees is that it starts decoding as + soon as a syntactically valid JSON text has been seen. This means you need + to set resource limits (e.g. C) to ensure the parser will stop + parsing in the presence if syntax errors. + + The following methods implement this incremental parser. + + =head2 incr_parse + + $json->incr_parse( [$string] ) # void context + + $obj_or_undef = $json->incr_parse( [$string] ) # scalar context + + @obj_or_empty = $json->incr_parse( [$string] ) # list context + + This is the central parsing function. It can both append new text and + extract objects from the stream accumulated so far (both of these + functions are optional). + + If C<$string> is given, then this string is appended to the already + existing JSON fragment stored in the C<$json> object. + + After that, if the function is called in void context, it will simply + return without doing anything further. This can be used to add more text + in as many chunks as you want. + + If the method is called in scalar context, then it will try to extract + exactly I JSON object. If that is successful, it will return this + object, otherwise it will return C. If there is a parse error, + this method will croak just as C would do (one can then use + C to skip the errornous part). This is the most common way of + using the method. + + And finally, in list context, it will try to extract as many objects + from the stream as it can find and return them, or the empty list + otherwise. For this to work, there must be no separators between the JSON + objects or arrays, instead they must be concatenated back-to-back. If + an error occurs, an exception will be raised as in the scalar context + case. Note that in this case, any previously-parsed JSON texts will be + lost. + + Example: Parse some JSON arrays/objects in a given string and return them. + + my @objs = JSON->new->incr_parse ("[5][7][1,2]"); + + =head2 incr_text + + $lvalue_string = $json->incr_text + + This method returns the currently stored JSON fragment as an lvalue, that + is, you can manipulate it. This I works when a preceding call to + C in I successfully returned an object. Under + all other circumstances you must not call this function (I mean it. + although in simple tests it might actually work, it I fail under + real world conditions). As a special exception, you can also call this + method before having parsed anything. + + This function is useful in two cases: a) finding the trailing text after a + JSON object or b) parsing multiple JSON objects separated by non-JSON text + (such as commas). + + $json->incr_text =~ s/\s*,\s*//; + + In Perl 5.005, C attribute is not available. + You must write codes like the below: + + $string = $json->incr_text; + $string =~ s/\s*,\s*//; + $json->incr_text( $string ); + + =head2 incr_skip + + $json->incr_skip + + This will reset the state of the incremental parser and will remove the + parsed text from the input buffer. This is useful after C + died, in which case the input buffer and incremental parser state is left + unchanged, to skip the text parsed so far and to reset the parse state. + + =head2 incr_reset + + $json->incr_reset + + This completely resets the incremental parser, that is, after this call, + it will be as if the parser had never parsed anything. + + This is useful if you want ot repeatedly parse JSON objects and want to + ignore any trailing data, which means you have to reset the parser after + each successful decode. + + See to L for examples. + + + =head1 JSON::PP OWN METHODS + + =head2 allow_singlequote + + $json = $json->allow_singlequote([$enable]) + + If C<$enable> is true (or missing), then C will accept + JSON strings quoted by single quotations that are invalid JSON + format. + + $json->allow_singlequote->decode({"foo":'bar'}); + $json->allow_singlequote->decode({'foo':"bar"}); + $json->allow_singlequote->decode({'foo':'bar'}); + + As same as the C option, this option may be used to parse + application-specific files written by humans. + + + =head2 allow_barekey + + $json = $json->allow_barekey([$enable]) + + If C<$enable> is true (or missing), then C will accept + bare keys of JSON object that are invalid JSON format. + + As same as the C option, this option may be used to parse + application-specific files written by humans. + + $json->allow_barekey->decode('{foo:"bar"}'); + + =head2 allow_bignum + + $json = $json->allow_bignum([$enable]) + + If C<$enable> is true (or missing), then C will convert + the big integer Perl cannot handle as integer into a L + object and convert a floating number (any) into a L. + + On the contary, C converts C objects and C + objects into JSON numbers with C enable. + + $json->allow_nonref->allow_blessed->allow_bignum; + $bigfloat = $json->decode('2.000000000000000000000000001'); + print $json->encode($bigfloat); + # => 2.000000000000000000000000001 + + See to L aboout the normal conversion of JSON number. + + =head2 loose + + $json = $json->loose([$enable]) + + The unescaped [\x00-\x1f\x22\x2f\x5c] strings are invalid in JSON strings + and the module doesn't allow to C to these (except for \x2f). + If C<$enable> is true (or missing), then C will accept these + unescaped strings. + + $json->loose->decode(qq|["abc + def"]|); + + See L. + + =head2 escape_slash + + $json = $json->escape_slash([$enable]) + + According to JSON Grammar, I (U+002F) is escaped. But default + JSON::PP (as same as JSON::XS) encodes strings without escaping slash. + + If C<$enable> is true (or missing), then C will escape slashes. + + =head2 indent_length + + $json = $json->indent_length($length) + + JSON::XS indent space length is 3 and cannot be changed. + JSON::PP set the indent space length with the given $length. + The default is 3. The acceptable range is 0 to 15. + + =head2 sort_by + + $json = $json->sort_by($function_name) + $json = $json->sort_by($subroutine_ref) + + If $function_name or $subroutine_ref are set, its sort routine are used + in encoding JSON objects. + + $js = $pc->sort_by(sub { $JSON::PP::a cmp $JSON::PP::b })->encode($obj); + # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|); + + $js = $pc->sort_by('own_sort')->encode($obj); + # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|); + + sub JSON::PP::own_sort { $JSON::PP::a cmp $JSON::PP::b } + + As the sorting routine runs in the JSON::PP scope, the given + subroutine name and the special variables C<$a>, C<$b> will begin + 'JSON::PP::'. + + If $integer is set, then the effect is same as C on. + + =head1 INTERNAL + + For developers. + + =over + + =item PP_encode_box + + Returns + + { + depth => $depth, + indent_count => $indent_count, + } + + + =item PP_decode_box + + Returns + + { + text => $text, + at => $at, + ch => $ch, + len => $len, + depth => $depth, + encoding => $encoding, + is_valid_utf8 => $is_valid_utf8, + }; + + =back + + =head1 MAPPING + + This section is copied from JSON::XS and modified to C. + JSON::XS and JSON::PP mapping mechanisms are almost equivalent. + + See to L. + + =head2 JSON -> PERL + + =over 4 + + =item object + + A JSON object becomes a reference to a hash in Perl. No ordering of object + keys is preserved (JSON does not preserver object key ordering itself). + + =item array + + A JSON array becomes a reference to an array in Perl. + + =item string + + A JSON string becomes a string scalar in Perl - Unicode codepoints in JSON + are represented by the same codepoints in the Perl string, so no manual + decoding is necessary. + + =item number + + A JSON number becomes either an integer, numeric (floating point) or + string scalar in perl, depending on its range and any fractional parts. On + the Perl level, there is no difference between those as Perl handles all + the conversion details, but an integer may take slightly less memory and + might represent more values exactly than floating point numbers. + + If the number consists of digits only, C will try to represent + it as an integer value. If that fails, it will try to represent it as + a numeric (floating point) value if that is possible without loss of + precision. Otherwise it will preserve the number as a string value (in + which case you lose roundtripping ability, as the JSON number will be + re-encoded toa JSON string). + + Numbers containing a fractional or exponential part will always be + represented as numeric (floating point) values, possibly at a loss of + precision (in which case you might lose perfect roundtripping ability, but + the JSON number will still be re-encoded as a JSON number). + + Note that precision is not accuracy - binary floating point values cannot + represent most decimal fractions exactly, and when converting from and to + floating point, C only guarantees precision up to but not including + the leats significant bit. + + When C is enable, the big integers + and the numeric can be optionally converted into L and + L objects. + + =item true, false + + These JSON atoms become C and C, + respectively. They are overloaded to act almost exactly like the numbers + C<1> and C<0>. You can check wether a scalar is a JSON boolean by using + the C function. + + print JSON::PP::true . "\n"; + => true + print JSON::PP::true + 1; + => 1 + + ok(JSON::true eq '1'); + ok(JSON::true == 1); + + C will install these missing overloading features to the backend modules. + + + =item null + + A JSON null atom becomes C in Perl. + + C returns C. + + =back + + + =head2 PERL -> JSON + + The mapping from Perl to JSON is slightly more difficult, as Perl is a + truly typeless language, so we can only guess which JSON type is meant by + a Perl value. + + =over 4 + + =item hash references + + Perl hash references become JSON objects. As there is no inherent ordering + in hash keys (or JSON objects), they will usually be encoded in a + pseudo-random order that can change between runs of the same program but + stays generally the same within a single run of a program. C + optionally sort the hash keys (determined by the I flag), so + the same datastructure will serialise to the same JSON text (given same + settings and version of JSON::XS), but this incurs a runtime overhead + and is only rarely useful, e.g. when you want to compare some JSON text + against another for equality. + + + =item array references + + Perl array references become JSON arrays. + + =item other references + + Other unblessed references are generally not allowed and will cause an + exception to be thrown, except for references to the integers C<0> and + C<1>, which get turned into C and C atoms in JSON. You can + also use C and C to improve readability. + + to_json [\0,JSON::PP::true] # yields [false,true] + + =item JSON::PP::true, JSON::PP::false, JSON::PP::null + + These special values become JSON true and JSON false values, + respectively. You can also use C<\1> and C<\0> directly if you want. + + JSON::PP::null returns C. + + =item blessed objects + + Blessed objects are not directly representable in JSON. See the + C and C methods on various options on + how to deal with this: basically, you can choose between throwing an + exception, encoding the reference as if it weren't blessed, or provide + your own serialiser method. + + See to L. + + =item simple scalars + + Simple Perl scalars (any scalar that is not a reference) are the most + difficult objects to encode: JSON::XS and JSON::PP will encode undefined scalars as + JSON C values, scalars that have last been used in a string context + before encoding as JSON strings, and anything else as number value: + + # dump as number + encode_json [2] # yields [2] + encode_json [-3.0e17] # yields [-3e+17] + my $value = 5; encode_json [$value] # yields [5] + + # used as string, so dump as string + print $value; + encode_json [$value] # yields ["5"] + + # undef becomes null + encode_json [undef] # yields [null] + + You can force the type to be a string by stringifying it: + + my $x = 3.1; # some variable containing a number + "$x"; # stringified + $x .= ""; # another, more awkward way to stringify + print $x; # perl does it for you, too, quite often + + You can force the type to be a number by numifying it: + + my $x = "3"; # some variable containing a string + $x += 0; # numify it, ensuring it will be dumped as a number + $x *= 1; # same thing, the choise is yours. + + You can not currently force the type in other, less obscure, ways. + + Note that numerical precision has the same meaning as under Perl (so + binary to decimal conversion follows the same rules as in Perl, which + can differ to other languages). Also, your perl interpreter might expose + extensions to the floating point numbers of your platform, such as + infinities or NaN's - these cannot be represented in JSON, and it is an + error to pass those in. + + =item Big Number + + When C is enable, + C converts C objects and C + objects into JSON numbers. + + + =back + + =head1 UNICODE HANDLING ON PERLS + + If you do not know about Unicode on Perl well, + please check L. + + =head2 Perl 5.8 and later + + Perl can handle Unicode and the JSON::PP de/encode methods also work properly. + + $json->allow_nonref->encode(chr hex 3042); + $json->allow_nonref->encode(chr hex 12345); + + Reuturns C<"\u3042"> and C<"\ud808\udf45"> respectively. + + $json->allow_nonref->decode('"\u3042"'); + $json->allow_nonref->decode('"\ud808\udf45"'); + + Returns UTF-8 encoded strings with UTF8 flag, regarded as C and C. + + Note that the versions from Perl 5.8.0 to 5.8.2, Perl built-in C was broken, + so JSON::PP wraps the C with a subroutine. Thus JSON::PP works slow in the versions. + + + =head2 Perl 5.6 + + Perl can handle Unicode and the JSON::PP de/encode methods also work. + + =head2 Perl 5.005 + + Perl 5.005 is a byte sementics world -- all strings are sequences of bytes. + That means the unicode handling is not available. + + In encoding, + + $json->allow_nonref->encode(chr hex 3042); # hex 3042 is 12354. + $json->allow_nonref->encode(chr hex 12345); # hex 12345 is 74565. + + Returns C and C, as C takes a value more than 255, it treats + as C<$value % 256>, so the above codes are equivalent to : + + $json->allow_nonref->encode(chr 66); + $json->allow_nonref->encode(chr 69); + + In decoding, + + $json->decode('"\u00e3\u0081\u0082"'); + + The returned is a byte sequence C<0xE3 0x81 0x82> for UTF-8 encoded + japanese character (C). + And if it is represented in Unicode code point, C. + + Next, + + $json->decode('"\u3042"'); + + We ordinary expect the returned value is a Unicode character C. + But here is 5.005 world. This is C<0xE3 0x81 0x82>. + + $json->decode('"\ud808\udf45"'); + + This is not a character C but bytes - C<0xf0 0x92 0x8d 0x85>. + + + =head1 TODO + + =over + + =item speed + + =item memory saving + + =back + + + =head1 SEE ALSO + + Most of the document are copied and modified from JSON::XS doc. + + L + + RFC4627 (L) + + =head1 AUTHOR + + Makamaka Hannyaharamitu, Emakamaka[at]cpan.orgE + + + =head1 COPYRIGHT AND LICENSE + + Copyright 2007-2014 by Makamaka Hannyaharamitu + + This library is free software; you can redistribute it and/or modify + it under the same terms as Perl itself. + + =cut + JSON_PP + + $fatpacked{"JSON/PP/Boolean.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP_BOOLEAN'; + =head1 NAME + + JSON::PP::Boolean - dummy module providing JSON::PP::Boolean + + =head1 SYNOPSIS + + # do not "use" yourself + + =head1 DESCRIPTION + + This module exists only to provide overload resolution for Storable and similar modules. See + L for more info about this class. + + =cut + + use JSON::PP (); + use strict; + + 1; + + =head1 AUTHOR + + This idea is from L written by Marc Lehmann + + =cut + + JSON_PP_BOOLEAN + + $fatpacked{"Module/CPANfile.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE'; + package Module::CPANfile; + use strict; + use warnings; + use Cwd; + use Carp (); + use Module::CPANfile::Environment; + use Module::CPANfile::Requirement; + + our $VERSION = '1.1000'; + + sub new { + my($class, $file) = @_; + bless {}, $class; + } + + sub load { + my($proto, $file) = @_; + + my $self = ref $proto ? $proto : $proto->new; + $self->parse($file || Cwd::abs_path('cpanfile')); + $self; + } + + sub save { + my($self, $path) = @_; + + open my $out, ">", $path or die "$path: $!"; + print {$out} $self->to_string; + } + + sub parse { + my($self, $file) = @_; + + my $code = do { + open my $fh, "<", $file or die "$file: $!"; + join '', <$fh>; + }; + + my $env = Module::CPANfile::Environment->new($file); + $env->parse($code) or die $@; + + $self->{_mirrors} = $env->mirrors; + $self->{_prereqs} = $env->prereqs; + } + + sub from_prereqs { + my($proto, $prereqs) = @_; + + my $self = $proto->new; + $self->{_prereqs} = Module::CPANfile::Prereqs->from_cpan_meta($prereqs); + + $self; + } + + sub mirrors { + my $self = shift; + $self->{_mirrors} || []; + } + + sub features { + my $self = shift; + map $self->feature($_), $self->{_prereqs}->identifiers; + } + + sub feature { + my($self, $identifier) = @_; + $self->{_prereqs}->feature($identifier); + } + + sub prereq { shift->prereqs } + + sub prereqs { + my $self = shift; + $self->{_prereqs}->as_cpan_meta; + } + + sub merged_requirements { + my $self = shift; + $self->{_prereqs}->merged_requirements; + } + + sub effective_prereqs { + my($self, $features) = @_; + $self->prereqs_with(@{$features || []}); + } + + sub prereqs_with { + my($self, @feature_identifiers) = @_; + + my $prereqs = $self->prereqs; + my @others = map { $self->feature($_)->prereqs } @feature_identifiers; + + $prereqs->with_merged_prereqs(\@others); + } + + sub prereq_specs { + my $self = shift; + $self->prereqs->as_string_hash; + } + + sub prereq_for_module { + my($self, $module) = @_; + $self->{_prereqs}->find($module); + } + + sub options_for_module { + my($self, $module) = @_; + my $prereq = $self->prereq_for_module($module) or return; + $prereq->requirement->options; + } + + sub merge_meta { + my($self, $file, $version) = @_; + + require CPAN::Meta; + + $version ||= $file =~ /\.yml$/ ? '1.4' : '2'; + + my $prereq = $self->prereqs; + + my $meta = CPAN::Meta->load_file($file); + my $prereqs_hash = $prereq->with_merged_prereqs($meta->effective_prereqs)->as_string_hash; + my $struct = { %{$meta->as_struct}, prereqs => $prereqs_hash }; + + CPAN::Meta->new($struct)->save($file, { version => $version }); + } + + sub _dump { + my $str = shift; + require Data::Dumper; + chomp(my $value = Data::Dumper->new([$str])->Terse(1)->Dump); + $value; + } + + sub to_string { + my($self, $include_empty) = @_; + + my $mirrors = $self->mirrors; + my $prereqs = $self->prereq_specs; + + my $code = ''; + $code .= $self->_dump_mirrors($mirrors); + $code .= $self->_dump_prereqs($prereqs, $include_empty); + + for my $feature ($self->features) { + $code .= sprintf "feature %s, %s => sub {\n", _dump($feature->{identifier}), _dump($feature->{description}); + $code .= $self->_dump_prereqs($feature->{spec}, $include_empty, 4); + $code .= "}\n\n"; + } + + $code =~ s/\n+$/\n/s; + $code; + } + + sub _dump_mirrors { + my($self, $mirrors) = @_; + + my $code = ""; + + for my $url (@$mirrors) { + $code .= "mirror '$url';\n"; + } + + $code =~ s/\n+$/\n/s; + $code; + } + + sub _dump_prereqs { + my($self, $prereqs, $include_empty, $base_indent) = @_; + + my $code = ''; + for my $phase (qw(runtime configure build test develop)) { + my $indent = $phase eq 'runtime' ? '' : ' '; + $indent = (' ' x ($base_indent || 0)) . $indent; + + my($phase_code, $requirements); + $phase_code .= "on $phase => sub {\n" unless $phase eq 'runtime'; + + for my $type (qw(requires recommends suggests conflicts)) { + for my $mod (sort keys %{$prereqs->{$phase}{$type}}) { + my $ver = $prereqs->{$phase}{$type}{$mod}; + $phase_code .= $ver eq '0' + ? "${indent}$type '$mod';\n" + : "${indent}$type '$mod', '$ver';\n"; + $requirements++; + } + } + + $phase_code .= "\n" unless $requirements; + $phase_code .= "};\n" unless $phase eq 'runtime'; + + $code .= $phase_code . "\n" if $requirements or $include_empty; + } + + $code =~ s/\n+$/\n/s; + $code; + } + + 1; + + __END__ + + =head1 NAME + + Module::CPANfile - Parse cpanfile + + =head1 SYNOPSIS + + use Module::CPANfile; + + my $file = Module::CPANfile->load("cpanfile"); + my $prereqs = $file->prereqs; # CPAN::Meta::Prereqs object + + my @features = $file->features; # CPAN::Meta::Feature objects + my $merged_prereqs = $file->prereqs_with(@identifiers); # CPAN::Meta::Prereqs + + $file->merge_meta('MYMETA.json'); + + =head1 DESCRIPTION + + Module::CPANfile is a tool to handle L format to load application + specific dependencies, not just for CPAN distributions. + + =head1 METHODS + + =over 4 + + =item load + + $file = Module::CPANfile->load; + $file = Module::CPANfile->load('cpanfile'); + + Load and parse a cpanfile. By default it tries to load C in + the current directory, unless you pass the path to its argument. + + =item from_prereqs + + $file = Module::CPANfile->from_prereqs({ + runtime => { requires => { DBI => '1.000' } }, + }); + + Creates a new Module::CPANfile object from prereqs hash you can get + via L's C, or L' + C. + + # read MYMETA, then feed the prereqs to create Module::CPANfile + my $meta = CPAN::Meta->load_file('MYMETA.json'); + my $file = Module::CPANfile->from_prereqs($meta->prereqs); + + # load cpanfile, then recreate it with round-trip + my $file = Module::CPANfile->load('cpanfile'); + $file = Module::CPANfile->from_prereqs($file->prereq_specs); + # or $file->prereqs->as_string_hash + + =item prereqs + + Returns L object out of the parsed cpanfile. + + =item prereq_specs + + Returns a hash reference that should be passed to C<< CPAN::Meta::Prereqs->new >>. + + =item features + + Returns a list of features available in the cpanfile as L. + + =item prereqs_with(@identifiers), effective_prereqs(\@identifiers) + + Returns L object, with merged prereqs for + features identified with the C<@identifiers>. + + =item to_string($include_empty) + + $file->to_string; + $file->to_string(1); + + Returns a canonical string (code) representation for cpanfile. Useful + if you want to convert L to a new cpanfile. + + # read MYMETA's prereqs and print cpanfile representation of it + my $meta = CPAN::Meta->load_file('MYMETA.json'); + my $file = Module::CPANfile->from_prereqs($meta->prereqs); + print $file->to_string; + + By default, it omits the phase where there're no modules + registered. If you pass the argument of a true value, it will print + them as well. + + =item save + + $file->save('cpanfile'); + + Saves the currently loaded prereqs as a new C by calling + C. Beware B. Taking a backup or giving + warnings to users is a caller's responsibility. + + # Read MYMETA.json and creates a new cpanfile + my $meta = CPAN::Meta->load_file('MYMETA.json'); + my $file = Module::CPANfile->from_prereqs($meta->prereqs); + $file->save('cpanfile'); + + =item merge_meta + + $file->merge_meta('META.yml'); + $file->merge_meta('MYMETA.json', '2.0'); + + Merge the effective prereqs with Meta specification loaded from the + given META file, using CPAN::Meta. You can specify the META spec + version in the second argument, which defaults to 1.4 in case the + given file is YAML, and 2 if it is JSON. + + =back + + =head1 AUTHOR + + Tatsuhiko Miyagawa + + =head1 SEE ALSO + + L, L, L + + =cut + MODULE_CPANFILE + + $fatpacked{"Module/CPANfile/Environment.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_ENVIRONMENT'; + package Module::CPANfile::Environment; + use strict; + use warnings; + use Module::CPANfile::Prereqs; + use Carp (); + + my @bindings = qw( + on requires recommends suggests conflicts + feature + osname + mirror + configure_requires build_requires test_requires author_requires + ); + + my $file_id = 1; + + sub new { + my($class, $file) = @_; + bless { + file => $file, + phase => 'runtime', # default phase + feature => undef, + features => {}, + prereqs => Module::CPANfile::Prereqs->new, + mirrors => [], + }, $class; + } + + sub bind { + my $self = shift; + my $pkg = caller; + + for my $binding (@bindings) { + no strict 'refs'; + *{"$pkg\::$binding"} = sub { $self->$binding(@_) }; + } + } + + sub parse { + my($self, $code) = @_; + + my $err; + { + local $@; + $file_id++; + $self->_evaluate(<bind } + + # line 1 "$self->{file}" + $code; + EVAL + $err = $@; + } + + if ($err) { die "Parsing $self->{file} failed: $err" }; + + return 1; + } + + sub _evaluate { + my $_environment = $_[0]; + eval $_[1]; + } + + sub prereqs { $_[0]->{prereqs} } + + sub mirrors { $_[0]->{mirrors} } + + # DSL goes from here + + sub on { + my($self, $phase, $code) = @_; + local $self->{phase} = $phase; + $code->(); + } + + sub feature { + my($self, $identifier, $description, $code) = @_; + + # shortcut: feature identifier => sub { ... } + if (@_ == 3 && ref($description) eq 'CODE') { + $code = $description; + $description = $identifier; + } + + unless (ref $description eq '' && ref $code eq 'CODE') { + Carp::croak("Usage: feature 'identifier', 'Description' => sub { ... }"); + } + + local $self->{feature} = $identifier; + $self->prereqs->add_feature($identifier, $description); + + $code->(); + } + + sub osname { die "TODO" } + + sub mirror { + my($self, $url) = @_; + push @{$self->{mirrors}}, $url; + } + + sub requirement_for { + my($self, $module, @args) = @_; + + my $requirement = 0; + $requirement = shift @args if @args % 2; + + return Module::CPANfile::Requirement->new( + name => $module, + version => $requirement, + @args, + ); + } + + sub requires { + my $self = shift; + $self->add_prereq(requires => @_); + } + + sub recommends { + my $self = shift; + $self->add_prereq(recommends => @_); + } + + sub suggests { + my $self = shift; + $self->add_prereq(suggests => @_); + } + + sub conflicts { + my $self = shift; + $self->add_prereq(conflicts => @_); + } + + sub add_prereq { + my($self, $type, $module, @args) = @_; + + $self->prereqs->add_prereq( + feature => $self->{feature}, + phase => $self->{phase}, + type => $type, + module => $module, + requirement => $self->requirement_for($module, @args), + ); + } + + # Module::Install compatible shortcuts + + sub configure_requires { + my($self, @args) = @_; + $self->on(configure => sub { $self->requires(@args) }); + } + + sub build_requires { + my($self, @args) = @_; + $self->on(build => sub { $self->requires(@args) }); + } + + sub test_requires { + my($self, @args) = @_; + $self->on(test => sub { $self->requires(@args) }); + } + + sub author_requires { + my($self, @args) = @_; + $self->on(develop => sub { $self->requires(@args) }); + } + + 1; + + MODULE_CPANFILE_ENVIRONMENT + + $fatpacked{"Module/CPANfile/Prereq.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_PREREQ'; + package Module::CPANfile::Prereq; + use strict; + + sub new { + my($class, %options) = @_; + bless \%options, $class; + } + + sub feature { $_[0]->{feature} } + sub phase { $_[0]->{phase} } + sub type { $_[0]->{type} } + sub module { $_[0]->{module} } + sub requirement { $_[0]->{requirement} } + + sub match_feature { + my($self, $identifier) = @_; + no warnings 'uninitialized'; + $self->feature eq $identifier; + } + + 1; + MODULE_CPANFILE_PREREQ + + $fatpacked{"Module/CPANfile/Prereqs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_PREREQS'; + package Module::CPANfile::Prereqs; + use strict; + use Carp (); + use CPAN::Meta::Feature; + use Module::CPANfile::Prereq; + + sub from_cpan_meta { + my($class, $prereqs) = @_; + + my $self = $class->new; + + for my $phase (keys %$prereqs) { + for my $type (keys %{ $prereqs->{$phase} }) { + while (my($module, $requirement) = each %{ $prereqs->{$phase}{$type} }) { + $self->add_prereq( + phase => $phase, + type => $type, + module => $module, + requirement => Module::CPANfile::Requirement->new(name => $module, version => $requirement), + ); + } + } + } + + $self; + } + + sub new { + my $class = shift; + bless { + prereqs => [], + features => {}, + }, $class; + } + + sub add_feature { + my($self, $identifier, $description) = @_; + $self->{features}{$identifier} = { description => $description }; + } + + sub add_prereq { + my($self, %args) = @_; + $self->add( Module::CPANfile::Prereq->new(%args) ); + } + + sub add { + my($self, $prereq) = @_; + push @{$self->{prereqs}}, $prereq; + } + + sub as_cpan_meta { + my $self = shift; + $self->{cpanmeta} ||= $self->build_cpan_meta; + } + + sub build_cpan_meta { + my($self, $identifier) = @_; + + my $prereq_spec = {}; + $self->prereq_each($identifier, sub { + my $prereq = shift; + $prereq_spec->{$prereq->phase}{$prereq->type}{$prereq->module} = $prereq->requirement->version; + }); + + CPAN::Meta::Prereqs->new($prereq_spec); + } + + sub prereq_each { + my($self, $identifier, $code) = @_; + + for my $prereq (@{$self->{prereqs}}) { + next unless $prereq->match_feature($identifier); + $code->($prereq); + } + } + + sub merged_requirements { + my $self = shift; + + my $reqs = CPAN::Meta::Requirements->new; + for my $prereq (@{$self->{prereqs}}) { + $reqs->add_string_requirement($prereq->module, $prereq->requirement->version); + } + + $reqs; + } + + sub find { + my($self, $module) = @_; + + for my $prereq (@{$self->{prereqs}}) { + return $prereq if $prereq->module eq $module; + } + + return; + } + + sub identifiers { + my $self = shift; + keys %{$self->{features}}; + } + + sub feature { + my($self, $identifier) = @_; + + my $data = $self->{features}{$identifier} + or Carp::croak("Unknown feature '$identifier'"); + + my $prereqs = $self->build_cpan_meta($identifier); + + CPAN::Meta::Feature->new($identifier, { + description => $data->{description}, + prereqs => $prereqs->as_string_hash, + }); + } + + 1; + MODULE_CPANFILE_PREREQS + + $fatpacked{"Module/CPANfile/Requirement.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_REQUIREMENT'; + package Module::CPANfile::Requirement; + use strict; + + sub new { + my ($class, %args) = @_; + + $args{version} ||= 0; + + bless +{ + name => delete $args{name}, + version => delete $args{version}, + options => \%args, + }, $class; + } + + sub name { $_[0]->{name} } + sub version { $_[0]->{version} } + + sub options { $_[0]->{options} } + + sub has_options { + keys %{$_[0]->{options}} > 0; + } + + 1; + MODULE_CPANFILE_REQUIREMENT + + $fatpacked{"Module/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_METADATA'; + # -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*- + # vim:ts=8:sw=2:et:sta:sts=2 + package Module::Metadata; # git description: v1.000026-12-g9b12bf1 + + # Adapted from Perl-licensed code originally distributed with + # Module-Build by Ken Williams + + # This module provides routines to gather information about + # perl modules (assuming this may be expanded in the distant + # parrot future to look at other types of modules). + + sub __clean_eval { eval $_[0] } + use strict; + use warnings; + + our $VERSION = '1.000027'; + + use Carp qw/croak/; + use File::Spec; + BEGIN { + # Try really hard to not depend ony any DynaLoaded module, such as IO::File or Fcntl + eval { + require Fcntl; Fcntl->import('SEEK_SET'); 1; + } or *SEEK_SET = sub { 0 } + } + use version 0.87; + BEGIN { + if ($INC{'Log/Contextual.pm'}) { + require "Log/Contextual/WarnLogger.pm"; # Hide from AutoPrereqs + Log::Contextual->import('log_info', + '-default_logger' => Log::Contextual::WarnLogger->new({ env_prefix => 'MODULE_METADATA', }), + ); + } else { + *log_info = sub (&) { warn $_[0]->() }; + } + } + use File::Find qw(find); + + my $V_NUM_REGEXP = qr{v?[0-9._]+}; # crudely, a v-string or decimal + + my $PKG_FIRST_WORD_REGEXP = qr{ # the FIRST word in a package name + [a-zA-Z_] # the first word CANNOT start with a digit + (?: + [\w']? # can contain letters, digits, _, or ticks + \w # But, NO multi-ticks or trailing ticks + )* + }x; + + my $PKG_ADDL_WORD_REGEXP = qr{ # the 2nd+ word in a package name + \w # the 2nd+ word CAN start with digits + (?: + [\w']? # and can contain letters or ticks + \w # But, NO multi-ticks or trailing ticks + )* + }x; + + my $PKG_NAME_REGEXP = qr{ # match a package name + (?: :: )? # a pkg name can start with arisdottle + $PKG_FIRST_WORD_REGEXP # a package word + (?: + (?: :: )+ ### arisdottle (allow one or many times) + $PKG_ADDL_WORD_REGEXP ### a package word + )* # ^ zero, one or many times + (?: + :: # allow trailing arisdottle + )? + }x; + + my $PKG_REGEXP = qr{ # match a package declaration + ^[\s\{;]* # intro chars on a line + package # the word 'package' + \s+ # whitespace + ($PKG_NAME_REGEXP) # a package name + \s* # optional whitespace + ($V_NUM_REGEXP)? # optional version number + \s* # optional whitesapce + [;\{] # semicolon line terminator or block start (since 5.16) + }x; + + my $VARNAME_REGEXP = qr{ # match fully-qualified VERSION name + ([\$*]) # sigil - $ or * + ( + ( # optional leading package name + (?:::|\')? # possibly starting like just :: (a la $::VERSION) + (?:\w+(?:::|\'))* # Foo::Bar:: ... + )? + VERSION + )\b + }x; + + my $VERS_REGEXP = qr{ # match a VERSION definition + (?: + \(\s*$VARNAME_REGEXP\s*\) # with parens + | + $VARNAME_REGEXP # without parens + ) + \s* + =[^=~>] # = but not ==, nor =~, nor => + }x; + + sub new_from_file { + my $class = shift; + my $filename = File::Spec->rel2abs( shift ); + + return undef unless defined( $filename ) && -f $filename; + return $class->_init(undef, $filename, @_); + } + + sub new_from_handle { + my $class = shift; + my $handle = shift; + my $filename = shift; + return undef unless defined($handle) && defined($filename); + $filename = File::Spec->rel2abs( $filename ); + + return $class->_init(undef, $filename, @_, handle => $handle); + + } + + + sub new_from_module { + my $class = shift; + my $module = shift; + my %props = @_; + + $props{inc} ||= \@INC; + my $filename = $class->find_module_by_name( $module, $props{inc} ); + return undef unless defined( $filename ) && -f $filename; + return $class->_init($module, $filename, %props); + } + + { + + my $compare_versions = sub { + my ($v1, $op, $v2) = @_; + $v1 = version->new($v1) + unless UNIVERSAL::isa($v1,'version'); + + my $eval_str = "\$v1 $op \$v2"; + my $result = eval $eval_str; + log_info { "error comparing versions: '$eval_str' $@" } if $@; + + return $result; + }; + + my $normalize_version = sub { + my ($version) = @_; + if ( $version =~ /[=<>!,]/ ) { # logic, not just version + # take as is without modification + } + elsif ( ref $version eq 'version' ) { # version objects + $version = $version->is_qv ? $version->normal : $version->stringify; + } + elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots + # normalize string tuples without "v": "1.2.3" -> "v1.2.3" + $version = "v$version"; + } + else { + # leave alone + } + return $version; + }; + + # separate out some of the conflict resolution logic + + my $resolve_module_versions = sub { + my $packages = shift; + + my( $file, $version ); + my $err = ''; + foreach my $p ( @$packages ) { + if ( defined( $p->{version} ) ) { + if ( defined( $version ) ) { + if ( $compare_versions->( $version, '!=', $p->{version} ) ) { + $err .= " $p->{file} ($p->{version})\n"; + } else { + # same version declared multiple times, ignore + } + } else { + $file = $p->{file}; + $version = $p->{version}; + } + } + $file ||= $p->{file} if defined( $p->{file} ); + } + + if ( $err ) { + $err = " $file ($version)\n" . $err; + } + + my %result = ( + file => $file, + version => $version, + err => $err + ); + + return \%result; + }; + + sub provides { + my $class = shift; + + croak "provides() requires key/value pairs \n" if @_ % 2; + my %args = @_; + + croak "provides() takes only one of 'dir' or 'files'\n" + if $args{dir} && $args{files}; + + croak "provides() requires a 'version' argument" + unless defined $args{version}; + + croak "provides() does not support version '$args{version}' metadata" + unless grep { $args{version} eq $_ } qw/1.4 2/; + + $args{prefix} = 'lib' unless defined $args{prefix}; + + my $p; + if ( $args{dir} ) { + $p = $class->package_versions_from_directory($args{dir}); + } + else { + croak "provides() requires 'files' to be an array reference\n" + unless ref $args{files} eq 'ARRAY'; + $p = $class->package_versions_from_directory($args{files}); + } + + # Now, fix up files with prefix + if ( length $args{prefix} ) { # check in case disabled with q{} + $args{prefix} =~ s{/$}{}; + for my $v ( values %$p ) { + $v->{file} = "$args{prefix}/$v->{file}"; + } + } + + return $p + } + + sub package_versions_from_directory { + my ( $class, $dir, $files ) = @_; + + my @files; + + if ( $files ) { + @files = @$files; + } else { + find( { + wanted => sub { + push @files, $_ if -f $_ && /\.pm$/; + }, + no_chdir => 1, + }, $dir ); + } + + # First, we enumerate all packages & versions, + # separating into primary & alternative candidates + my( %prime, %alt ); + foreach my $file (@files) { + my $mapped_filename = File::Spec::Unix->abs2rel( $file, $dir ); + my @path = split( /\//, $mapped_filename ); + (my $prime_package = join( '::', @path )) =~ s/\.pm$//; + + my $pm_info = $class->new_from_file( $file ); + + foreach my $package ( $pm_info->packages_inside ) { + next if $package eq 'main'; # main can appear numerous times, ignore + next if $package eq 'DB'; # special debugging package, ignore + next if grep /^_/, split( /::/, $package ); # private package, ignore + + my $version = $pm_info->version( $package ); + + $prime_package = $package if lc($prime_package) eq lc($package); + if ( $package eq $prime_package ) { + if ( exists( $prime{$package} ) ) { + croak "Unexpected conflict in '$package'; multiple versions found.\n"; + } else { + $mapped_filename = "$package.pm" if lc("$package.pm") eq lc($mapped_filename); + $prime{$package}{file} = $mapped_filename; + $prime{$package}{version} = $version if defined( $version ); + } + } else { + push( @{$alt{$package}}, { + file => $mapped_filename, + version => $version, + } ); + } + } + } + + # Then we iterate over all the packages found above, identifying conflicts + # and selecting the "best" candidate for recording the file & version + # for each package. + foreach my $package ( keys( %alt ) ) { + my $result = $resolve_module_versions->( $alt{$package} ); + + if ( exists( $prime{$package} ) ) { # primary package selected + + if ( $result->{err} ) { + # Use the selected primary package, but there are conflicting + # errors among multiple alternative packages that need to be + # reported + log_info { + "Found conflicting versions for package '$package'\n" . + " $prime{$package}{file} ($prime{$package}{version})\n" . + $result->{err} + }; + + } elsif ( defined( $result->{version} ) ) { + # There is a primary package selected, and exactly one + # alternative package + + if ( exists( $prime{$package}{version} ) && + defined( $prime{$package}{version} ) ) { + # Unless the version of the primary package agrees with the + # version of the alternative package, report a conflict + if ( $compare_versions->( + $prime{$package}{version}, '!=', $result->{version} + ) + ) { + + log_info { + "Found conflicting versions for package '$package'\n" . + " $prime{$package}{file} ($prime{$package}{version})\n" . + " $result->{file} ($result->{version})\n" + }; + } + + } else { + # The prime package selected has no version so, we choose to + # use any alternative package that does have a version + $prime{$package}{file} = $result->{file}; + $prime{$package}{version} = $result->{version}; + } + + } else { + # no alt package found with a version, but we have a prime + # package so we use it whether it has a version or not + } + + } else { # No primary package was selected, use the best alternative + + if ( $result->{err} ) { + log_info { + "Found conflicting versions for package '$package'\n" . + $result->{err} + }; + } + + # Despite possible conflicting versions, we choose to record + # something rather than nothing + $prime{$package}{file} = $result->{file}; + $prime{$package}{version} = $result->{version} + if defined( $result->{version} ); + } + } + + # Normalize versions. Can't use exists() here because of bug in YAML::Node. + # XXX "bug in YAML::Node" comment seems irrelevant -- dagolden, 2009-05-18 + for (grep defined $_->{version}, values %prime) { + $_->{version} = $normalize_version->( $_->{version} ); + } + + return \%prime; + } + } + + + sub _init { + my $class = shift; + my $module = shift; + my $filename = shift; + my %props = @_; + + my $handle = delete $props{handle}; + my( %valid_props, @valid_props ); + @valid_props = qw( collect_pod inc ); + @valid_props{@valid_props} = delete( @props{@valid_props} ); + warn "Unknown properties: @{[keys %props]}\n" if scalar( %props ); + + my %data = ( + module => $module, + filename => $filename, + version => undef, + packages => [], + versions => {}, + pod => {}, + pod_headings => [], + collect_pod => 0, + + %valid_props, + ); + + my $self = bless(\%data, $class); + + if ( not $handle ) { + my $filename = $self->{filename}; + open $handle, '<', $filename + or croak( "Can't open '$filename': $!" ); + + $self->_handle_bom($handle, $filename); + } + $self->_parse_fh($handle); + + unless($self->{module} and length($self->{module})) { + my ($v, $d, $f) = File::Spec->splitpath($self->{filename}); + if($f =~ /\.pm$/) { + $f =~ s/\..+$//; + my @candidates = grep /$f$/, @{$self->{packages}}; + $self->{module} = shift(@candidates); # punt + } + else { + if(grep /main/, @{$self->{packages}}) { + $self->{module} = 'main'; + } + else { + $self->{module} = $self->{packages}[0] || ''; + } + } + } + + $self->{version} = $self->{versions}{$self->{module}} + if defined( $self->{module} ); + + return $self; + } + + # class method + sub _do_find_module { + my $class = shift; + my $module = shift || croak 'find_module_by_name() requires a package name'; + my $dirs = shift || \@INC; + + my $file = File::Spec->catfile(split( /::/, $module)); + foreach my $dir ( @$dirs ) { + my $testfile = File::Spec->catfile($dir, $file); + return [ File::Spec->rel2abs( $testfile ), $dir ] + if -e $testfile and !-d _; # For stuff like ExtUtils::xsubpp + $testfile .= '.pm'; + return [ File::Spec->rel2abs( $testfile ), $dir ] + if -e $testfile; + } + return; + } + + # class method + sub find_module_by_name { + my $found = shift()->_do_find_module(@_) or return; + return $found->[0]; + } + + # class method + sub find_module_dir_by_name { + my $found = shift()->_do_find_module(@_) or return; + return $found->[1]; + } + + + # given a line of perl code, attempt to parse it if it looks like a + # $VERSION assignment, returning sigil, full name, & package name + sub _parse_version_expression { + my $self = shift; + my $line = shift; + + my( $sigil, $variable_name, $package); + if ( $line =~ /$VERS_REGEXP/o ) { + ( $sigil, $variable_name, $package) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 ); + if ( $package ) { + $package = ($package eq '::') ? 'main' : $package; + $package =~ s/::$//; + } + } + + return ( $sigil, $variable_name, $package ); + } + + # Look for a UTF-8/UTF-16BE/UTF-16LE BOM at the beginning of the stream. + # If there's one, then skip it and set the :encoding layer appropriately. + sub _handle_bom { + my ($self, $fh, $filename) = @_; + + my $pos = tell $fh; + return unless defined $pos; + + my $buf = ' ' x 2; + my $count = read $fh, $buf, length $buf; + return unless defined $count and $count >= 2; + + my $encoding; + if ( $buf eq "\x{FE}\x{FF}" ) { + $encoding = 'UTF-16BE'; + } elsif ( $buf eq "\x{FF}\x{FE}" ) { + $encoding = 'UTF-16LE'; + } elsif ( $buf eq "\x{EF}\x{BB}" ) { + $buf = ' '; + $count = read $fh, $buf, length $buf; + if ( defined $count and $count >= 1 and $buf eq "\x{BF}" ) { + $encoding = 'UTF-8'; + } + } + + if ( defined $encoding ) { + if ( "$]" >= 5.008 ) { + binmode( $fh, ":encoding($encoding)" ); + } + } else { + seek $fh, $pos, SEEK_SET + or croak( sprintf "Can't reset position to the top of '$filename'" ); + } + + return $encoding; + } + + sub _parse_fh { + my ($self, $fh) = @_; + + my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 ); + my( @packages, %vers, %pod, @pod ); + my $package = 'main'; + my $pod_sect = ''; + my $pod_data = ''; + my $in_end = 0; + + while (defined( my $line = <$fh> )) { + my $line_num = $.; + + chomp( $line ); + + # From toke.c : any line that begins by "=X", where X is an alphabetic + # character, introduces a POD segment. + my $is_cut; + if ( $line =~ /^=([a-zA-Z].*)/ ) { + my $cmd = $1; + # Then it goes back to Perl code for "=cutX" where X is a non-alphabetic + # character (which includes the newline, but here we chomped it away). + $is_cut = $cmd =~ /^cut(?:[^a-zA-Z]|$)/; + $in_pod = !$is_cut; + } + + if ( $in_pod ) { + + if ( $line =~ /^=head[1-4]\s+(.+)\s*$/ ) { + push( @pod, $1 ); + if ( $self->{collect_pod} && length( $pod_data ) ) { + $pod{$pod_sect} = $pod_data; + $pod_data = ''; + } + $pod_sect = $1; + + } elsif ( $self->{collect_pod} ) { + $pod_data .= "$line\n"; + + } + + } elsif ( $is_cut ) { + + if ( $self->{collect_pod} && length( $pod_data ) ) { + $pod{$pod_sect} = $pod_data; + $pod_data = ''; + } + $pod_sect = ''; + + } else { + + # Skip after __END__ + next if $in_end; + + # Skip comments in code + next if $line =~ /^\s*#/; + + # Would be nice if we could also check $in_string or something too + if ($line eq '__END__') { + $in_end++; + next; + } + last if $line eq '__DATA__'; + + # parse $line to see if it's a $VERSION declaration + my( $version_sigil, $version_fullname, $version_package ) = + index($line, 'VERSION') >= 1 + ? $self->_parse_version_expression( $line ) + : (); + + if ( $line =~ /$PKG_REGEXP/o ) { + $package = $1; + my $version = $2; + push( @packages, $package ) unless grep( $package eq $_, @packages ); + $need_vers = defined $version ? 0 : 1; + + if ( not exists $vers{$package} and defined $version ){ + # Upgrade to a version object. + my $dwim_version = eval { _dwim_version($version) }; + croak "Version '$version' from $self->{filename} does not appear to be valid:\n$line\n\nThe fatal error was: $@\n" + unless defined $dwim_version; # "0" is OK! + $vers{$package} = $dwim_version; + } + + # VERSION defined with full package spec, i.e. $Module::VERSION + } elsif ( $version_fullname && $version_package ) { + push( @packages, $version_package ) unless grep( $version_package eq $_, @packages ); + $need_vers = 0 if $version_package eq $package; + + unless ( defined $vers{$version_package} && length $vers{$version_package} ) { + $vers{$version_package} = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line ); + } + + # first non-comment line in undeclared package main is VERSION + } elsif ( $package eq 'main' && $version_fullname && !exists($vers{main}) ) { + $need_vers = 0; + my $v = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line ); + $vers{$package} = $v; + push( @packages, 'main' ); + + # first non-comment line in undeclared package defines package main + } elsif ( $package eq 'main' && !exists($vers{main}) && $line =~ /\w/ ) { + $need_vers = 1; + $vers{main} = ''; + push( @packages, 'main' ); + + # only keep if this is the first $VERSION seen + } elsif ( $version_fullname && $need_vers ) { + $need_vers = 0; + my $v = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line ); + + unless ( defined $vers{$package} && length $vers{$package} ) { + $vers{$package} = $v; + } + } + } + } + + if ( $self->{collect_pod} && length($pod_data) ) { + $pod{$pod_sect} = $pod_data; + } + + $self->{versions} = \%vers; + $self->{packages} = \@packages; + $self->{pod} = \%pod; + $self->{pod_headings} = \@pod; + } + + { + my $pn = 0; + sub _evaluate_version_line { + my $self = shift; + my( $sigil, $variable_name, $line ) = @_; + + # We compile into a local sub because 'use version' would cause + # compiletime/runtime issues with local() + $pn++; # everybody gets their own package + my $eval = qq{ my \$dummy = q# Hide from _packages_inside() + #; package Module::Metadata::_version::p${pn}; + use version; + sub { + local $sigil$variable_name; + $line; + \$$variable_name + }; + }; + + $eval = $1 if $eval =~ m{^(.+)}s; + + local $^W; + # Try to get the $VERSION + my $vsub = __clean_eval($eval); + # some modules say $VERSION $Foo::Bar::VERSION, but Foo::Bar isn't + # installed, so we need to hunt in ./lib for it + if ( $@ =~ /Can't locate/ && -d 'lib' ) { + local @INC = ('lib',@INC); + $vsub = __clean_eval($eval); + } + warn "Error evaling version line '$eval' in $self->{filename}: $@\n" + if $@; + + (ref($vsub) eq 'CODE') or + croak "failed to build version sub for $self->{filename}"; + + my $result = eval { $vsub->() }; + # FIXME: $eval is not the right thing to print here + croak "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n" + if $@; + + # Upgrade it into a version object + my $version = eval { _dwim_version($result) }; + + # FIXME: $eval is not the right thing to print here + croak "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n" + unless defined $version; # "0" is OK! + + return $version; + } + } + + # Try to DWIM when things fail the lax version test in obvious ways + { + my @version_prep = ( + # Best case, it just works + sub { return shift }, + + # If we still don't have a version, try stripping any + # trailing junk that is prohibited by lax rules + sub { + my $v = shift; + $v =~ s{([0-9])[a-z-].*$}{$1}i; # 1.23-alpha or 1.23b + return $v; + }, + + # Activestate apparently creates custom versions like '1.23_45_01', which + # cause version.pm to think it's an invalid alpha. So check for that + # and strip them + sub { + my $v = shift; + my $num_dots = () = $v =~ m{(\.)}g; + my $num_unders = () = $v =~ m{(_)}g; + my $leading_v = substr($v,0,1) eq 'v'; + if ( ! $leading_v && $num_dots < 2 && $num_unders > 1 ) { + $v =~ s{_}{}g; + $num_unders = () = $v =~ m{(_)}g; + } + return $v; + }, + + # Worst case, try numifying it like we would have before version objects + sub { + my $v = shift; + no warnings 'numeric'; + return 0 + $v; + }, + + ); + + sub _dwim_version { + my ($result) = shift; + + return $result if ref($result) eq 'version'; + + my ($version, $error); + for my $f (@version_prep) { + $result = $f->($result); + $version = eval { version->new($result) }; + $error ||= $@ if $@; # capture first failure + last if defined $version; + } + + croak $error unless defined $version; + + return $version; + } + } + + ############################################################ + + # accessors + sub name { $_[0]->{module} } + + sub filename { $_[0]->{filename} } + sub packages_inside { @{$_[0]->{packages}} } + sub pod_inside { @{$_[0]->{pod_headings}} } + sub contains_pod { 0+@{$_[0]->{pod_headings}} } + + sub version { + my $self = shift; + my $mod = shift || $self->{module}; + my $vers; + if ( defined( $mod ) && length( $mod ) && + exists( $self->{versions}{$mod} ) ) { + return $self->{versions}{$mod}; + } else { + return undef; + } + } + + sub pod { + my $self = shift; + my $sect = shift; + if ( defined( $sect ) && length( $sect ) && + exists( $self->{pod}{$sect} ) ) { + return $self->{pod}{$sect}; + } else { + return undef; + } + } + + sub is_indexable { + my ($self, $package) = @_; + + my @indexable_packages = grep { $_ ne 'main' } $self->packages_inside; + + # check for specific package, if provided + return !! grep { $_ eq $package } @indexable_packages if $package; + + # otherwise, check for any indexable packages at all + return !! @indexable_packages; + } + + 1; + + =head1 NAME + + Module::Metadata - Gather package and POD information from perl module files + + =head1 SYNOPSIS + + use Module::Metadata; + + # information about a .pm file + my $info = Module::Metadata->new_from_file( $file ); + my $version = $info->version; + + # CPAN META 'provides' field for .pm files in a directory + my $provides = Module::Metadata->provides( + dir => 'lib', version => 2 + ); + + =head1 DESCRIPTION + + This module provides a standard way to gather metadata about a .pm file through + (mostly) static analysis and (some) code execution. When determining the + version of a module, the C<$VERSION> assignment is Ced, as is traditional + in the CPAN toolchain. + + =head1 CLASS METHODS + + =head2 C<< new_from_file($filename, collect_pod => 1) >> + + Constructs a C object given the path to a file. Returns + undef if the filename does not exist. + + C is a optional boolean argument that determines whether POD + data is collected and stored for reference. POD data is not collected by + default. POD headings are always collected. + + If the file begins by an UTF-8, UTF-16BE or UTF-16LE byte-order mark, then + it is skipped before processing, and the content of the file is also decoded + appropriately starting from perl 5.8. + + =head2 C<< new_from_handle($handle, $filename, collect_pod => 1) >> + + This works just like C, except that a handle can be provided + as the first argument. + + Note that there is no validation to confirm that the handle is a handle or + something that can act like one. Passing something that isn't a handle will + cause a exception when trying to read from it. The C argument is + mandatory or undef will be returned. + + You are responsible for setting the decoding layers on C<$handle> if + required. + + =head2 C<< new_from_module($module, collect_pod => 1, inc => \@dirs) >> + + Constructs a C object given a module or package name. + Returns undef if the module cannot be found. + + In addition to accepting the C argument as described above, + this method accepts a C argument which is a reference to an array of + directories to search for the module. If none are given, the default is + @INC. + + If the file that contains the module begins by an UTF-8, UTF-16BE or + UTF-16LE byte-order mark, then it is skipped before processing, and the + content of the file is also decoded appropriately starting from perl 5.8. + + =head2 C<< find_module_by_name($module, \@dirs) >> + + Returns the path to a module given the module or package name. A list + of directories can be passed in as an optional parameter, otherwise + @INC is searched. + + Can be called as either an object or a class method. + + =head2 C<< find_module_dir_by_name($module, \@dirs) >> + + Returns the entry in C<@dirs> (or C<@INC> by default) that contains + the module C<$module>. A list of directories can be passed in as an + optional parameter, otherwise @INC is searched. + + Can be called as either an object or a class method. + + =head2 C<< provides( %options ) >> + + This is a convenience wrapper around C + to generate a CPAN META C data structure. It takes key/value + pairs. Valid option keys include: + + =over + + =item version B<(required)> + + Specifies which version of the L should be used as + the format of the C output. Currently only '1.4' and '2' + are supported (and their format is identical). This may change in + the future as the definition of C changes. + + The C option is required. If it is omitted or if + an unsupported version is given, then C will throw an error. + + =item dir + + Directory to search recursively for F<.pm> files. May not be specified with + C. + + =item files + + Array reference of files to examine. May not be specified with C. + + =item prefix + + String to prepend to the C field of the resulting output. This defaults + to F, which is the common case for most CPAN distributions with their + F<.pm> files in F. This option ensures the META information has the + correct relative path even when the C or C arguments are + absolute or have relative paths from a location other than the distribution + root. + + =back + + For example, given C of 'lib' and C of 'lib', the return value + is a hashref of the form: + + { + 'Package::Name' => { + version => '0.123', + file => 'lib/Package/Name.pm' + }, + 'OtherPackage::Name' => ... + } + + =head2 C<< package_versions_from_directory($dir, \@files?) >> + + Scans C<$dir> for .pm files (unless C<@files> is given, in which case looks + for those files in C<$dir> - and reads each file for packages and versions, + returning a hashref of the form: + + { + 'Package::Name' => { + version => '0.123', + file => 'Package/Name.pm' + }, + 'OtherPackage::Name' => ... + } + + The C and C
packages are always omitted, as are any "private" + packages that have leading underscores in the namespace (e.g. + C) + + Note that the file path is relative to C<$dir> if that is specified. + This B be used directly for CPAN META C. See + the C method instead. + + =head2 C<< log_info (internal) >> + + Used internally to perform logging; imported from Log::Contextual if + Log::Contextual has already been loaded, otherwise simply calls warn. + + =head1 OBJECT METHODS + + =head2 C<< name() >> + + Returns the name of the package represented by this module. If there + is more than one package, it makes a best guess based on the + filename. If it's a script (i.e. not a *.pm) the package name is + 'main'. + + =head2 C<< version($package) >> + + Returns the version as defined by the $VERSION variable for the + package as returned by the C method if no arguments are + given. If given the name of a package it will attempt to return the + version of that package if it is specified in the file. + + =head2 C<< filename() >> + + Returns the absolute path to the file. + Note that this file may not actually exist on disk yet, e.g. if the module was read from an in-memory filehandle. + + =head2 C<< packages_inside() >> + + Returns a list of packages. Note: this is a raw list of packages + discovered (or assumed, in the case of C
). It is not + filtered for C, C
or private packages the way the + C method does. Invalid package names are not returned, + for example "Foo:Bar". Strange but valid package names are + returned, for example "Foo::Bar::", and are left up to the caller + on how to handle. + + =head2 C<< pod_inside() >> + + Returns a list of POD sections. + + =head2 C<< contains_pod() >> + + Returns true if there is any POD in the file. + + =head2 C<< pod($section) >> + + Returns the POD data in the given section. + + =head2 C<< is_indexable($package) >> or C<< is_indexable() >> + + Returns a boolean indicating whether the package (if provided) or any package + (otherwise) is eligible for indexing by PAUSE, the Perl Authors Upload Server. + Note This only checks for valid C declarations, and does not take any + ownership information into account. + + =head1 AUTHOR + + Original code from Module::Build::ModuleInfo by Ken Williams + , Randy W. Sims + + Released as Module::Metadata by Matt S Trout (mst) with + assistance from David Golden (xdg) . + + =head1 COPYRIGHT & LICENSE + + Original code Copyright (c) 2001-2011 Ken Williams. + Additional code Copyright (c) 2010-2011 Matt Trout and David Golden. + All rights reserved. + + This library is free software; you can redistribute it and/or + modify it under the same terms as Perl itself. + + =cut + MODULE_METADATA + + $fatpacked{"Parse/CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PARSE_CPAN_META'; + use 5.008001; + use strict; + package Parse::CPAN::Meta; + # ABSTRACT: Parse META.yml and META.json CPAN metadata files + our $VERSION = '1.4414'; # VERSION + + use Exporter; + use Carp 'croak'; + + our @ISA = qw/Exporter/; + our @EXPORT_OK = qw/Load LoadFile/; + + sub load_file { + my ($class, $filename) = @_; + + my $meta = _slurp($filename); + + if ($filename =~ /\.ya?ml$/) { + return $class->load_yaml_string($meta); + } + elsif ($filename =~ /\.json$/) { + return $class->load_json_string($meta); + } + else { + $class->load_string($meta); # try to detect yaml/json + } + } + + sub load_string { + my ($class, $string) = @_; + if ( $string =~ /^---/ ) { # looks like YAML + return $class->load_yaml_string($string); + } + elsif ( $string =~ /^\s*\{/ ) { # looks like JSON + return $class->load_json_string($string); + } + else { # maybe doc-marker-free YAML + return $class->load_yaml_string($string); + } + } + + sub load_yaml_string { + my ($class, $string) = @_; + my $backend = $class->yaml_backend(); + my $data = eval { no strict 'refs'; &{"$backend\::Load"}($string) }; + croak $@ if $@; + return $data || {}; # in case document was valid but empty + } + + sub load_json_string { + my ($class, $string) = @_; + my $data = eval { $class->json_backend()->new->decode($string) }; + croak $@ if $@; + return $data || {}; + } + + sub yaml_backend { + if (! defined $ENV{PERL_YAML_BACKEND} ) { + _can_load( 'CPAN::Meta::YAML', 0.011 ) + or croak "CPAN::Meta::YAML 0.011 is not available\n"; + return "CPAN::Meta::YAML"; + } + else { + my $backend = $ENV{PERL_YAML_BACKEND}; + _can_load( $backend ) + or croak "Could not load PERL_YAML_BACKEND '$backend'\n"; + $backend->can("Load") + or croak "PERL_YAML_BACKEND '$backend' does not implement Load()\n"; + return $backend; + } + } + + sub json_backend { + if (! $ENV{PERL_JSON_BACKEND} or $ENV{PERL_JSON_BACKEND} eq 'JSON::PP') { + _can_load( 'JSON::PP' => 2.27103 ) + or croak "JSON::PP 2.27103 is not available\n"; + return 'JSON::PP'; + } + else { + _can_load( 'JSON' => 2.5 ) + or croak "JSON 2.5 is required for " . + "\$ENV{PERL_JSON_BACKEND} = '$ENV{PERL_JSON_BACKEND}'\n"; + return "JSON"; + } + } + + sub _slurp { + require Encode; + open my $fh, "<:raw", "$_[0]" ## no critic + or die "can't open $_[0] for reading: $!"; + my $content = do { local $/; <$fh> }; + $content = Encode::decode('UTF-8', $content, Encode::PERLQQ()); + return $content; + } + + sub _can_load { + my ($module, $version) = @_; + (my $file = $module) =~ s{::}{/}g; + $file .= ".pm"; + return 1 if $INC{$file}; + return 0 if exists $INC{$file}; # prior load failed + eval { require $file; 1 } + or return 0; + if ( defined $version ) { + eval { $module->VERSION($version); 1 } + or return 0; + } + return 1; + } + + # Kept for backwards compatibility only + # Create an object from a file + sub LoadFile ($) { + return Load(_slurp(shift)); + } + + # Parse a document from a string. + sub Load ($) { + require CPAN::Meta::YAML; + my $object = eval { CPAN::Meta::YAML::Load(shift) }; + croak $@ if $@; + return $object; + } + + 1; + + __END__ + + =pod + + =encoding UTF-8 + + =head1 NAME + + Parse::CPAN::Meta - Parse META.yml and META.json CPAN metadata files + + =head1 VERSION + + version 1.4414 + + =head1 SYNOPSIS + + ############################################# + # In your file + + --- + name: My-Distribution + version: 1.23 + resources: + homepage: "http://example.com/dist/My-Distribution" + + + ############################################# + # In your program + + use Parse::CPAN::Meta; + + my $distmeta = Parse::CPAN::Meta->load_file('META.yml'); + + # Reading properties + my $name = $distmeta->{name}; + my $version = $distmeta->{version}; + my $homepage = $distmeta->{resources}{homepage}; + + =head1 DESCRIPTION + + B is a parser for F and F files, using + L and/or L. + + B provides three methods: C, C, + and C. These will read and deserialize CPAN metafiles, and + are described below in detail. + + B provides a legacy API of only two functions, + based on the YAML functions of the same name. Wherever possible, + identical calling semantics are used. These may only be used with YAML sources. + + All error reporting is done with exceptions (die'ing). + + Note that META files are expected to be in UTF-8 encoding, only. When + converted string data, it must first be decoded from UTF-8. + + =begin Pod::Coverage + + + + + =end Pod::Coverage + + =head1 METHODS + + =head2 load_file + + my $metadata_structure = Parse::CPAN::Meta->load_file('META.json'); + + my $metadata_structure = Parse::CPAN::Meta->load_file('META.yml'); + + This method will read the named file and deserialize it to a data structure, + determining whether it should be JSON or YAML based on the filename. + The file will be read using the ":utf8" IO layer. + + =head2 load_yaml_string + + my $metadata_structure = Parse::CPAN::Meta->load_yaml_string($yaml_string); + + This method deserializes the given string of YAML and returns the first + document in it. (CPAN metadata files should always have only one document.) + If the source was UTF-8 encoded, the string must be decoded before calling + C. + + =head2 load_json_string + + my $metadata_structure = Parse::CPAN::Meta->load_json_string($json_string); + + This method deserializes the given string of JSON and the result. + If the source was UTF-8 encoded, the string must be decoded before calling + C. + + =head2 load_string + + my $metadata_structure = Parse::CPAN::Meta->load_string($some_string); + + If you don't know whether a string contains YAML or JSON data, this method + will use some heuristics and guess. If it can't tell, it assumes YAML. + + =head2 yaml_backend + + my $backend = Parse::CPAN::Meta->yaml_backend; + + Returns the module name of the YAML serializer. See L + for details. + + =head2 json_backend + + my $backend = Parse::CPAN::Meta->json_backend; + + Returns the module name of the JSON serializer. This will either + be L or L. Even if C is set, + this will return L as further delegation is handled by + the L module. See L for details. + + =head1 FUNCTIONS + + For maintenance clarity, no functions are exported by default. These functions + are available for backwards compatibility only and are best avoided in favor of + C. + + =head2 Load + + my @yaml = Parse::CPAN::Meta::Load( $string ); + + Parses a string containing a valid YAML stream into a list of Perl data + structures. + + =head2 LoadFile + + my @yaml = Parse::CPAN::Meta::LoadFile( 'META.yml' ); + + Reads the YAML stream from a file instead of a string. + + =head1 ENVIRONMENT + + =head2 PERL_JSON_BACKEND + + By default, L will be used for deserializing JSON data. If the + C environment variable exists, is true and is not + "JSON::PP", then the L module (version 2.5 or greater) will be loaded and + used to interpret C. If L is not installed or is too + old, an exception will be thrown. + + =head2 PERL_YAML_BACKEND + + By default, L will be used for deserializing YAML data. If + the C environment variable is defined, then it is interpreted + as a module to use for deserialization. The given module must be installed, + must load correctly and must implement the C function or an exception + will be thrown. + + =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan + + =head1 SUPPORT + + =head2 Bugs / Feature Requests + + Please report any bugs or feature requests through the issue tracker + at L. + You will be notified automatically of any progress on your issue. + + =head2 Source Code + + This is open source software. The code repository is available for + public review and contribution under the terms of the license. + + L + + git clone https://github.com/Perl-Toolchain-Gang/Parse-CPAN-Meta.git + + =head1 AUTHORS + + =over 4 + + =item * + + Adam Kennedy + + =item * + + David Golden + + =back + + =head1 CONTRIBUTORS + + =over 4 + + =item * + + Graham Knop + + =item * + + Joshua ben Jore + + =item * + + Neil Bowers + + =item * + + Ricardo Signes + + =item * + + Steffen Mueller + + =back + + =head1 COPYRIGHT AND LICENSE + + This software is copyright (c) 2014 by Adam Kennedy and Contributors. + + This is free software; you can redistribute it and/or modify it under + the same terms as the Perl 5 programming language system itself. + + =cut + PARSE_CPAN_META + + $fatpacked{"Parse/PMFile.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PARSE_PMFILE'; + package Parse::PMFile; + + sub __clean_eval { eval $_[0] } # needs to be here (RT#101273) + + use strict; + use warnings; + use Safe; + use JSON::PP (); + use Dumpvalue; + use version (); + use File::Spec (); + + our $VERSION = '0.36'; + our $VERBOSE = 0; + our $ALLOW_DEV_VERSION = 0; + our $FORK = 0; + our $UNSAFE = $] < 5.010000 ? 1 : 0; + + sub new { + my ($class, $meta, $opts) = @_; + bless {%{ $opts || {} }, META_CONTENT => $meta}, $class; + } + + # from PAUSE::pmfile::examine_fio + sub parse { + my ($self, $pmfile) = @_; + + $pmfile =~ s|\\|/|g; + + my($filemtime) = (stat $pmfile)[9]; + $self->{MTIME} = $filemtime; + $self->{PMFILE} = $pmfile; + + unless ($self->_version_from_meta_ok) { + my $version; + unless (eval { $version = $self->_parse_version; 1 }) { + $self->_verbose(1, "error with version in $pmfile: $@"); + return; + } + + $self->{VERSION} = $version; + if ($self->{VERSION} =~ /^\{.*\}$/) { + # JSON error message + } elsif ($self->{VERSION} =~ /[_\s]/ && !$self->{ALLOW_DEV_VERSION} && !$ALLOW_DEV_VERSION){ # ignore developer releases and "You suck!" + return; + } + } + + my($ppp) = $self->_packages_per_pmfile; + my @keys_ppp = $self->_filter_ppps(sort keys %$ppp); + $self->_verbose(1,"Will check keys_ppp[@keys_ppp]\n"); + + # + # Immediately after each package (pmfile) examined contact + # the database + # + + my ($package, %errors); + my %checked_in; + DBPACK: foreach $package (@keys_ppp) { + # this part is taken from PAUSE::package::examine_pkg + # and PAUSE::package::_pkg_name_insane + if ($package !~ /^\w[\w\:\']*\w?\z/ + || $package !~ /\w\z/ + || $package =~ /:/ && $package !~ /::/ + || $package =~ /\w:\w/ + || $package =~ /:::/ + ){ + $self->_verbose(1,"Package[$package] did not pass the ultimate sanity check"); + delete $ppp->{$package}; + next; + } + + if ($self->{USERID} && $self->{PERMISSIONS} && !$self->_perm_check($package)) { + delete $ppp->{$package}; + next; + } + + # Check that package name matches case of file name + { + my (undef, $module) = split m{/lib/}, $self->{PMFILE}, 2; + if ($module) { + $module =~ s{\.pm\z}{}; + $module =~ s{/}{::}g; + + if (lc $module eq lc $package && $module ne $package) { + # warn "/// $self->{PMFILE} vs. $module vs. $package\n"; + $errors{$package} = { + indexing_warning => "Capitalization of package ($package) does not match filename!", + infile => $self->{PMFILE}, + }; + } + } + } + + my $pp = $ppp->{$package}; + if ($pp->{version} && $pp->{version} =~ /^\{.*\}$/) { # JSON parser error + my $err = JSON::PP::decode_json($pp->{version}); + if ($err->{x_normalize}) { + $errors{$package} = { + normalize => $err->{version}, + infile => $pp->{infile}, + }; + $pp->{version} = "undef"; + } elsif ($err->{openerr}) { + $pp->{version} = "undef"; + $self->_verbose(1, + qq{Parse::PMFile was not able to + read the file. It issued the following error: C< $err->{r} >}, + ); + $errors{$package} = { + open => $err->{r}, + infile => $pp->{infile}, + }; + } else { + $pp->{version} = "undef"; + $self->_verbose(1, + qq{Parse::PMFile was not able to + parse the following line in that file: C< $err->{line} > + + Note: the indexer is running in a Safe compartement and cannot + provide the full functionality of perl in the VERSION line. It + is trying hard, but sometime it fails. As a workaround, please + consider writing a META.yml that contains a 'provides' + attribute or contact the CPAN admins to investigate (yet + another) workaround against "Safe" limitations.)}, + + ); + $errors{$package} = { + parse_version => $err->{line}, + infile => $err->{file}, + }; + } + } + + # Sanity checks + + for ( + $package, + $pp->{version}, + ) { + if (!defined || /^\s*$/ || /\s/){ # for whatever reason I come here + delete $ppp->{$package}; + next; # don't screw up 02packages + } + } + $checked_in{$package} = $ppp->{$package}; + } # end foreach package + + return (wantarray && %errors) ? (\%checked_in, \%errors) : \%checked_in; + } + + sub _perm_check { + my ($self, $package) = @_; + my $userid = $self->{USERID}; + my $module = $self->{PERMISSIONS}->module_permissions($package); + return 1 if !$module; # not listed yet + return 1 if defined $module->m && $module->m eq $userid; + return 1 if defined $module->f && $module->f eq $userid; + return 1 if defined $module->c && grep {$_ eq $userid} @{$module->c}; + return; + } + + # from PAUSE::pmfile; + sub _parse_version { + my $self = shift; + + use strict; + + my $pmfile = $self->{PMFILE}; + my $tmpfile = File::Spec->catfile(File::Spec->tmpdir, "ParsePMFile$$" . rand(1000)); + + my $pmcp = $pmfile; + for ($pmcp) { + s/([^\\](\\\\)*)@/$1\\@/g; # thanks to Raphael Manfredi for the + # solution to escape @s and \ + } + my($v); + { + + package main; # seems necessary + + # XXX: do we need to fork as PAUSE does? + # or, is alarm() just fine? + my $pid; + if ($self->{FORK} || $FORK) { + $pid = fork(); + die "Can't fork: $!" unless defined $pid; + } + if ($pid) { + waitpid($pid, 0); + if (open my $fh, '<', $tmpfile) { + $v = <$fh>; + } + } else { + # XXX Limit Resources too + + my($comp) = Safe->new; + my $eval = qq{ + local(\$^W) = 0; + Parse::PMFile::_parse_version_safely("$pmcp"); + }; + $comp->permit("entereval"); # for MBARBON/Module-Info-0.30.tar.gz + $comp->share("*Parse::PMFile::_parse_version_safely"); + $comp->share("*version::new"); + $comp->share("*version::numify"); + $comp->share_from('main', ['*version::', + '*charstar::', + '*Exporter::', + '*DynaLoader::']); + $comp->share_from('version', ['&qv']); + $comp->permit(":base_math"); # atan2 (Acme-Pi) + # $comp->permit("require"); # no strict! + $comp->deny(qw/enteriter iter unstack goto/); # minimum protection against Acme::BadExample + + version->import('qv') if $self->{UNSAFE} || $UNSAFE; + { + no strict; + $v = ($self->{UNSAFE} || $UNSAFE) ? eval $eval : $comp->reval($eval); + } + if ($@){ # still in the child process, out of Safe::reval + my $err = $@; + # warn ">>>>>>>err[$err]<<<<<<<<"; + if (ref $err) { + if ($err->{line} =~ /([\$*])([\w\:\']*)\bVERSION\b.*?\=(.*)/) { + local($^W) = 0; + my ($sigil, $vstr) = ($1, $3); + $self->_restore_overloaded_stuff(1) if $err->{line} =~ /use\s+version\b|version\->|qv\(/; + $v = ($self->{UNSAFE} || $UNSAFE) ? eval $vstr : $comp->reval($vstr); + $v = $$v if $sigil eq '*' && ref $v; + } + if ($@ or !$v) { + $self->_verbose(1, sprintf("reval failed: err[%s] for eval[%s]", + JSON::PP::encode_json($err), + $eval, + )); + $v = JSON::PP::encode_json($err); + } + } else { + $v = JSON::PP::encode_json({ openerr => $err }); + } + } + if (defined $v) { + $v = $v->numify if ref($v) =~ /^version(::vpp)?$/; + } else { + $v = ""; + } + if ($self->{FORK} || $FORK) { + open my $fh, '>:utf8', $tmpfile; + print $fh $v; + exit 0; + } else { + utf8::encode($v); + # undefine empty $v as if read from the tmpfile + $v = undef if defined $v && !length $v; + $comp->erase; + $self->_restore_overloaded_stuff; + } + } + } + unlink $tmpfile if ($self->{FORK} || $FORK) && -e $tmpfile; + + return $self->_normalize_version($v); + } + + sub _restore_overloaded_stuff { + my ($self, $used_version_in_safe) = @_; + return if $self->{UNSAFE} || $UNSAFE; + + no strict 'refs'; + no warnings 'redefine'; + + # version XS in CPAN + my $restored; + if ($INC{'version/vxs.pm'}) { + *{'version::(""'} = \&version::vxs::stringify; + *{'version::(0+'} = \&version::vxs::numify; + *{'version::(cmp'} = \&version::vxs::VCMP; + *{'version::(<=>'} = \&version::vxs::VCMP; + *{'version::(bool'} = \&version::vxs::boolean; + $restored = 1; + } + # version PP in CPAN + if ($INC{'version/vpp.pm'}) { + { + package # hide from PAUSE + charstar; + overload->import; + } + if (!$used_version_in_safe) { + package # hide from PAUSE + version::vpp; + overload->import; + } + unless ($restored) { + *{'version::(""'} = \&version::vpp::stringify; + *{'version::(0+'} = \&version::vpp::numify; + *{'version::(cmp'} = \&version::vpp::vcmp; + *{'version::(<=>'} = \&version::vpp::vcmp; + *{'version::(bool'} = \&version::vpp::vbool; + } + *{'version::vpp::(""'} = \&version::vpp::stringify; + *{'version::vpp::(0+'} = \&version::vpp::numify; + *{'version::vpp::(cmp'} = \&version::vpp::vcmp; + *{'version::vpp::(<=>'} = \&version::vpp::vcmp; + *{'version::vpp::(bool'} = \&version::vpp::vbool; + *{'charstar::(""'} = \&charstar::thischar; + *{'charstar::(0+'} = \&charstar::thischar; + *{'charstar::(++'} = \&charstar::increment; + *{'charstar::(--'} = \&charstar::decrement; + *{'charstar::(+'} = \&charstar::plus; + *{'charstar::(-'} = \&charstar::minus; + *{'charstar::(*'} = \&charstar::multiply; + *{'charstar::(cmp'} = \&charstar::cmp; + *{'charstar::(<=>'} = \&charstar::spaceship; + *{'charstar::(bool'} = \&charstar::thischar; + *{'charstar::(='} = \&charstar::clone; + $restored = 1; + } + # version in core + if (!$restored) { + *{'version::(""'} = \&version::stringify; + *{'version::(0+'} = \&version::numify; + *{'version::(cmp'} = \&version::vcmp; + *{'version::(<=>'} = \&version::vcmp; + *{'version::(bool'} = \&version::boolean; + } + } + + # from PAUSE::pmfile; + sub _packages_per_pmfile { + my $self = shift; + + my $ppp = {}; + my $pmfile = $self->{PMFILE}; + my $filemtime = $self->{MTIME}; + my $version = $self->{VERSION}; + + open my $fh, "<", "$pmfile" or return $ppp; + + local $/ = "\n"; + my $inpod = 0; + + PLINE: while (<$fh>) { + chomp; + my($pline) = $_; + $inpod = $pline =~ /^=(?!cut)/ ? 1 : + $pline =~ /^=cut/ ? 0 : $inpod; + next if $inpod; + next if substr($pline,0,4) eq "=cut"; + + $pline =~ s/\#.*//; + next if $pline =~ /^\s*$/; + if ($pline =~ /^__(?:END|DATA)__\b/ + and $pmfile !~ /\.PL$/ # PL files may well have code after __DATA__ + ){ + last PLINE; + } + + my $pkg; + my $strict_version; + + if ( + $pline =~ m{ + # (.*) # takes too much time if $pline is long + (? 128; + #restriction + $ppp->{$pkg}{parsed}++; + $ppp->{$pkg}{infile} = $pmfile; + if ($self->_simile($pmfile,$pkg)) { + $ppp->{$pkg}{simile} = $pmfile; + if ($self->_version_from_meta_ok) { + my $provides = $self->{META_CONTENT}{provides}; + if (exists $provides->{$pkg}) { + if (defined $provides->{$pkg}{version}) { + my $v = $provides->{$pkg}{version}; + if ($v =~ /[_\s]/ && !$self->{ALLOW_DEV_VERSION} && !$ALLOW_DEV_VERSION){ # ignore developer releases and "You suck!" + next PLINE; + } + + unless (eval { $version = $self->_normalize_version($v); 1 }) { + $self->_verbose(1, "error with version in $pmfile: $@"); + next; + + } + $ppp->{$pkg}{version} = $version; + } else { + $ppp->{$pkg}{version} = "undef"; + } + } + } else { + if (defined $strict_version){ + $ppp->{$pkg}{version} = $strict_version ; + } else { + $ppp->{$pkg}{version} = defined $version ? $version : ""; + } + no warnings; + if ($version eq 'undef') { + $ppp->{$pkg}{version} = $version unless defined $ppp->{$pkg}{version}; + } else { + $ppp->{$pkg}{version} = + $version + if $version + > $ppp->{$pkg}{version} || + $version + gt $ppp->{$pkg}{version}; + } + } + } else { # not simile + #### it comes later, it would be nonsense + #### to set to "undef". MM_Unix gives us + #### the best we can reasonably consider + $ppp->{$pkg}{version} = + $version + unless defined $ppp->{$pkg}{version} && + length($ppp->{$pkg}{version}); + } + $ppp->{$pkg}{filemtime} = $filemtime; + } else { + # $self->_verbose(2,"no pkg found"); + } + } + + close $fh; + $ppp; + } + + # from PAUSE::pmfile; + { + no strict; + sub _parse_version_safely { + my($parsefile) = @_; + my $result; + local *FH; + local $/ = "\n"; + open(FH,$parsefile) or die "Could not open '$parsefile': $!"; + my $inpod = 0; + while () { + $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod; + next if $inpod || /^\s*#/; + last if /^__(?:END|DATA)__\b/; # fails on quoted __END__ but this is rare -> __END__ in the middle of a line is rarer + chop; + + if (my ($ver) = /package \s+ \S+ \s+ (\S+) \s* [;{]/x) { + # XXX: should handle this better if version is bogus -- rjbs, + # 2014-03-16 + return $ver if version::is_lax($ver); + } + + # next unless /\$(([\w\:\']*)\bVERSION)\b.*\=/; + next unless /(?<=])\=(?![=>])/; + my $current_parsed_line = $_; + my $eval = qq{ + package # + ExtUtils::MakeMaker::_version; + + local $1$2; + \$$2=undef; do { + $_ + }; \$$2 + }; + local $^W = 0; + local $SIG{__WARN__} = sub {}; + $result = __clean_eval($eval); + # warn "current_parsed_line[$current_parsed_line]\$\@[$@]"; + if ($@ or !defined $result){ + die +{ + eval => $eval, + line => $current_parsed_line, + file => $parsefile, + err => $@, + }; + } + last; + } #; + close FH; + + $result = "undef" unless defined $result; + if ((ref $result) =~ /^version(?:::vpp)?\b/) { + $result = $result->numify; + } + return $result; + } + } + + # from PAUSE::pmfile; + sub _filter_ppps { + my($self,@ppps) = @_; + my @res; + + # very similar code is in PAUSE::dist::filter_pms + MANI: for my $ppp ( @ppps ) { + if ($self->{META_CONTENT}){ + my $no_index = $self->{META_CONTENT}{no_index} + || $self->{META_CONTENT}{private}; # backward compat + if (ref($no_index) eq 'HASH') { + my %map = ( + package => qr{\z}, + namespace => qr{::}, + ); + for my $k (qw(package namespace)) { + next unless my $v = $no_index->{$k}; + my $rest = $map{$k}; + if (ref $v eq "ARRAY") { + for my $ve (@$v) { + $ve =~ s|::$||; + if ($ppp =~ /^$ve$rest/){ + $self->_verbose(1,"Skipping ppp[$ppp] due to ve[$ve]"); + next MANI; + } else { + $self->_verbose(1,"NOT skipping ppp[$ppp] due to ve[$ve]"); + } + } + } else { + $v =~ s|::$||; + if ($ppp =~ /^$v$rest/){ + $self->_verbose(1,"Skipping ppp[$ppp] due to v[$v]"); + next MANI; + } else { + $self->_verbose(1,"NOT skipping ppp[$ppp] due to v[$v]"); + } + } + } + } else { + $self->_verbose(1,"No keyword 'no_index' or 'private' in META_CONTENT"); + } + } else { + # $self->_verbose(1,"no META_CONTENT"); # too noisy + } + push @res, $ppp; + } + $self->_verbose(1,"Result of filter_ppps: res[@res]"); + @res; + } + + # from PAUSE::pmfile; + sub _simile { + my($self,$file,$package) = @_; + # MakeMaker gives them the chance to have the file Simple.pm in + # this directory but have the package HTML::Simple in it. + # Afaik, they wouldn't be able to do so with deeper nested packages + $file =~ s|.*/||; + $file =~ s|\.pm(?:\.PL)?||; + my $ret = $package =~ m/\b\Q$file\E$/; + $ret ||= 0; + unless ($ret) { + # Apache::mod_perl_guide stuffs it into Version.pm + $ret = 1 if lc $file eq 'version'; + } + $self->_verbose(1,"Result of simile(): file[$file] package[$package] ret[$ret]\n"); + $ret; + } + + # from PAUSE::pmfile + sub _normalize_version { + my($self,$v) = @_; + $v = "undef" unless defined $v; + my $dv = Dumpvalue->new; + my $sdv = $dv->stringify($v,1); # second argument prevents ticks + $self->_verbose(1,"Result of normalize_version: sdv[$sdv]\n"); + + return $v if $v eq "undef"; + return $v if $v =~ /^\{.*\}$/; # JSON object + $v =~ s/^\s+//; + $v =~ s/\s+\z//; + if ($v =~ /_/) { + # XXX should pass something like EDEVELOPERRELEASE up e.g. + # SIXTEASE/XML-Entities-0.0306.tar.gz had nothing but one + # such modules and the mesage was not helpful that "nothing + # was found". + return $v ; + } + if (!version::is_lax($v)) { + return JSON::PP::encode_json({ x_normalize => 'version::is_lax failed', version => $v }); + } + # may warn "Integer overflow" + my $vv = eval { no warnings; version->new($v)->numify }; + if ($@) { + # warn "$v: $@"; + return JSON::PP::encode_json({ x_normalize => $@, version => $v }); + # return "undef"; + } + if ($vv eq $v) { + # the boring 3.14 + } else { + my $forced = $self->_force_numeric($v); + if ($forced eq $vv) { + } elsif ($forced =~ /^v(.+)/) { + # rare case where a v1.0.23 slipped in (JANL/w3mir-1.0.10.tar.gz) + $vv = version->new($1)->numify; + } else { + # warn "Unequal forced[$forced] and vv[$vv]"; + if ($forced == $vv) { + # the trailing zeroes would cause unnecessary havoc + $vv = $forced; + } + } + } + return $vv; + } + + # from PAUSE::pmfile; + sub _force_numeric { + my($self,$v) = @_; + $v = $self->_readable($v); + + if ( + $v =~ + /^(\+?)(\d*)(\.(\d*))?/ && + # "$2$4" ne '' + ( + defined $2 && length $2 + || + defined $4 && length $4 + ) + ) { + my $two = defined $2 ? $2 : ""; + my $three = defined $3 ? $3 : ""; + $v = "$two$three"; + } + # no else branch! We simply say, everything else is a string. + $v; + } + + # from PAUSE::dist + sub _version_from_meta_ok { + my($self) = @_; + return $self->{VERSION_FROM_META_OK} if exists $self->{VERSION_FROM_META_OK}; + my $c = $self->{META_CONTENT}; + + # If there's no provides hash, we can't get our module versions from the + # provides hash! -- rjbs, 2012-03-31 + return($self->{VERSION_FROM_META_OK} = 0) unless $c->{provides}; + + # Some versions of Module::Build geneated an empty provides hash. If we're + # *not* looking at a Module::Build-generated metafile, then it's okay. + my ($mb_v) = (defined $c->{generated_by} ? $c->{generated_by} : '') =~ /Module::Build version ([\d\.]+)/; + return($self->{VERSION_FROM_META_OK} = 1) unless $mb_v; + + # ??? I don't know why this is here. + return($self->{VERSION_FROM_META_OK} = 1) if $mb_v eq '0.250.0'; + + if ($mb_v >= 0.19 && $mb_v < 0.26 && ! keys %{$c->{provides}}) { + # RSAVAGE/Javascript-SHA1-1.01.tgz had an empty provides hash. Ron + # did not find the reason why this happened, but let's not go + # overboard, 0.26 seems a good threshold from the statistics: there + # are not many empty provides hashes from 0.26 up. + return($self->{VERSION_FROM_META_OK} = 0); + } + + # We're not in the suspect range of M::B versions. It's good to go. + return($self->{VERSION_FROM_META_OK} = 1); + } + + sub _verbose { + my($self,$level,@what) = @_; + warn @what if $level <= ((ref $self && $self->{VERBOSE}) || $VERBOSE); + } + + # all of the following methods are stripped from CPAN::Version + # (as of version 5.5001, bundled in CPAN 2.03), and slightly + # modified (ie. made private, as well as CPAN->debug(...) are + # replaced with $self->_verbose(9, ...).) + + # CPAN::Version::vcmp courtesy Jost Krieger + sub _vcmp { + my($self,$l,$r) = @_; + local($^W) = 0; + $self->_verbose(9, "l[$l] r[$r]"); + + return 0 if $l eq $r; # short circuit for quicker success + + for ($l,$r) { + s/_//g; + } + $self->_verbose(9, "l[$l] r[$r]"); + for ($l,$r) { + next unless tr/.// > 1 || /^v/; + s/^v?/v/; + 1 while s/\.0+(\d)/.$1/; # remove leading zeroes per group + } + $self->_verbose(9, "l[$l] r[$r]"); + if ($l=~/^v/ <=> $r=~/^v/) { + for ($l,$r) { + next if /^v/; + $_ = $self->_float2vv($_); + } + } + $self->_verbose(9, "l[$l] r[$r]"); + my $lvstring = "v0"; + my $rvstring = "v0"; + if ($] >= 5.006 + && $l =~ /^v/ + && $r =~ /^v/) { + $lvstring = $self->_vstring($l); + $rvstring = $self->_vstring($r); + $self->_verbose(9, sprintf "lv[%vd] rv[%vd]", $lvstring, $rvstring); + } + + return ( + ($l ne "undef") <=> ($r ne "undef") + || + $lvstring cmp $rvstring + || + $l <=> $r + || + $l cmp $r + ); + } + + sub _vgt { + my($self,$l,$r) = @_; + $self->_vcmp($l,$r) > 0; + } + + sub _vlt { + my($self,$l,$r) = @_; + $self->_vcmp($l,$r) < 0; + } + + sub _vge { + my($self,$l,$r) = @_; + $self->_vcmp($l,$r) >= 0; + } + + sub _vle { + my($self,$l,$r) = @_; + $self->_vcmp($l,$r) <= 0; + } + + sub _vstring { + my($self,$n) = @_; + $n =~ s/^v// or die "Parse::PMFile::_vstring() called with invalid arg [$n]"; + pack "U*", split /\./, $n; + } + + # vv => visible vstring + sub _float2vv { + my($self,$n) = @_; + my($rev) = int($n); + $rev ||= 0; + my($mantissa) = $n =~ /\.(\d{1,12})/; # limit to 12 digits to limit + # architecture influence + $mantissa ||= 0; + $mantissa .= "0" while length($mantissa)%3; + my $ret = "v" . $rev; + while ($mantissa) { + $mantissa =~ s/(\d{1,3})// or + die "Panic: length>0 but not a digit? mantissa[$mantissa]"; + $ret .= ".".int($1); + } + # warn "n[$n]ret[$ret]"; + $ret =~ s/(\.0)+/.0/; # v1.0.0 => v1.0 + $ret; + } + + sub _readable { + my($self,$n) = @_; + $n =~ /^([\w\-\+\.]+)/; + + return $1 if defined $1 && length($1)>0; + # if the first user reaches version v43, he will be treated as "+". + # We'll have to decide about a new rule here then, depending on what + # will be the prevailing versioning behavior then. + + if ($] < 5.006) { # or whenever v-strings were introduced + # we get them wrong anyway, whatever we do, because 5.005 will + # have already interpreted 0.2.4 to be "0.24". So even if he + # indexer sends us something like "v0.2.4" we compare wrongly. + + # And if they say v1.2, then the old perl takes it as "v12" + + $self->_verbose(9, "Suspicious version string seen [$n]\n"); + return $n; + } + my $better = sprintf "v%vd", $n; + $self->_verbose(9, "n[$n] better[$better]"); + return $better; + } + + 1; + + __END__ + + =head1 NAME + + Parse::PMFile - parses .pm file as PAUSE does + + =head1 SYNOPSIS + + use Parse::PMFile; + + my $parser = Parse::PMFile->new($metadata, {VERBOSE => 1}); + my $packages_info = $parser->parse($pmfile); + + # if you need info about invalid versions + my ($packages_info, $errors) = $parser->parse($pmfile); + + # to check permissions + my $parser = Parse::PMFile->new($metadata, { + USERID => 'ISHIGAKI', + PERMISSIONS => PAUSE::Permissions->new, + }); + + =head1 DESCRIPTION + + The most of the code of this module is taken from the PAUSE code as of April 2013 almost verbatim. Thus, the heart of this module should be quite stable. However, I made it not to use pipe ("-|") as well as I stripped database-related code. If you encounter any issue, that's most probably because of my modification. + + This module doesn't provide features to extract a distribution or parse meta files intentionally. + + =head1 METHODS + + =head2 new + + creates an object. You can also pass a hashref taken from META.yml etc, and an optional hashref. Options are: + + =over 4 + + =item ALLOW_DEV_VERSION + + Parse::PMFile usually ignores a version with an underscore as PAUSE does (because it's for a developer release, and should not be indexed). Set this option to true if you happen to need to keep such a version for better analysis. + + =item VERBOSE + + Set this to true if you need to know some details. + + =item FORK + + As of version 0.17, Parse::PMFile stops forking while parsing a version for better performance. Parse::PMFile should return the same result no matter how this option is set, but if you do care, set this to true to fork as PAUSE does. + + =item USERID, PERMISSIONS + + As of version 0.21, Parse::PMFile checks permissions of a package if both USERID and PERMISSIONS (which should be an instance of L) are provided. Unauthorized packages are removed. + + =item UNSAFE + + Parse::PMFile usually parses a module version in a Safe compartment. However, this approach doesn't work smoothly under older perls (prior to 5.10) plus some combinations of recent versions of Safe.pm (2.24 and above) and version.pm (0.9905 and above) for various reasons. As of version 0.27, Parse::PMFile simply uses C to parse a version under older perls. If you want it to use always C (even under recent perls), set this to true. + + =back + + =head2 parse + + takes a path to a .pm file, and returns a hash reference that holds information for package(s) found in the file. + + =head1 SEE ALSO + + L, L + + Most part of this module is derived from PAUSE and CPAN::Version. + + L + + L + + =head1 AUTHOR + + Andreas Koenig Eandreas.koenig@anima.deE + + Kenichi Ishigaki, Eishigaki@cpan.orgE + + =head1 COPYRIGHT AND LICENSE + + Copyright 1995 - 2013 by Andreas Koenig Eandk@cpan.orgE for most of the code. + + Copyright 2013 by Kenichi Ishigaki for some. + + This program is free software; you can redistribute it and/or + modify it under the same terms as Perl itself. + + =cut + PARSE_PMFILE + + $fatpacked{"String/ShellQuote.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'STRING_SHELLQUOTE'; + # $Id: ShellQuote.pm,v 1.11 2010-06-11 20:08:57 roderick Exp $ + # + # Copyright (c) 1997 Roderick Schertler. All rights reserved. This + # program is free software; you can redistribute it and/or modify it + # under the same terms as Perl itself. + + =head1 NAME + + String::ShellQuote - quote strings for passing through the shell + + =head1 SYNOPSIS + + $string = shell_quote @list; + $string = shell_quote_best_effort @list; + $string = shell_comment_quote $string; + + =head1 DESCRIPTION + + This module contains some functions which are useful for quoting strings + which are going to pass through the shell or a shell-like object. + + =over + + =cut + + package String::ShellQuote; + + use strict; + use vars qw($VERSION @ISA @EXPORT); + + require Exporter; + + $VERSION = '1.04'; + @ISA = qw(Exporter); + @EXPORT = qw(shell_quote shell_quote_best_effort shell_comment_quote); + + sub croak { + require Carp; + goto &Carp::croak; + } + + sub _shell_quote_backend { + my @in = @_; + my @err = (); + + if (0) { + require RS::Handy; + print RS::Handy::data_dump(\@in); + } + + return \@err, '' unless @in; + + my $ret = ''; + my $saw_non_equal = 0; + foreach (@in) { + if (!defined $_ or $_ eq '') { + $_ = "''"; + next; + } + + if (s/\x00//g) { + push @err, "No way to quote string containing null (\\000) bytes"; + } + + my $escape = 0; + + # = needs quoting when it's the first element (or part of a + # series of such elements), as in command position it's a + # program-local environment setting + + if (/=/) { + if (!$saw_non_equal) { + $escape = 1; + } + } + else { + $saw_non_equal = 1; + } + + if (m|[^\w!%+,\-./:=@^]|) { + $escape = 1; + } + + if ($escape + || (!$saw_non_equal && /=/)) { + + # ' -> '\'' + s/'/'\\''/g; + + # make multiple ' in a row look simpler + # '\'''\'''\'' -> '"'''"' + s|((?:'\\''){2,})|q{'"} . (q{'} x (length($1) / 4)) . q{"'}|ge; + + $_ = "'$_'"; + s/^''//; + s/''$//; + } + } + continue { + $ret .= "$_ "; + } + + chop $ret; + return \@err, $ret; + } + + =item B [I]... + + B quotes strings so they can be passed through the shell. + Each I is quoted so that the shell will pass it along as a + single argument and without further interpretation. If no Is + are given an empty string is returned. + + If any I can't be safely quoted B will B. + + =cut + + sub shell_quote { + my ($rerr, $s) = _shell_quote_backend @_; + + if (@$rerr) { + my %seen; + @$rerr = grep { !$seen{$_}++ } @$rerr; + my $s = join '', map { "shell_quote(): $_\n" } @$rerr; + chomp $s; + croak $s; + } + return $s; + } + + =item B [I]... + + This is like B, excpet if the string can't be safely quoted + it does the best it can and returns the result, instead of dying. + + =cut + + sub shell_quote_best_effort { + my ($rerr, $s) = _shell_quote_backend @_; + + return $s; + } + + =item B [I] + + B quotes the I so that it can safely be + included in a shell-style comment (the current algorithm is that a sharp + character is placed after any newlines in the string). + + This routine might be changed to accept multiple I arguments + in the future. I haven't done this yet because I'm not sure if the + Is should be joined with blanks ($") or nothing ($,). Cast + your vote today! Be sure to justify your answer. + + =cut + + sub shell_comment_quote { + return '' unless @_; + unless (@_ == 1) { + croak "Too many arguments to shell_comment_quote " + . "(got " . @_ . " expected 1)"; + } + local $_ = shift; + s/\n/\n#/g; + return $_; + } + + 1; + + __END__ + + =back + + =head1 EXAMPLES + + $cmd = 'fuser 2>/dev/null ' . shell_quote @files; + @pids = split ' ', `$cmd`; + + print CFG "# Configured by: ", + shell_comment_quote($ENV{LOGNAME}), "\n"; + + =head1 BUGS + + Only Bourne shell quoting is supported. I'd like to add other shells + (particularly cmd.exe), but I'm not familiar with them. It would be a + big help if somebody supplied the details. + + =head1 AUTHOR + + Roderick Schertler > + + =head1 SEE ALSO + + perl(1). + + =cut + STRING_SHELLQUOTE + + $fatpacked{"lib/core/only.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LIB_CORE_ONLY'; + package lib::core::only; + + use strict; + use warnings FATAL => 'all'; + use Config; + + sub import { + @INC = @Config{qw(privlibexp archlibexp)}; + return + } + + =head1 NAME + + lib::core::only - Remove all non-core paths from @INC to avoid site/vendor dirs + + =head1 SYNOPSIS + + use lib::core::only; # now @INC contains only the two core directories + + To get only the core directories plus the ones for the local::lib in scope: + + $ perl -mlocal::lib -Mlib::core::only -Mlocal::lib=~/perl5 myscript.pl + + To attempt to do a self-contained build (but note this will not reliably + propagate into subprocesses, see the CAVEATS below): + + $ PERL5OPT='-mlocal::lib -Mlib::core::only -Mlocal::lib=~/perl5' cpan + + Please note that it is necessary to use C twice for this to work. + First so that C doesn't prevent C from loading + (it's not currently in core) and then again after C so that + the local paths are not removed. + + =head1 DESCRIPTION + + lib::core::only is simply a shortcut to say "please reduce my @INC to only + the core lib and archlib (architecture-specific lib) directories of this perl". + + You might want to do this to ensure a local::lib contains only the code you + need, or to test an L tree, or to avoid known + bad vendor packages. + + You might want to use this to try and install a self-contained tree of perl + modules. Be warned that that probably won't work (see L). + + This module was extracted from L's --self-contained + feature, and contains the only part that ever worked. I apologise to anybody + who thought anything else did. + + =head1 CAVEATS + + This does B propagate properly across perl invocations like local::lib's + stuff does. It can't. It's only a module import, so it B. + + If you want to cascade it across invocations, you can set the PERL5OPT + environment variable to '-Mlib::core::only' and it'll sort of work. But be + aware that taint mode ignores this, so some modules' build and test code + probably will as well. + + You also need to be aware that perl's command line options are not processed + in order - -I options take effect before -M options, so + + perl -Mlib::core::only -Ilib + + is unlike to do what you want - it's exactly equivalent to: + + perl -Mlib::core::only + + If you want to combine a core-only @INC with additional paths, you need to + add the additional paths using -M options and the L module: + + perl -Mlib::core::only -Mlib=lib + + # or if you're trying to test compiled code: + + perl -Mlib::core::only -Mblib + + For more information on the impossibility of sanely propagating this across + module builds without help from the build program, see + L - and for ways + to achieve the old --self-contained feature's results, look at + L's tree function, and at + L's --local-lib-contained feature. + + =head1 AUTHOR + + Matt S. Trout + + =head1 LICENSE + + This library is free software under the same terms as perl itself. + + =head1 COPYRIGHT + + (c) 2010 the lib::core::only L as specified above. + + =cut + + 1; + LIB_CORE_ONLY + + $fatpacked{"local/lib.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOCAL_LIB'; + package local::lib; + use 5.006; + use strict; + use warnings; + use Config; + + our $VERSION = '2.000015'; + $VERSION = eval $VERSION; + + BEGIN { + *_WIN32 = ($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'symbian') + ? sub(){1} : sub(){0}; + # punt on these systems + *_USE_FSPEC = ($^O eq 'MacOS' || $^O eq 'VMS' || $INC{'File/Spec.pm'}) + ? sub(){1} : sub(){0}; + } + our $_DIR_JOIN = _WIN32 ? '\\' : '/'; + our $_DIR_SPLIT = (_WIN32 || $^O eq 'cygwin') ? qr{[\\/]} + : qr{/}; + our $_ROOT = _WIN32 ? do { + my $UNC = qr{[\\/]{2}[^\\/]+[\\/][^\\/]+}; + qr{^(?:$UNC|[A-Za-z]:|)$_DIR_SPLIT}; + } : qr{^/}; + our $_PERL; + + sub _cwd { + my $drive = shift; + if (!$_PERL) { + ($_PERL) = $^X =~ /(.+)/; # $^X is internal how could it be tainted?! + if (_is_abs($_PERL)) { + } + elsif (-x $Config{perlpath}) { + $_PERL = $Config{perlpath}; + } + else { + ($_PERL) = + map { /(.*)/ } + grep { -x $_ } + map { join($_DIR_JOIN, $_, $_PERL) } + split /\Q$Config{path_sep}\E/, $ENV{PATH}; + } + } + local @ENV{qw(PATH IFS CDPATH ENV BASH_ENV)}; + my $cmd = $drive ? "eval { Cwd::getdcwd(q($drive)) }" + : 'getcwd'; + my $cwd = `"$_PERL" -MCwd -le "print $cmd"`; + chomp $cwd; + if (!length $cwd && $drive) { + $cwd = $drive; + } + $cwd =~ s/$_DIR_SPLIT?$/$_DIR_JOIN/; + $cwd; + } + + sub _catdir { + if (_USE_FSPEC) { + require File::Spec; + File::Spec->catdir(@_); + } + else { + my $dir = join($_DIR_JOIN, @_); + $dir =~ s{($_DIR_SPLIT)(?:\.?$_DIR_SPLIT)+}{$1}g; + $dir; + } + } + + sub _is_abs { + if (_USE_FSPEC) { + require File::Spec; + File::Spec->file_name_is_absolute($_[0]); + } + else { + $_[0] =~ $_ROOT; + } + } + + sub _rel2abs { + my ($dir, $base) = @_; + return $dir + if _is_abs($dir); + + $base = _WIN32 && $dir =~ s/^([A-Za-z]:)// ? _cwd("$1") + : $base ? $base + : _cwd; + return _catdir($base, $dir); + } + + sub import { + my ($class, @args) = @_; + push @args, @ARGV + if $0 eq '-'; + + my @steps; + my %opts; + my $shelltype; + + while (@args) { + my $arg = shift @args; + # check for lethal dash first to stop processing before causing problems + # the fancy dash is U+2212 or \xE2\x88\x92 + if ($arg =~ /\xE2\x88\x92/ or $arg =~ /−/) { + die <<'DEATH'; + WHOA THERE! It looks like you've got some fancy dashes in your commandline! + These are *not* the traditional -- dashes that software recognizes. You + probably got these by copy-pasting from the perldoc for this module as + rendered by a UTF8-capable formatter. This most typically happens on an OS X + terminal, but can happen elsewhere too. Please try again after replacing the + dashes with normal minus signs. + DEATH + } + elsif ($arg eq '--self-contained') { + die <<'DEATH'; + 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). + DEATH + } + elsif( $arg =~ /^--deactivate(?:=(.*))?$/ ) { + my $path = defined $1 ? $1 : shift @args; + push @steps, ['deactivate', $path]; + } + elsif ( $arg eq '--deactivate-all' ) { + push @steps, ['deactivate_all']; + } + elsif ( $arg =~ /^--shelltype(?:=(.*))?$/ ) { + $shelltype = defined $1 ? $1 : shift @args; + } + elsif ( $arg eq '--no-create' ) { + $opts{no_create} = 1; + } + elsif ( $arg =~ /^--/ ) { + die "Unknown import argument: $arg"; + } + else { + push @steps, ['activate', $arg]; + } + } + if (!@steps) { + push @steps, ['activate', undef]; + } + + my $self = $class->new(%opts); + + for (@steps) { + my ($method, @args) = @$_; + $self = $self->$method(@args); + } + + if ($0 eq '-') { + print $self->environment_vars_string($shelltype); + exit 0; + } + else { + $self->setup_local_lib; + } + } + + sub new { + my $class = shift; + bless {@_}, $class; + } + + sub clone { + my $self = shift; + bless {%$self, @_}, ref $self; + } + + sub inc { $_[0]->{inc} ||= \@INC } + sub libs { $_[0]->{libs} ||= [ \'PERL5LIB' ] } + sub bins { $_[0]->{bins} ||= [ \'PATH' ] } + sub roots { $_[0]->{roots} ||= [ \'PERL_LOCAL_LIB_ROOT' ] } + sub extra { $_[0]->{extra} ||= {} } + sub no_create { $_[0]->{no_create} } + + my $_archname = $Config{archname}; + my $_version = $Config{version}; + my @_inc_version_list = reverse split / /, $Config{inc_version_list}; + my $_path_sep = $Config{path_sep}; + + sub _as_list { + my $list = shift; + grep length, map { + !(ref $_ && ref $_ eq 'SCALAR') ? $_ : ( + defined $ENV{$$_} ? split(/\Q$_path_sep/, $ENV{$$_}) + : () + ) + } ref $list ? @$list : $list; + } + sub _remove_from { + my ($list, @remove) = @_; + return @$list + if !@remove; + my %remove = map { $_ => 1 } @remove; + grep !$remove{$_}, _as_list($list); + } + + my @_lib_subdirs = ( + [$_version, $_archname], + [$_version], + [$_archname], + (@_inc_version_list ? \@_inc_version_list : ()), + [], + ); + + sub install_base_bin_path { + my ($class, $path) = @_; + return _catdir($path, 'bin'); + } + sub install_base_perl_path { + my ($class, $path) = @_; + return _catdir($path, 'lib', 'perl5'); + } + sub install_base_arch_path { + my ($class, $path) = @_; + _catdir($class->install_base_perl_path($path), $_archname); + } + + sub lib_paths_for { + my ($class, $path) = @_; + my $base = $class->install_base_perl_path($path); + return map { _catdir($base, @$_) } @_lib_subdirs; + } + + sub _mm_escape_path { + my $path = shift; + $path =~ s/\\/\\\\/g; + if ($path =~ s/ /\\ /g) { + $path = qq{"$path"}; + } + return $path; + } + + sub _mb_escape_path { + my $path = shift; + $path =~ s/\\/\\\\/g; + return qq{"$path"}; + } + + sub installer_options_for { + my ($class, $path) = @_; + return ( + PERL_MM_OPT => + defined $path ? "INSTALL_BASE="._mm_escape_path($path) : undef, + PERL_MB_OPT => + defined $path ? "--install_base "._mb_escape_path($path) : undef, + ); + } + + sub active_paths { + my ($self) = @_; + $self = ref $self ? $self : $self->new; + + return grep { + # screen out entries that aren't actually reflected in @INC + my $active_ll = $self->install_base_perl_path($_); + grep { $_ eq $active_ll } @{$self->inc}; + } _as_list($self->roots); + } + + + sub deactivate { + my ($self, $path) = @_; + $self = $self->new unless ref $self; + $path = $self->resolve_path($path); + $path = $self->normalize_path($path); + + my @active_lls = $self->active_paths; + + if (!grep { $_ eq $path } @active_lls) { + warn "Tried to deactivate inactive local::lib '$path'\n"; + return $self; + } + + my %args = ( + bins => [ _remove_from($self->bins, + $self->install_base_bin_path($path)) ], + libs => [ _remove_from($self->libs, + $self->install_base_perl_path($path)) ], + inc => [ _remove_from($self->inc, + $self->lib_paths_for($path)) ], + roots => [ _remove_from($self->roots, $path) ], + ); + + $args{extra} = { $self->installer_options_for($args{roots}[0]) }; + + $self->clone(%args); + } + + sub deactivate_all { + my ($self) = @_; + $self = $self->new unless ref $self; + + my @active_lls = $self->active_paths; + + my %args; + if (@active_lls) { + %args = ( + bins => [ _remove_from($self->bins, + map $self->install_base_bin_path($_), @active_lls) ], + libs => [ _remove_from($self->libs, + map $self->install_base_perl_path($_), @active_lls) ], + inc => [ _remove_from($self->inc, + map $self->lib_paths_for($_), @active_lls) ], + roots => [ _remove_from($self->roots, @active_lls) ], + ); + } + + $args{extra} = { $self->installer_options_for(undef) }; + + $self->clone(%args); + } + + sub activate { + my ($self, $path) = @_; + $self = $self->new unless ref $self; + $path = $self->resolve_path($path); + $self->ensure_dir_structure_for($path) + unless $self->no_create; + + $path = $self->normalize_path($path); + + my @active_lls = $self->active_paths; + + if (grep { $_ eq $path } @active_lls[1 .. $#active_lls]) { + $self = $self->deactivate($path); + } + + my %args; + if (!@active_lls || $active_lls[0] ne $path) { + %args = ( + bins => [ $self->install_base_bin_path($path), @{$self->bins} ], + libs => [ $self->install_base_perl_path($path), @{$self->libs} ], + inc => [ $self->lib_paths_for($path), @{$self->inc} ], + roots => [ $path, @{$self->roots} ], + ); + } + + $args{extra} = { $self->installer_options_for($path) }; + + $self->clone(%args); + } + + sub normalize_path { + my ($self, $path) = @_; + $path = ( Win32::GetShortPathName($path) || $path ) + if $^O eq 'MSWin32'; + return $path; + } + + sub build_environment_vars_for { + my $self = $_[0]->new->activate($_[1]); + $self->build_environment_vars; + } + sub build_activate_environment_vars_for { + my $self = $_[0]->new->activate($_[1]); + $self->build_environment_vars; + } + sub build_deactivate_environment_vars_for { + my $self = $_[0]->new->deactivate($_[1]); + $self->build_environment_vars; + } + sub build_deact_all_environment_vars_for { + my $self = $_[0]->new->deactivate_all; + $self->build_environment_vars; + } + sub build_environment_vars { + my $self = shift; + ( + PATH => join($_path_sep, _as_list($self->bins)), + PERL5LIB => join($_path_sep, _as_list($self->libs)), + PERL_LOCAL_LIB_ROOT => join($_path_sep, _as_list($self->roots)), + %{$self->extra}, + ); + } + + sub setup_local_lib_for { + my $self = $_[0]->new->activate($_[1]); + $self->setup_local_lib; + } + + sub setup_local_lib { + my $self = shift; + + # if Carp is already loaded, ensure Carp::Heavy is also loaded, to avoid + # $VERSION mismatch errors (Carp::Heavy loads Carp, so we do not need to + # check in the other direction) + require Carp::Heavy if $INC{'Carp.pm'}; + + $self->setup_env_hash; + @INC = @{$self->inc}; + } + + sub setup_env_hash_for { + my $self = $_[0]->new->activate($_[1]); + $self->setup_env_hash; + } + sub setup_env_hash { + my $self = shift; + my %env = $self->build_environment_vars; + for my $key (keys %env) { + if (defined $env{$key}) { + $ENV{$key} = $env{$key}; + } + else { + delete $ENV{$key}; + } + } + } + + sub print_environment_vars_for { + print $_[0]->environment_vars_string_for(@_[1..$#_]); + } + + sub environment_vars_string_for { + my $self = $_[0]->new->activate($_[1]); + $self->environment_vars_string; + } + sub environment_vars_string { + my ($self, $shelltype) = @_; + + $shelltype ||= $self->guess_shelltype; + + my $extra = $self->extra; + my @envs = ( + PATH => $self->bins, + PERL5LIB => $self->libs, + PERL_LOCAL_LIB_ROOT => $self->roots, + map { $_ => $extra->{$_} } sort keys %$extra, + ); + $self->_build_env_string($shelltype, \@envs); + } + + sub _build_env_string { + my ($self, $shelltype, $envs) = @_; + my @envs = @$envs; + + my $build_method = "build_${shelltype}_env_declaration"; + + my $out = ''; + while (@envs) { + my ($name, $value) = (shift(@envs), shift(@envs)); + if ( + ref $value + && @$value == 1 + && ref $value->[0] + && ref $value->[0] eq 'SCALAR' + && ${$value->[0]} eq $name) { + next; + } + $out .= $self->$build_method($name, $value); + } + my $wrap_method = "wrap_${shelltype}_output"; + if ($self->can($wrap_method)) { + return $self->$wrap_method($out); + } + return $out; + } + + sub build_bourne_env_declaration { + my ($class, $name, $args) = @_; + my $value = $class->_interpolate($args, '${%s}', qr/["\\\$!`]/, '\\%s'); + + if (!defined $value) { + return qq{unset $name;\n}; + } + + $value =~ s/(^|\G|$_path_sep)\$\{$name\}$_path_sep/$1\${$name}\${$name+$_path_sep}/g; + $value =~ s/$_path_sep\$\{$name\}$/\${$name+$_path_sep}\${$name}/; + + qq{${name}="$value"; export ${name};\n} + } + + sub build_csh_env_declaration { + my ($class, $name, $args) = @_; + my ($value, @vars) = $class->_interpolate($args, '${%s}', '"', '"\\%s"'); + if (!defined $value) { + return qq{unsetenv $name;\n}; + } + + my $out = ''; + for my $var (@vars) { + $out .= qq{if ! \$?$name setenv $name '';\n}; + } + + my $value_without = $value; + if ($value_without =~ s/(?:^|$_path_sep)\$\{$name\}(?:$_path_sep|$)//g) { + $out .= qq{if "\${$name}" != '' setenv $name "$value";\n}; + $out .= qq{if "\${$name}" == '' }; + } + $out .= qq{setenv $name "$value_without";\n}; + return $out; + } + + sub build_cmd_env_declaration { + my ($class, $name, $args) = @_; + my $value = $class->_interpolate($args, '%%%s%%', qr(%), '%s'); + if (!$value) { + return qq{\@set $name=\n}; + } + + my $out = ''; + my $value_without = $value; + if ($value_without =~ s/(?:^|$_path_sep)%$name%(?:$_path_sep|$)//g) { + $out .= qq{\@if not "%$name%"=="" set "$name=$value"\n}; + $out .= qq{\@if "%$name%"=="" }; + } + $out .= qq{\@set "$name=$value_without"\n}; + return $out; + } + + sub build_powershell_env_declaration { + my ($class, $name, $args) = @_; + my $value = $class->_interpolate($args, '$env:%s', '"', '`%s'); + + if (!$value) { + return qq{Remove-Item -ErrorAction 0 Env:\\$name;\n}; + } + + my $maybe_path_sep = qq{\$(if("\$env:$name"-eq""){""}else{"$_path_sep"})}; + $value =~ s/(^|\G|$_path_sep)\$env:$name$_path_sep/$1\$env:$name"+$maybe_path_sep+"/g; + $value =~ s/$_path_sep\$env:$name$/"+$maybe_path_sep+\$env:$name+"/; + + qq{\$env:$name = \$("$value");\n}; + } + sub wrap_powershell_output { + my ($class, $out) = @_; + return $out || " \n"; + } + + sub build_fish_env_declaration { + my ($class, $name, $args) = @_; + my $value = $class->_interpolate($args, '$%s', qr/[\\"' ]/, '\\%s'); + if (!defined $value) { + return qq{set -e $name;\n}; + } + $value =~ s/$_path_sep/ /g; + qq{set -x $name $value;\n}; + } + + sub _interpolate { + my ($class, $args, $var_pat, $escape, $escape_pat) = @_; + return + unless defined $args; + my @args = ref $args ? @$args : $args; + return + unless @args; + my @vars = map { $$_ } grep { ref $_ eq 'SCALAR' } @args; + my $string = join $_path_sep, map { + ref $_ eq 'SCALAR' ? sprintf($var_pat, $$_) : do { + s/($escape)/sprintf($escape_pat, $1)/ge; $_; + }; + } @args; + return wantarray ? ($string, \@vars) : $string; + } + + sub pipeline; + + sub pipeline { + my @methods = @_; + my $last = pop(@methods); + if (@methods) { + \sub { + my ($obj, @args) = @_; + $obj->${pipeline @methods}( + $obj->$last(@args) + ); + }; + } else { + \sub { + shift->$last(@_); + }; + } + } + + sub resolve_path { + my ($class, $path) = @_; + + $path = $class->${pipeline qw( + resolve_relative_path + resolve_home_path + resolve_empty_path + )}($path); + + $path; + } + + sub resolve_empty_path { + my ($class, $path) = @_; + if (defined $path) { + $path; + } else { + '~/perl5'; + } + } + + sub resolve_home_path { + my ($class, $path) = @_; + $path =~ /^~([^\/]*)/ or return $path; + my $user = $1; + my $homedir = do { + if (! length($user) && defined $ENV{HOME}) { + $ENV{HOME}; + } + else { + require File::Glob; + File::Glob::bsd_glob("~$user", File::Glob::GLOB_TILDE()); + } + }; + unless (defined $homedir) { + require Carp; require Carp::Heavy; + Carp::croak( + "Couldn't resolve homedir for " + .(defined $user ? $user : 'current user') + ); + } + $path =~ s/^~[^\/]*/$homedir/; + $path; + } + + sub resolve_relative_path { + my ($class, $path) = @_; + _rel2abs($path); + } + + sub ensure_dir_structure_for { + my ($class, $path) = @_; + unless (-d $path) { + warn "Attempting to create directory ${path}\n"; + } + require File::Basename; + my @dirs; + while(!-d $path) { + push @dirs, $path; + $path = File::Basename::dirname($path); + } + mkdir $_ for reverse @dirs; + return; + } + + sub guess_shelltype { + my $shellbin + = defined $ENV{SHELL} + ? ($ENV{SHELL} =~ /([\w.]+)$/)[-1] + : ( $^O eq 'MSWin32' && exists $ENV{'!EXITCODE'} ) + ? 'bash' + : ( $^O eq 'MSWin32' && $ENV{PROMPT} && $ENV{COMSPEC} ) + ? ($ENV{COMSPEC} =~ /([\w.]+)$/)[-1] + : ( $^O eq 'MSWin32' && !$ENV{PROMPT} ) + ? 'powershell.exe' + : 'sh'; + + for ($shellbin) { + return + /csh$/ ? 'csh' + : /fish/ ? 'fish' + : /command(?:\.com)?$/i ? 'cmd' + : /cmd(?:\.exe)?$/i ? 'cmd' + : /4nt(?:\.exe)?$/i ? 'cmd' + : /powershell(?:\.exe)?$/i ? 'powershell' + : 'bourne'; + } + } + + 1; + __END__ + + =encoding utf8 + + =head1 NAME + + local::lib - create and use a local lib/ for perl modules with PERL5LIB + + =head1 SYNOPSIS + + In code - + + use local::lib; # sets up a local lib at ~/perl5 + + use local::lib '~/foo'; # same, but ~/foo + + # Or... + use FindBin; + use local::lib "$FindBin::Bin/../support"; # app-local support library + + From the shell - + + # Install LWP and its missing dependencies to the '~/perl5' directory + perl -MCPAN -Mlocal::lib -e 'CPAN::install(LWP)' + + # Just print out useful shell commands + $ perl -Mlocal::lib + PERL_MB_OPT='--install_base /home/username/perl5'; export PERL_MB_OPT; + PERL_MM_OPT='INSTALL_BASE=/home/username/perl5'; export PERL_MM_OPT; + PERL5LIB="/home/username/perl5/lib/perl5"; export PERL5LIB; + PATH="/home/username/perl5/bin:$PATH"; export PATH; + PERL_LOCAL_LIB_ROOT="/home/usename/perl5:$PERL_LOCAL_LIB_ROOT"; export PERL_LOCAL_LIB_ROOT; + + From a .bashrc file - + + [ $SHLVL -eq 1 ] && eval "$(perl -I$HOME/perl5/lib/perl5 -Mlocal::lib)" + + =head2 The bootstrapping technique + + A typical way to install local::lib is using what is known as the + "bootstrapping" technique. You would do this if your system administrator + hasn't already installed local::lib. In this case, you'll need to install + local::lib in your home directory. + + Even if you do have administrative privileges, you will still want to set up your + environment variables, as discussed in step 4. Without this, you would still + install the modules into the system CPAN installation and also your Perl scripts + will not use the lib/ path you bootstrapped with local::lib. + + By default local::lib installs itself and the CPAN modules into ~/perl5. + + Windows users must also see L. + + =over 4 + + =item 1. + + Download and unpack the local::lib tarball from CPAN (search for "Download" + on the CPAN page about local::lib). Do this as an ordinary user, not as root + or administrator. Unpack the file in your home directory or in any other + convenient location. + + =item 2. + + Run this: + + perl Makefile.PL --bootstrap + + If the system asks you whether it should automatically configure as much + as possible, you would typically answer yes. + + In order to install local::lib into a directory other than the default, you need + to specify the name of the directory when you call bootstrap, as follows: + + perl Makefile.PL --bootstrap=~/foo + + =item 3. + + Run this: (local::lib assumes you have make installed on your system) + + make test && make install + + =item 4. + + Now we need to setup the appropriate environment variables, so that Perl + starts using our newly generated lib/ directory. If you are using bash or + any other Bourne shells, you can add this to your shell startup script this + way: + + echo '[ $SHLVL -eq 1 ] && eval "$(perl -I$HOME/perl5/lib/perl5 -Mlocal::lib)"' >>~/.bashrc + + If you are using C shell, you can do this as follows: + + /bin/csh + echo $SHELL + /bin/csh + echo 'eval `perl -I$HOME/perl5/lib/perl5 -Mlocal::lib`' >> ~/.cshrc + + If you passed to bootstrap a directory other than default, you also need to + give that as import parameter to the call of the local::lib module like this + way: + + echo '[ $SHLVL -eq 1 ] && eval "$(perl -I$HOME/foo/lib/perl5 -Mlocal::lib=$HOME/foo)"' >>~/.bashrc + + After writing your shell configuration file, be sure to re-read it to get the + changed settings into your current shell's environment. Bourne shells use + C<. ~/.bashrc> for this, whereas C shells use C. + + =back + + If you're on a slower machine, or are operating under draconian disk space + limitations, you can disable the automatic generation of manpages from POD when + installing modules by using the C<--no-manpages> argument when bootstrapping: + + perl Makefile.PL --bootstrap --no-manpages + + To avoid doing several bootstrap for several Perl module environments on the + same account, for example if you use it for several different deployed + applications independently, you can use one bootstrapped local::lib + installation to install modules in different directories directly this way: + + cd ~/mydir1 + perl -Mlocal::lib=./ + eval $(perl -Mlocal::lib=./) ### To set the environment for this shell alone + printenv ### You will see that ~/mydir1 is in the PERL5LIB + perl -MCPAN -e install ... ### whatever modules you want + cd ../mydir2 + ... REPEAT ... + + When used in a C<.bashrc> file, it is recommended that you protect against + re-activating a directory in a sub-shell. This can be done by checking the + C<$SHLVL> variable as shown in synopsis. Without this, sub-shells created by + the user or other programs will override changes made to the parent shell's + environment. + + If you are working with several C environments, you may want to + remove some of them from the current environment without disturbing the others. + You can deactivate one environment like this (using bourne sh): + + eval $(perl -Mlocal::lib=--deactivate,~/path) + + which will generate and run the commands needed to remove C<~/path> from your + various search paths. Whichever environment was B will + remain the target for module installations. That is, if you activate + C<~/path_A> and then you activate C<~/path_B>, new modules you install will go + in C<~/path_B>. If you deactivate C<~/path_B> then modules will be installed + into C<~/pathA> -- but if you deactivate C<~/path_A> then they will still be + installed in C<~/pathB> because pathB was activated later. + + You can also ask C to clean itself completely out of the current + shell's environment with the C<--deactivate-all> option. + For multiple environments for multiple apps you may need to include a modified + version of the C<< use FindBin >> instructions in the "In code" sample above. + If you did something like the above, you have a set of Perl modules at C<< + ~/mydir1/lib >>. If you have a script at C<< ~/mydir1/scripts/myscript.pl >>, + you need to tell it where to find the modules you installed for it at C<< + ~/mydir1/lib >>. + + In C<< ~/mydir1/scripts/myscript.pl >>: + + use strict; + use warnings; + use local::lib "$FindBin::Bin/.."; ### points to ~/mydir1 and local::lib finds lib + use lib "$FindBin::Bin/../lib"; ### points to ~/mydir1/lib + + Put this before any BEGIN { ... } blocks that require the modules you installed. + + =head2 Differences when using this module under Win32 + + To set up the proper environment variables for your current session of + C, you can use this: + + C:\>perl -Mlocal::lib + set PERL_MB_OPT=--install_base C:\DOCUME~1\ADMINI~1\perl5 + set PERL_MM_OPT=INSTALL_BASE=C:\DOCUME~1\ADMINI~1\perl5 + set PERL5LIB=C:\DOCUME~1\ADMINI~1\perl5\lib\perl5 + set PATH=C:\DOCUME~1\ADMINI~1\perl5\bin;%PATH% + + ### To set the environment for this shell alone + C:\>perl -Mlocal::lib > %TEMP%\tmp.bat && %TEMP%\tmp.bat && del %TEMP%\tmp.bat + ### instead of $(perl -Mlocal::lib=./) + + If you want the environment entries to persist, you'll need to add them to the + Control Panel's System applet yourself or use L. + + The "~" is translated to the user's profile directory (the directory named for + the user under "Documents and Settings" (Windows XP or earlier) or "Users" + (Windows Vista or later)) unless $ENV{HOME} exists. After that, the home + directory is translated to a short name (which means the directory must exist) + and the subdirectories are created. + + =head3 PowerShell + + local::lib also supports PowerShell, and can be used with the + C cmdlet. + + Invoke-Expression "$(perl -Mlocal::lib)" + + =head1 RATIONALE + + The version of a Perl package on your machine is not always the version you + need. Obviously, the best thing to do would be to update to the version you + need. However, you might be in a situation where you're prevented from doing + this. Perhaps you don't have system administrator privileges; or perhaps you + are using a package management system such as Debian, and nobody has yet gotten + around to packaging up the version you need. + + local::lib solves this problem by allowing you to create your own directory of + Perl packages downloaded from CPAN (in a multi-user system, this would typically + be within your own home directory). The existing system Perl installation is + not affected; you simply invoke Perl with special options so that Perl uses the + packages in your own local package directory rather than the system packages. + local::lib arranges things so that your locally installed version of the Perl + packages takes precedence over the system installation. + + If you are using a package management system (such as Debian), you don't need to + worry about Debian and CPAN stepping on each other's toes. Your local version + of the packages will be written to an entirely separate directory from those + installed by Debian. + + =head1 DESCRIPTION + + This module provides a quick, convenient way of bootstrapping a user-local Perl + module library located within the user's home directory. It also constructs and + prints out for the user the list of environment variables using the syntax + appropriate for the user's current shell (as specified by the C + environment variable), suitable for directly adding to one's shell + configuration file. + + More generally, local::lib allows for the bootstrapping and usage of a + directory containing Perl modules outside of Perl's C<@INC>. This makes it + easier to ship an application with an app-specific copy of a Perl module, or + collection of modules. Useful in cases like when an upstream maintainer hasn't + applied a patch to a module of theirs that you need for your application. + + On import, local::lib sets the following environment variables to appropriate + values: + + =over 4 + + =item PERL_MB_OPT + + =item PERL_MM_OPT + + =item PERL5LIB + + =item PATH + + =item PERL_LOCAL_LIB_ROOT + + =back + + When possible, these will be appended to instead of overwritten entirely. + + These values are then available for reference by any code after import. + + =head1 CREATING A SELF-CONTAINED SET OF MODULES + + See L for one way to do this - but note that + there are a number of caveats, and the best approach is always to perform a + build against a clean perl (i.e. site and vendor as close to empty as possible). + + =head1 IMPORT OPTIONS + + Options are values that can be passed to the C import besides the + directory to use. They are specified as C + or C. + + =head2 --deactivate + + Remove the chosen path (or the default path) from the module search paths if it + was added by C, instead of adding it. + + =head2 --deactivate-all + + Remove all directories that were added to search paths by C from the + search paths. + + =head2 --shelltype + + Specify the shell type to use for output. By default, the shell will be + detected based on the environment. Should be one of: C, C, + C, or C. + + =head2 --no-create + + Prevents C from creating directories when activating dirs. This is + likely to cause issues on Win32 systems. + + =head1 CLASS METHODS + + =head2 ensure_dir_structure_for + + =over 4 + + =item Arguments: $path + + =item Return value: None + + =back + + Attempts to create the given path, and all required parent directories. Throws + an exception on failure. + + =head2 print_environment_vars_for + + =over 4 + + =item Arguments: $path + + =item Return value: None + + =back + + Prints to standard output the variables listed above, properly set to use the + given path as the base directory. + + =head2 build_environment_vars_for + + =over 4 + + =item Arguments: $path + + =item Return value: %environment_vars + + =back + + Returns a hash with the variables listed above, properly set to use the + given path as the base directory. + + =head2 setup_env_hash_for + + =over 4 + + =item Arguments: $path + + =item Return value: None + + =back + + Constructs the C<%ENV> keys for the given path, by calling + L. + + =head2 active_paths + + =over 4 + + =item Arguments: None + + =item Return value: @paths + + =back + + Returns a list of active C paths, according to the + C environment variable and verified against + what is really in C<@INC>. + + =head2 install_base_perl_path + + =over 4 + + =item Arguments: $path + + =item Return value: $install_base_perl_path + + =back + + Returns a path describing where to install the Perl modules for this local + library installation. Appends the directories C and C to the given + path. + + =head2 lib_paths_for + + =over 4 + + =item Arguments: $path + + =item Return value: @lib_paths + + =back + + Returns the list of paths perl will search for libraries, given a base path. + This includes the base path itself, the architecture specific subdirectory, and + perl version specific subdirectories. These paths may not all exist. + + =head2 install_base_bin_path + + =over 4 + + =item Arguments: $path + + =item Return value: $install_base_bin_path + + =back + + Returns a path describing where to install the executable programs for this + local library installation. Appends the directory C to the given path. + + =head2 installer_options_for + + =over 4 + + =item Arguments: $path + + =item Return value: %installer_env_vars + + =back + + Returns a hash of environment variables that should be set to cause + installation into the given path. + + =head2 resolve_empty_path + + =over 4 + + =item Arguments: $path + + =item Return value: $base_path + + =back + + Builds and returns the base path into which to set up the local module + installation. Defaults to C<~/perl5>. + + =head2 resolve_home_path + + =over 4 + + =item Arguments: $path + + =item Return value: $home_path + + =back + + Attempts to find the user's home directory. If installed, uses C + for this purpose. If no definite answer is available, throws an exception. + + =head2 resolve_relative_path + + =over 4 + + =item Arguments: $path + + =item Return value: $absolute_path + + =back + + Translates the given path into an absolute path. + + =head2 resolve_path + + =over 4 + + =item Arguments: $path + + =item Return value: $absolute_path + + =back + + Calls the following in a pipeline, passing the result from the previous to the + next, in an attempt to find where to configure the environment for a local + library installation: L, L, + L. Passes the given path argument to + L which then returns a result that is passed to + L, which then has its result passed to + L. The result of this final call is returned from + L. + + =head1 OBJECT INTERFACE + + =head2 new + + =over 4 + + =item Arguments: %attributes + + =item Return value: $local_lib + + =back + + Constructs a new C object, representing the current state of + C<@INC> and the relevant environment variables. + + =head1 ATTRIBUTES + + =head2 roots + + An arrayref representing active C directories. + + =head2 inc + + An arrayref representing C<@INC>. + + =head2 libs + + An arrayref representing the PERL5LIB environment variable. + + =head2 bins + + An arrayref representing the PATH environment variable. + + =head2 extra + + A hashref of extra environment variables (e.g. C and + C) + + =head2 no_create + + If set, C will not try to create directories when activating them. + + =head1 OBJECT METHODS + + =head2 clone + + =over 4 + + =item Arguments: %attributes + + =item Return value: $local_lib + + =back + + Constructs a new C object based on the existing one, overriding the + specified attributes. + + =head2 activate + + =over 4 + + =item Arguments: $path + + =item Return value: $new_local_lib + + =back + + Constructs a new instance with the specified path active. + + =head2 deactivate + + =over 4 + + =item Arguments: $path + + =item Return value: $new_local_lib + + =back + + Constructs a new instance with the specified path deactivated. + + =head2 deactivate_all + + =over 4 + + =item Arguments: None + + =item Return value: $new_local_lib + + =back + + Constructs a new instance with all C directories deactivated. + + =head2 environment_vars_string + + =over 4 + + =item Arguments: [ $shelltype ] + + =item Return value: $shell_env_string + + =back + + Returns a string to set up the C, meant to be run by a shell. + + =head2 build_environment_vars + + =over 4 + + =item Arguments: None + + =item Return value: %environment_vars + + =back + + Returns a hash with the variables listed above, properly set to use the + given path as the base directory. + + =head2 setup_env_hash + + =over 4 + + =item Arguments: None + + =item Return value: None + + =back + + Constructs the C<%ENV> keys for the given path, by calling + L. + + =head2 setup_local_lib + + Constructs the C<%ENV> hash using L, and set up C<@INC>. + + =head1 A WARNING ABOUT UNINST=1 + + Be careful about using local::lib in combination with "make install UNINST=1". + The idea of this feature is that will uninstall an old version of a module + before installing a new one. However it lacks a safety check that the old + version and the new version will go in the same directory. Used in combination + with local::lib, you can potentially delete a globally accessible version of a + module while installing the new version in a local place. Only combine "make + install UNINST=1" and local::lib if you understand these possible consequences. + + =head1 LIMITATIONS + + =over 4 + + =item * Directory names with spaces in them are not well supported by the perl + toolchain and the programs it uses. Pure-perl distributions should support + spaces, but problems are more likely with dists that require compilation. A + workaround you can do is moving your local::lib to a directory with spaces + B you installed all modules inside your local::lib bootstrap. But be + aware that you can't update or install CPAN modules after the move. + + =item * Rather basic shell detection. Right now anything with csh in its name is + assumed to be a C shell or something compatible, and everything else is assumed + to be Bourne, except on Win32 systems. If the C environment variable is + not set, a Bourne-compatible shell is assumed. + + =item * Kills any existing PERL_MM_OPT or PERL_MB_OPT. + + =item * Should probably auto-fixup CPAN config if not already done. + + =item * On VMS and MacOS Classic (pre-OS X), local::lib loads L. + This means any L version installed in the local::lib will be + ignored by scripts using local::lib. A workaround for this is using + C instead of using C directly. + + =item * Conflicts with L's C option. + C uses the C option, as it has more predictable and + sane behavior. If something attempts to use the C option when running + a F, L will refuse to run, as the two + options conflict. This can be worked around by temporarily unsetting the + C environment variable. + + =item * Conflicts with L's C<--prefix> option. Similar to the + previous limitation, but any C<--prefix> option specified will be ignored. + This can be worked around by temporarily unsetting the C + environment variable. + + =back + + Patches very much welcome for any of the above. + + =over 4 + + =item * On Win32 systems, does not have a way to write the created environment + variables to the registry, so that they can persist through a reboot. + + =back + + =head1 TROUBLESHOOTING + + If you've configured local::lib to install CPAN modules somewhere in to your + home directory, and at some point later you try to install a module with C, but it fails with an error like: C and buried within the install log is an + error saying C<'INSTALL_BASE' is not a known MakeMaker parameter name>, then + you've somehow lost your updated ExtUtils::MakeMaker module. + + To remedy this situation, rerun the bootstrapping procedure documented above. + + Then, run C + + Finally, re-run C and it should install without problems. + + =head1 ENVIRONMENT + + =over 4 + + =item SHELL + + =item COMSPEC + + local::lib looks at the user's C environment variable when printing out + commands to add to the shell configuration file. + + On Win32 systems, C is also examined. + + =back + + =head1 SEE ALSO + + =over 4 + + =item * L + + =back + + =head1 SUPPORT + + IRC: + + Join #local-lib on irc.perl.org. + + =head1 AUTHOR + + Matt S Trout http://www.shadowcat.co.uk/ + + auto_install fixes kindly sponsored by http://www.takkle.com/ + + =head1 CONTRIBUTORS + + Patches to correctly output commands for csh style shells, as well as some + documentation additions, contributed by Christopher Nehren . + + Doc patches for a custom local::lib directory, more cleanups in the english + documentation and a L contributed by + Torsten Raudssus . + + Hans Dieter Pearcey sent in some additional tests for ensuring + things will install properly, submitted a fix for the bug causing problems with + writing Makefiles during bootstrapping, contributed an example program, and + submitted yet another fix to ensure that local::lib can install and bootstrap + properly. Many, many thanks! + + pattern of Freenode IRC contributed the beginnings of the Troubleshooting + section. Many thanks! + + Patch to add Win32 support contributed by Curtis Jewell . + + Warnings for missing PATH/PERL5LIB (as when not running interactively) silenced + by a patch from Marco Emilio Poleggi. + + Mark Stosberg provided the code for the now deleted + '--self-contained' option. + + Documentation patches to make win32 usage clearer by + David Mertens (run4flat). + + Brazilian L and minor doc + patches contributed by Breno G. de Oliveira . + + Improvements to stacking multiple local::lib dirs and removing them from the + environment later on contributed by Andrew Rodland . + + Patch for Carp version mismatch contributed by Hakim Cassimally + . + + Rewrite of internals and numerous bug fixes and added features contributed by + Graham Knop . + + =head1 COPYRIGHT + + Copyright (c) 2007 - 2013 the local::lib L and L as + listed above. + + =head1 LICENSE + + This is free software; you can redistribute it and/or modify it under + the same terms as the Perl 5 programming language system itself. + + =cut + LOCAL_LIB + + $fatpacked{"parent.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PARENT'; + package parent; + use strict; + use vars qw($VERSION); + $VERSION = '0.228'; + + sub import { + my $class = shift; + + my $inheritor = caller(0); + + if ( @_ and $_[0] eq '-norequire' ) { + shift @_; + } else { + for ( my @filename = @_ ) { + if ( $_ eq $inheritor ) { + warn "Class '$inheritor' tried to inherit from itself\n"; + }; + + s{::|'}{/}g; + require "$_.pm"; # dies if the file is not found + } + } + + { + no strict 'refs'; + push @{"$inheritor\::ISA"}, @_; + }; + }; + + "All your base are belong to us" + + __END__ + + =encoding utf8 + + =head1 NAME + + parent - Establish an ISA relationship with base classes at compile time + + =head1 SYNOPSIS + + package Baz; + use parent qw(Foo Bar); + + =head1 DESCRIPTION + + Allows you to both load one or more modules, while setting up inheritance from + those modules at the same time. Mostly similar in effect to + + package Baz; + BEGIN { + require Foo; + require Bar; + push @ISA, qw(Foo Bar); + } + + By default, every base class needs to live in a file of its own. + If you want to have a subclass and its parent class in the same file, you + can tell C not to load any modules by using the C<-norequire> switch: + + package Foo; + sub exclaim { "I CAN HAS PERL" } + + package DoesNotLoadFooBar; + use parent -norequire, 'Foo', 'Bar'; + # will not go looking for Foo.pm or Bar.pm + + This is equivalent to the following code: + + package Foo; + sub exclaim { "I CAN HAS PERL" } + + package DoesNotLoadFooBar; + push @DoesNotLoadFooBar::ISA, 'Foo', 'Bar'; + + This is also helpful for the case where a package lives within + a differently named file: + + package MyHash; + use Tie::Hash; + use parent -norequire, 'Tie::StdHash'; + + This is equivalent to the following code: + + package MyHash; + require Tie::Hash; + push @ISA, 'Tie::StdHash'; + + If you want to load a subclass from a file that C would + not consider an eligible filename (that is, it does not end in + either C<.pm> or C<.pmc>), use the following code: + + package MySecondPlugin; + require './plugins/custom.plugin'; # contains Plugin::Custom + use parent -norequire, 'Plugin::Custom'; + + =head1 DIAGNOSTICS + + =over 4 + + =item Class 'Foo' tried to inherit from itself + + Attempting to inherit from yourself generates a warning. + + package Foo; + use parent 'Foo'; + + =back + + =head1 HISTORY + + This module was forked from L to remove the cruft + that had accumulated in it. + + =head1 CAVEATS + + =head1 SEE ALSO + + L + + =head1 AUTHORS AND CONTRIBUTORS + + Rafaël Garcia-Suarez, Bart Lateur, Max Maischein, Anno Siegel, Michael Schwern + + =head1 MAINTAINER + + Max Maischein C< corion@cpan.org > + + Copyright (c) 2007-10 Max Maischein C<< >> + Based on the idea of C, which was introduced with Perl 5.004_04. + + =head1 LICENSE + + This module is released under the same terms as Perl itself. + + =cut + PARENT + + $fatpacked{"version.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'VERSION'; + #!perl -w + package version; + + use 5.006002; + use strict; + use warnings::register; + if ($] >= 5.015) { + warnings::register_categories(qw/version/); + } + + use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv); + + $VERSION = 0.9912; + $CLASS = 'version'; + + # !!!!Delete this next block completely when adding to Perl core!!!! + { + local $SIG{'__DIE__'}; + if (1) { # always pretend there's no XS + eval "use version::vpp $VERSION"; # don't tempt fate + die "$@" if ( $@ ); + push @ISA, "version::vpp"; + local $^W; + *version::qv = \&version::vpp::qv; + *version::declare = \&version::vpp::declare; + *version::_VERSION = \&version::vpp::_VERSION; + *version::vcmp = \&version::vpp::vcmp; + *version::new = \&version::vpp::new; + *version::numify = \&version::vpp::numify; + *version::normal = \&version::vpp::normal; + if ($] >= 5.009000) { + no strict 'refs'; + *version::stringify = \&version::vpp::stringify; + *{'version::(""'} = \&version::vpp::stringify; + *{'version::(<=>'} = \&version::vpp::vcmp; + *version::parse = \&version::vpp::parse; + } + } + else { # use XS module + push @ISA, "version::vxs"; + local $^W; + *version::declare = \&version::vxs::declare; + *version::qv = \&version::vxs::qv; + *version::_VERSION = \&version::vxs::_VERSION; + *version::vcmp = \&version::vxs::VCMP; + *version::new = \&version::vxs::new; + *version::numify = \&version::vxs::numify; + *version::normal = \&version::vxs::normal; + if ($] >= 5.009000) { + no strict 'refs'; + *version::stringify = \&version::vxs::stringify; + *{'version::(""'} = \&version::vxs::stringify; + *{'version::(<=>'} = \&version::vxs::VCMP; + *version::parse = \&version::vxs::parse; + } + } + } + + # avoid using Exporter + require version::regex; + *version::is_lax = \&version::regex::is_lax; + *version::is_strict = \&version::regex::is_strict; + *LAX = \$version::regex::LAX; + *STRICT = \$version::regex::STRICT; + + sub import { + no strict 'refs'; + my ($class) = shift; + + # Set up any derived class + unless ($class eq $CLASS) { + local $^W; + *{$class.'::declare'} = \&{$CLASS.'::declare'}; + *{$class.'::qv'} = \&{$CLASS.'::qv'}; + } + + my %args; + if (@_) { # any remaining terms are arguments + map { $args{$_} = 1 } @_ + } + else { # no parameters at all on use line + %args = + ( + qv => 1, + 'UNIVERSAL::VERSION' => 1, + ); + } + + my $callpkg = caller(); + + if (exists($args{declare})) { + *{$callpkg.'::declare'} = + sub {return $class->declare(shift) } + unless defined(&{$callpkg.'::declare'}); + } + + if (exists($args{qv})) { + *{$callpkg.'::qv'} = + sub {return $class->qv(shift) } + unless defined(&{$callpkg.'::qv'}); + } + + if (exists($args{'UNIVERSAL::VERSION'})) { + local $^W; + *UNIVERSAL::VERSION + = \&{$CLASS.'::_VERSION'}; + } + + if (exists($args{'VERSION'})) { + *{$callpkg.'::VERSION'} = \&{$CLASS.'::_VERSION'}; + } + + if (exists($args{'is_strict'})) { + *{$callpkg.'::is_strict'} = \&{$CLASS.'::is_strict'} + unless defined(&{$callpkg.'::is_strict'}); + } + + if (exists($args{'is_lax'})) { + *{$callpkg.'::is_lax'} = \&{$CLASS.'::is_lax'} + unless defined(&{$callpkg.'::is_lax'}); + } + } + + + 1; + VERSION + + $fatpacked{"version/regex.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'VERSION_REGEX'; + package version::regex; + + use strict; + + use vars qw($VERSION $CLASS $STRICT $LAX); + + $VERSION = 0.9912; + + #--------------------------------------------------------------------------# + # Version regexp components + #--------------------------------------------------------------------------# + + # Fraction part of a decimal version number. This is a common part of + # both strict and lax decimal versions + + my $FRACTION_PART = qr/\.[0-9]+/; + + # First part of either decimal or dotted-decimal strict version number. + # Unsigned integer with no leading zeroes (except for zero itself) to + # avoid confusion with octal. + + my $STRICT_INTEGER_PART = qr/0|[1-9][0-9]*/; + + # First part of either decimal or dotted-decimal lax version number. + # Unsigned integer, but allowing leading zeros. Always interpreted + # as decimal. However, some forms of the resulting syntax give odd + # results if used as ordinary Perl expressions, due to how perl treats + # octals. E.g. + # version->new("010" ) == 10 + # version->new( 010 ) == 8 + # version->new( 010.2) == 82 # "8" . "2" + + my $LAX_INTEGER_PART = qr/[0-9]+/; + + # Second and subsequent part of a strict dotted-decimal version number. + # Leading zeroes are permitted, and the number is always decimal. + # Limited to three digits to avoid overflow when converting to decimal + # form and also avoid problematic style with excessive leading zeroes. + + my $STRICT_DOTTED_DECIMAL_PART = qr/\.[0-9]{1,3}/; + + # Second and subsequent part of a lax dotted-decimal version number. + # Leading zeroes are permitted, and the number is always decimal. No + # limit on the numerical value or number of digits, so there is the + # possibility of overflow when converting to decimal form. + + my $LAX_DOTTED_DECIMAL_PART = qr/\.[0-9]+/; + + # Alpha suffix part of lax version number syntax. Acts like a + # dotted-decimal part. + + my $LAX_ALPHA_PART = qr/_[0-9]+/; + + #--------------------------------------------------------------------------# + # Strict version regexp definitions + #--------------------------------------------------------------------------# + + # Strict decimal version number. + + my $STRICT_DECIMAL_VERSION = + qr/ $STRICT_INTEGER_PART $FRACTION_PART? /x; + + # Strict dotted-decimal version number. Must have both leading "v" and + # at least three parts, to avoid confusion with decimal syntax. + + my $STRICT_DOTTED_DECIMAL_VERSION = + qr/ v $STRICT_INTEGER_PART $STRICT_DOTTED_DECIMAL_PART{2,} /x; + + # Complete strict version number syntax -- should generally be used + # anchored: qr/ \A $STRICT \z /x + + $STRICT = + qr/ $STRICT_DECIMAL_VERSION | $STRICT_DOTTED_DECIMAL_VERSION /x; + + #--------------------------------------------------------------------------# + # Lax version regexp definitions + #--------------------------------------------------------------------------# + + # Lax decimal version number. Just like the strict one except for + # allowing an alpha suffix or allowing a leading or trailing + # decimal-point + + my $LAX_DECIMAL_VERSION = + qr/ $LAX_INTEGER_PART (?: \. | $FRACTION_PART $LAX_ALPHA_PART? )? + | + $FRACTION_PART $LAX_ALPHA_PART? + /x; + + # Lax dotted-decimal version number. Distinguished by having either + # leading "v" or at least three non-alpha parts. Alpha part is only + # permitted if there are at least two non-alpha parts. Strangely + # enough, without the leading "v", Perl takes .1.2 to mean v0.1.2, + # so when there is no "v", the leading part is optional + + my $LAX_DOTTED_DECIMAL_VERSION = + qr/ + v $LAX_INTEGER_PART (?: $LAX_DOTTED_DECIMAL_PART+ $LAX_ALPHA_PART? )? + | + $LAX_INTEGER_PART? $LAX_DOTTED_DECIMAL_PART{2,} $LAX_ALPHA_PART? + /x; + + # Complete lax version number syntax -- should generally be used + # anchored: qr/ \A $LAX \z /x + # + # The string 'undef' is a special case to make for easier handling + # of return values from ExtUtils::MM->parse_version + + $LAX = + qr/ undef | $LAX_DECIMAL_VERSION | $LAX_DOTTED_DECIMAL_VERSION /x; + + #--------------------------------------------------------------------------# + + # Preloaded methods go here. + sub is_strict { defined $_[0] && $_[0] =~ qr/ \A $STRICT \z /x } + sub is_lax { defined $_[0] && $_[0] =~ qr/ \A $LAX \z /x } + + 1; + VERSION_REGEX + + $fatpacked{"version/vpp.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'VERSION_VPP'; + package charstar; + # a little helper class to emulate C char* semantics in Perl + # so that prescan_version can use the same code as in C + + use overload ( + '""' => \&thischar, + '0+' => \&thischar, + '++' => \&increment, + '--' => \&decrement, + '+' => \&plus, + '-' => \&minus, + '*' => \&multiply, + 'cmp' => \&cmp, + '<=>' => \&spaceship, + 'bool' => \&thischar, + '=' => \&clone, + ); + + sub new { + my ($self, $string) = @_; + my $class = ref($self) || $self; + + my $obj = { + string => [split(//,$string)], + current => 0, + }; + return bless $obj, $class; + } + + sub thischar { + my ($self) = @_; + my $last = $#{$self->{string}}; + my $curr = $self->{current}; + if ($curr >= 0 && $curr <= $last) { + return $self->{string}->[$curr]; + } + else { + return ''; + } + } + + sub increment { + my ($self) = @_; + $self->{current}++; + } + + sub decrement { + my ($self) = @_; + $self->{current}--; + } + + sub plus { + my ($self, $offset) = @_; + my $rself = $self->clone; + $rself->{current} += $offset; + return $rself; + } + + sub minus { + my ($self, $offset) = @_; + my $rself = $self->clone; + $rself->{current} -= $offset; + return $rself; + } + + sub multiply { + my ($left, $right, $swapped) = @_; + my $char = $left->thischar(); + return $char * $right; + } + + sub spaceship { + my ($left, $right, $swapped) = @_; + unless (ref($right)) { # not an object already + $right = $left->new($right); + } + return $left->{current} <=> $right->{current}; + } + + sub cmp { + my ($left, $right, $swapped) = @_; + unless (ref($right)) { # not an object already + if (length($right) == 1) { # comparing single character only + return $left->thischar cmp $right; + } + $right = $left->new($right); + } + return $left->currstr cmp $right->currstr; + } + + sub bool { + my ($self) = @_; + my $char = $self->thischar; + return ($char ne ''); + } + + sub clone { + my ($left, $right, $swapped) = @_; + $right = { + string => [@{$left->{string}}], + current => $left->{current}, + }; + return bless $right, ref($left); + } + + sub currstr { + my ($self, $s) = @_; + my $curr = $self->{current}; + my $last = $#{$self->{string}}; + if (defined($s) && $s->{current} < $last) { + $last = $s->{current}; + } + + my $string = join('', @{$self->{string}}[$curr..$last]); + return $string; + } + + package version::vpp; + + use 5.006002; + use strict; + use warnings::register; + + use Config; + use vars qw($VERSION $CLASS @ISA $LAX $STRICT $WARN_CATEGORY); + $VERSION = 0.9912; + $CLASS = 'version::vpp'; + if ($] > 5.015) { + warnings::register_categories(qw/version/); + $WARN_CATEGORY = 'version'; + } else { + $WARN_CATEGORY = 'numeric'; + } + + require version::regex; + *version::vpp::is_strict = \&version::regex::is_strict; + *version::vpp::is_lax = \&version::regex::is_lax; + *LAX = \$version::regex::LAX; + *STRICT = \$version::regex::STRICT; + + use overload ( + '""' => \&stringify, + '0+' => \&numify, + 'cmp' => \&vcmp, + '<=>' => \&vcmp, + 'bool' => \&vbool, + '+' => \&vnoop, + '-' => \&vnoop, + '*' => \&vnoop, + '/' => \&vnoop, + '+=' => \&vnoop, + '-=' => \&vnoop, + '*=' => \&vnoop, + '/=' => \&vnoop, + 'abs' => \&vnoop, + ); + + sub import { + no strict 'refs'; + my ($class) = shift; + + # Set up any derived class + unless ($class eq $CLASS) { + local $^W; + *{$class.'::declare'} = \&{$CLASS.'::declare'}; + *{$class.'::qv'} = \&{$CLASS.'::qv'}; + } + + my %args; + if (@_) { # any remaining terms are arguments + map { $args{$_} = 1 } @_ + } + else { # no parameters at all on use line + %args = + ( + qv => 1, + 'UNIVERSAL::VERSION' => 1, + ); + } + + my $callpkg = caller(); + + if (exists($args{declare})) { + *{$callpkg.'::declare'} = + sub {return $class->declare(shift) } + unless defined(&{$callpkg.'::declare'}); + } + + if (exists($args{qv})) { + *{$callpkg.'::qv'} = + sub {return $class->qv(shift) } + unless defined(&{$callpkg.'::qv'}); + } + + if (exists($args{'UNIVERSAL::VERSION'})) { + no warnings qw/redefine/; + *UNIVERSAL::VERSION + = \&{$CLASS.'::_VERSION'}; + } + + if (exists($args{'VERSION'})) { + *{$callpkg.'::VERSION'} = \&{$CLASS.'::_VERSION'}; + } + + if (exists($args{'is_strict'})) { + *{$callpkg.'::is_strict'} = \&{$CLASS.'::is_strict'} + unless defined(&{$callpkg.'::is_strict'}); + } + + if (exists($args{'is_lax'})) { + *{$callpkg.'::is_lax'} = \&{$CLASS.'::is_lax'} + unless defined(&{$callpkg.'::is_lax'}); + } + } + + my $VERSION_MAX = 0x7FFFFFFF; + + # implement prescan_version as closely to the C version as possible + use constant TRUE => 1; + use constant FALSE => 0; + + sub isDIGIT { + my ($char) = shift->thischar(); + return ($char =~ /\d/); + } + + sub isALPHA { + my ($char) = shift->thischar(); + return ($char =~ /[a-zA-Z]/); + } + + sub isSPACE { + my ($char) = shift->thischar(); + return ($char =~ /\s/); + } + + sub BADVERSION { + my ($s, $errstr, $error) = @_; + if ($errstr) { + $$errstr = $error; + } + return $s; + } + + sub prescan_version { + my ($s, $strict, $errstr, $sqv, $ssaw_decimal, $swidth, $salpha) = @_; + my $qv = defined $sqv ? $$sqv : FALSE; + my $saw_decimal = defined $ssaw_decimal ? $$ssaw_decimal : 0; + my $width = defined $swidth ? $$swidth : 3; + my $alpha = defined $salpha ? $$salpha : FALSE; + + my $d = $s; + + if ($qv && isDIGIT($d)) { + goto dotted_decimal_version; + } + + if ($d eq 'v') { # explicit v-string + $d++; + if (isDIGIT($d)) { + $qv = TRUE; + } + else { # degenerate v-string + # requires v1.2.3 + return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); + } + + dotted_decimal_version: + if ($strict && $d eq '0' && isDIGIT($d+1)) { + # no leading zeros allowed + return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)"); + } + + while (isDIGIT($d)) { # integer part + $d++; + } + + if ($d eq '.') + { + $saw_decimal++; + $d++; # decimal point + } + else + { + if ($strict) { + # require v1.2.3 + return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); + } + else { + goto version_prescan_finish; + } + } + + { + my $i = 0; + my $j = 0; + while (isDIGIT($d)) { # just keep reading + $i++; + while (isDIGIT($d)) { + $d++; $j++; + # maximum 3 digits between decimal + if ($strict && $j > 3) { + return BADVERSION($s,$errstr,"Invalid version format (maximum 3 digits between decimals)"); + } + } + if ($d eq '_') { + if ($strict) { + return BADVERSION($s,$errstr,"Invalid version format (no underscores)"); + } + if ( $alpha ) { + return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)"); + } + $d++; + $alpha = TRUE; + } + elsif ($d eq '.') { + if ($alpha) { + return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)"); + } + $saw_decimal++; + $d++; + } + elsif (!isDIGIT($d)) { + last; + } + $j = 0; + } + + if ($strict && $i < 2) { + # requires v1.2.3 + return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); + } + } + } # end if dotted-decimal + else + { # decimal versions + my $j = 0; + # special $strict case for leading '.' or '0' + if ($strict) { + if ($d eq '.') { + return BADVERSION($s,$errstr,"Invalid version format (0 before decimal required)"); + } + if ($d eq '0' && isDIGIT($d+1)) { + return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)"); + } + } + + # and we never support negative version numbers + if ($d eq '-') { + return BADVERSION($s,$errstr,"Invalid version format (negative version number)"); + } + + # consume all of the integer part + while (isDIGIT($d)) { + $d++; + } + + # look for a fractional part + if ($d eq '.') { + # we found it, so consume it + $saw_decimal++; + $d++; + } + elsif (!$d || $d eq ';' || isSPACE($d) || $d eq '}') { + if ( $d == $s ) { + # found nothing + return BADVERSION($s,$errstr,"Invalid version format (version required)"); + } + # found just an integer + goto version_prescan_finish; + } + elsif ( $d == $s ) { + # didn't find either integer or period + return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)"); + } + elsif ($d eq '_') { + # underscore can't come after integer part + if ($strict) { + return BADVERSION($s,$errstr,"Invalid version format (no underscores)"); + } + elsif (isDIGIT($d+1)) { + return BADVERSION($s,$errstr,"Invalid version format (alpha without decimal)"); + } + else { + return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)"); + } + } + elsif ($d) { + # anything else after integer part is just invalid data + return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)"); + } + + # scan the fractional part after the decimal point + if ($d && !isDIGIT($d) && ($strict || ! ($d eq ';' || isSPACE($d) || $d eq '}') )) { + # $strict or lax-but-not-the-end + return BADVERSION($s,$errstr,"Invalid version format (fractional part required)"); + } + + while (isDIGIT($d)) { + $d++; $j++; + if ($d eq '.' && isDIGIT($d-1)) { + if ($alpha) { + return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)"); + } + if ($strict) { + return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions must begin with 'v')"); + } + $d = $s; # start all over again + $qv = TRUE; + goto dotted_decimal_version; + } + if ($d eq '_') { + if ($strict) { + return BADVERSION($s,$errstr,"Invalid version format (no underscores)"); + } + if ( $alpha ) { + return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)"); + } + if ( ! isDIGIT($d+1) ) { + return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)"); + } + $width = $j; + $d++; + $alpha = TRUE; + } + } + } + + version_prescan_finish: + while (isSPACE($d)) { + $d++; + } + + if ($d && !isDIGIT($d) && (! ($d eq ';' || $d eq '}') )) { + # trailing non-numeric data + return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)"); + } + if ($saw_decimal > 1 && ($d-1) eq '.') { + # no trailing period allowed + return BADVERSION($s,$errstr,"Invalid version format (trailing decimal)"); + } + + if (defined $sqv) { + $$sqv = $qv; + } + if (defined $swidth) { + $$swidth = $width; + } + if (defined $ssaw_decimal) { + $$ssaw_decimal = $saw_decimal; + } + if (defined $salpha) { + $$salpha = $alpha; + } + return $d; + } + + sub scan_version { + my ($s, $rv, $qv) = @_; + my $start; + my $pos; + my $last; + my $errstr; + my $saw_decimal = 0; + my $width = 3; + my $alpha = FALSE; + my $vinf = FALSE; + my @av; + + $s = new charstar $s; + + while (isSPACE($s)) { # leading whitespace is OK + $s++; + } + + $last = prescan_version($s, FALSE, \$errstr, \$qv, \$saw_decimal, + \$width, \$alpha); + + if ($errstr) { + # 'undef' is a special case and not an error + if ( $s ne 'undef') { + require Carp; + Carp::croak($errstr); + } + } + + $start = $s; + if ($s eq 'v') { + $s++; + } + $pos = $s; + + if ( $qv ) { + $$rv->{qv} = $qv; + } + if ( $alpha ) { + $$rv->{alpha} = $alpha; + } + if ( !$qv && $width < 3 ) { + $$rv->{width} = $width; + } + + while (isDIGIT($pos)) { + $pos++; + } + if (!isALPHA($pos)) { + my $rev; + + for (;;) { + $rev = 0; + { + # this is atoi() that delimits on underscores + my $end = $pos; + my $mult = 1; + my $orev; + + # the following if() will only be true after the decimal + # point of a version originally created with a bare + # floating point number, i.e. not quoted in any way + # + if ( !$qv && $s > $start && $saw_decimal == 1 ) { + $mult *= 100; + while ( $s < $end ) { + $orev = $rev; + $rev += $s * $mult; + $mult /= 10; + if ( (abs($orev) > abs($rev)) + || (abs($rev) > $VERSION_MAX )) { + warn("Integer overflow in version %d", + $VERSION_MAX); + $s = $end - 1; + $rev = $VERSION_MAX; + $vinf = 1; + } + $s++; + if ( $s eq '_' ) { + $s++; + } + } + } + else { + while (--$end >= $s) { + $orev = $rev; + $rev += $end * $mult; + $mult *= 10; + if ( (abs($orev) > abs($rev)) + || (abs($rev) > $VERSION_MAX )) { + warn("Integer overflow in version"); + $end = $s - 1; + $rev = $VERSION_MAX; + $vinf = 1; + } + } + } + } + + # Append revision + push @av, $rev; + if ( $vinf ) { + $s = $last; + last; + } + elsif ( $pos eq '.' ) { + $pos++; + if ($qv) { + # skip leading zeros + while ($pos eq '0') { + $pos++; + } + } + $s = $pos; + } + elsif ( $pos eq '_' && isDIGIT($pos+1) ) { + $s = ++$pos; + } + elsif ( $pos eq ',' && isDIGIT($pos+1) ) { + $s = ++$pos; + } + elsif ( isDIGIT($pos) ) { + $s = $pos; + } + else { + $s = $pos; + last; + } + if ( $qv ) { + while ( isDIGIT($pos) ) { + $pos++; + } + } + else { + my $digits = 0; + while ( ( isDIGIT($pos) || $pos eq '_' ) && $digits < 3 ) { + if ( $pos ne '_' ) { + $digits++; + } + $pos++; + } + } + } + } + if ( $qv ) { # quoted versions always get at least three terms + my $len = $#av; + # This for loop appears to trigger a compiler bug on OS X, as it + # loops infinitely. Yes, len is negative. No, it makes no sense. + # Compiler in question is: + # gcc version 3.3 20030304 (Apple Computer, Inc. build 1640) + # for ( len = 2 - len; len > 0; len-- ) + # av_push(MUTABLE_AV(sv), newSViv(0)); + # + $len = 2 - $len; + while ($len-- > 0) { + push @av, 0; + } + } + + # need to save off the current version string for later + if ( $vinf ) { + $$rv->{original} = "v.Inf"; + $$rv->{vinf} = 1; + } + elsif ( $s > $start ) { + $$rv->{original} = $start->currstr($s); + if ( $qv && $saw_decimal == 1 && $start ne 'v' ) { + # need to insert a v to be consistent + $$rv->{original} = 'v' . $$rv->{original}; + } + } + else { + $$rv->{original} = '0'; + push(@av, 0); + } + + # And finally, store the AV in the hash + $$rv->{version} = \@av; + + # fix RT#19517 - special case 'undef' as string + if ($s eq 'undef') { + $s += 5; + } + + return $s; + } + + sub new { + my $class = shift; + unless (defined $class or $#_ > 1) { + require Carp; + Carp::croak('Usage: version::new(class, version)'); + } + + my $self = bless ({}, ref ($class) || $class); + my $qv = FALSE; + + if ( $#_ == 1 ) { # must be CVS-style + $qv = TRUE; + } + my $value = pop; # always going to be the last element + + if ( ref($value) && eval('$value->isa("version")') ) { + # Can copy the elements directly + $self->{version} = [ @{$value->{version} } ]; + $self->{qv} = 1 if $value->{qv}; + $self->{alpha} = 1 if $value->{alpha}; + $self->{original} = ''.$value->{original}; + return $self; + } + + if ( not defined $value or $value =~ /^undef$/ ) { + # RT #19517 - special case for undef comparison + # or someone forgot to pass a value + push @{$self->{version}}, 0; + $self->{original} = "0"; + return ($self); + } + + + if (ref($value) =~ m/ARRAY|HASH/) { + require Carp; + Carp::croak("Invalid version format (non-numeric data)"); + } + + $value = _un_vstring($value); + + if ($Config{d_setlocale}) { + use POSIX qw/locale_h/; + use if $Config{d_setlocale}, 'locale'; + my $currlocale = setlocale(LC_ALL); + + # if the current locale uses commas for decimal points, we + # just replace commas with decimal places, rather than changing + # locales + if ( localeconv()->{decimal_point} eq ',' ) { + $value =~ tr/,/./; + } + } + + # exponential notation + if ( $value =~ /\d+.?\d*e[-+]?\d+/ ) { + $value = sprintf("%.9f",$value); + $value =~ s/(0+)$//; # trim trailing zeros + } + + my $s = scan_version($value, \$self, $qv); + + if ($s) { # must be something left over + warn("Version string '%s' contains invalid data; " + ."ignoring: '%s'", $value, $s); + } + + return ($self); + } + + *parse = \&new; + + sub numify { + my ($self) = @_; + unless (_verify($self)) { + require Carp; + Carp::croak("Invalid version object"); + } + my $width = $self->{width} || 3; + my $alpha = $self->{alpha} || ""; + my $len = $#{$self->{version}}; + my $digit = $self->{version}[0]; + my $string = sprintf("%d.", $digit ); + + if ($alpha and warnings::enabled()) { + warnings::warn($WARN_CATEGORY, 'alpha->numify() is lossy'); + } + + for ( my $i = 1 ; $i < $len ; $i++ ) { + $digit = $self->{version}[$i]; + if ( $width < 3 ) { + my $denom = 10**(3-$width); + my $quot = int($digit/$denom); + my $rem = $digit - ($quot * $denom); + $string .= sprintf("%0".$width."d_%d", $quot, $rem); + } + else { + $string .= sprintf("%03d", $digit); + } + } + + if ( $len > 0 ) { + $digit = $self->{version}[$len]; + if ( $alpha && $width == 3 ) { + $string .= "_"; + } + $string .= sprintf("%0".$width."d", $digit); + } + else # $len = 0 + { + $string .= sprintf("000"); + } + + return $string; + } + + sub normal { + my ($self) = @_; + unless (_verify($self)) { + require Carp; + Carp::croak("Invalid version object"); + } + my $alpha = $self->{alpha} || ""; + my $qv = $self->{qv} || ""; + + my $len = $#{$self->{version}}; + my $digit = $self->{version}[0]; + my $string = sprintf("v%d", $digit ); + + for ( my $i = 1 ; $i < $len ; $i++ ) { + $digit = $self->{version}[$i]; + $string .= sprintf(".%d", $digit); + } + + if ( $len > 0 ) { + $digit = $self->{version}[$len]; + if ( $alpha ) { + $string .= sprintf("_%0d", $digit); + } + else { + $string .= sprintf(".%0d", $digit); + } + } + + if ( $len <= 2 ) { + for ( $len = 2 - $len; $len != 0; $len-- ) { + $string .= sprintf(".%0d", 0); + } + } + + return $string; + } + + sub stringify { + my ($self) = @_; + unless (_verify($self)) { + require Carp; + Carp::croak("Invalid version object"); + } + return exists $self->{original} + ? $self->{original} + : exists $self->{qv} + ? $self->normal + : $self->numify; + } + + sub vcmp { + require UNIVERSAL; + my ($left,$right,$swap) = @_; + my $class = ref($left); + unless ( UNIVERSAL::isa($right, $class) ) { + $right = $class->new($right); + } + + if ( $swap ) { + ($left, $right) = ($right, $left); + } + unless (_verify($left)) { + require Carp; + Carp::croak("Invalid version object"); + } + unless (_verify($right)) { + require Carp; + Carp::croak("Invalid version format"); + } + my $l = $#{$left->{version}}; + my $r = $#{$right->{version}}; + my $m = $l < $r ? $l : $r; + my $lalpha = $left->is_alpha; + my $ralpha = $right->is_alpha; + my $retval = 0; + my $i = 0; + while ( $i <= $m && $retval == 0 ) { + $retval = $left->{version}[$i] <=> $right->{version}[$i]; + $i++; + } + + # tiebreaker for alpha with identical terms + if ( $retval == 0 + && $l == $r + && $left->{version}[$m] == $right->{version}[$m] + && ( $lalpha || $ralpha ) ) { + + if ( $lalpha && !$ralpha ) { + $retval = -1; + } + elsif ( $ralpha && !$lalpha) { + $retval = +1; + } + } + + # possible match except for trailing 0's + if ( $retval == 0 && $l != $r ) { + if ( $l < $r ) { + while ( $i <= $r && $retval == 0 ) { + if ( $right->{version}[$i] != 0 ) { + $retval = -1; # not a match after all + } + $i++; + } + } + else { + while ( $i <= $l && $retval == 0 ) { + if ( $left->{version}[$i] != 0 ) { + $retval = +1; # not a match after all + } + $i++; + } + } + } + + return $retval; + } + + sub vbool { + my ($self) = @_; + return vcmp($self,$self->new("0"),1); + } + + sub vnoop { + require Carp; + Carp::croak("operation not supported with version object"); + } + + sub is_alpha { + my ($self) = @_; + return (exists $self->{alpha}); + } + + sub qv { + my $value = shift; + my $class = $CLASS; + if (@_) { + $class = ref($value) || $value; + $value = shift; + } + + $value = _un_vstring($value); + $value = 'v'.$value unless $value =~ /(^v|\d+\.\d+\.\d)/; + my $obj = $CLASS->new($value); + return bless $obj, $class; + } + + *declare = \&qv; + + sub is_qv { + my ($self) = @_; + return (exists $self->{qv}); + } + + + sub _verify { + my ($self) = @_; + if ( ref($self) + && eval { exists $self->{version} } + && ref($self->{version}) eq 'ARRAY' + ) { + return 1; + } + else { + return 0; + } + } + + sub _is_non_alphanumeric { + my $s = shift; + $s = new charstar $s; + while ($s) { + return 0 if isSPACE($s); # early out + return 1 unless (isALPHA($s) || isDIGIT($s) || $s =~ /[.-]/); + $s++; + } + return 0; + } + + sub _un_vstring { + my $value = shift; + # may be a v-string + if ( length($value) >= 1 && $value !~ /[,._]/ + && _is_non_alphanumeric($value)) { + my $tvalue; + if ( $] >= 5.008_001 ) { + $tvalue = _find_magic_vstring($value); + $value = $tvalue if length $tvalue; + } + elsif ( $] >= 5.006_000 ) { + $tvalue = sprintf("v%vd",$value); + if ( $tvalue =~ /^v\d+(\.\d+)*$/ ) { + # must be a v-string + $value = $tvalue; + } + } + } + return $value; + } + + sub _find_magic_vstring { + my $value = shift; + my $tvalue = ''; + require B; + my $sv = B::svref_2object(\$value); + my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef; + while ( $magic ) { + if ( $magic->TYPE eq 'V' ) { + $tvalue = $magic->PTR; + $tvalue =~ s/^v?(.+)$/v$1/; + last; + } + else { + $magic = $magic->MOREMAGIC; + } + } + return $tvalue; + } + + sub _VERSION { + my ($obj, $req) = @_; + my $class = ref($obj) || $obj; + + no strict 'refs'; + if ( exists $INC{"$class.pm"} and not %{"$class\::"} and $] >= 5.008) { + # file but no package + require Carp; + Carp::croak( "$class defines neither package nor VERSION" + ."--version check failed"); + } + + my $version = eval "\$$class\::VERSION"; + if ( defined $version ) { + local $^W if $] <= 5.008; + $version = version::vpp->new($version); + } + + if ( defined $req ) { + unless ( defined $version ) { + require Carp; + my $msg = $] < 5.006 + ? "$class version $req required--this is only version " + : "$class does not define \$$class\::VERSION" + ."--version check failed"; + + if ( $ENV{VERSION_DEBUG} ) { + Carp::confess($msg); + } + else { + Carp::croak($msg); + } + } + + $req = version::vpp->new($req); + + if ( $req > $version ) { + require Carp; + if ( $req->is_qv ) { + Carp::croak( + sprintf ("%s version %s required--". + "this is only version %s", $class, + $req->normal, $version->normal) + ); + } + else { + Carp::croak( + sprintf ("%s version %s required--". + "this is only version %s", $class, + $req->stringify, $version->stringify) + ); + } + } + } + + return defined $version ? $version->stringify : undef; + } + + 1; #this line is important and will help the module return a true value + VERSION_VPP + + s/^ //mg for values %fatpacked; + + my $class = 'FatPacked::'.(0+\%fatpacked); + no strict 'refs'; + *{"${class}::files"} = sub { keys %{$_[0]} }; + + if ($] < 5.008) { + *{"${class}::INC"} = sub { + if (my $fat = $_[0]{$_[1]}) { + return sub { + return 0 unless length $fat; + $fat =~ s/^([^\n]*\n?)//; + $_ = $1; + return 1; + }; + } + return; + }; + } + + else { + *{"${class}::INC"} = sub { + if (my $fat = $_[0]{$_[1]}) { + open my $fh, '<', \$fat + or die "FatPacker error loading $_[1] (could be a perl installation issue?)"; + return $fh; + } + return; + }; + } + + unshift @INC, bless \%fatpacked, $class; + } # END OF FATPACK CODE + + + + use strict; + use App::cpanminus::script; + + + unless (caller) { + my $app = App::cpanminus::script->new; + $app->parse_options(@ARGV); + exit $app->doit; + } + + __END__ + + =head1 NAME + + cpanm - get, unpack build and install modules from CPAN + + =head1 SYNOPSIS + + cpanm Test::More # install Test::More + cpanm MIYAGAWA/Plack-0.99_05.tar.gz # full distribution path + cpanm http://example.org/LDS/CGI.pm-3.20.tar.gz # install from URL + cpanm ~/dists/MyCompany-Enterprise-1.00.tar.gz # install from a local file + cpanm --interactive Task::Kensho # Configure interactively + cpanm . # install from local directory + cpanm --installdeps . # install all the deps for the current directory + cpanm -L extlib Plack # install Plack and all non-core deps into extlib + cpanm --mirror http://cpan.cpantesters.org/ DBI # use the fast-syncing mirror + cpanm --from https://cpan.metacpan.org/ Plack # use only the HTTPS mirror + + =head1 COMMANDS + + =over 4 + + =item (arguments) + + Command line arguments can be either a module name, distribution file, + local file path, HTTP URL or git repository URL. Following commands + will all work as you expect. + + cpanm Plack + cpanm Plack/Request.pm + cpanm MIYAGAWA/Plack-1.0000.tar.gz + cpanm /path/to/Plack-1.0000.tar.gz + cpanm http://cpan.metacpan.org/authors/id/M/MI/MIYAGAWA/Plack-0.9990.tar.gz + cpanm git://github.com/plack/Plack.git + + Additionally, you can use the notation using C<~> and C<@> to specify + version for a given module. C<~> specifies the version requirement in + the L format, while C<@> pins the exact version, and + is a shortcut for C<~"== VERSION">. + + cpanm Plack~1.0000 # 1.0000 or later + cpanm Plack~">= 1.0000, < 2.0000" # latest of 1.xxxx + cpanm Plack@0.9990 # specific version. same as Plack~"== 0.9990" + + The version query including specific version or range will be sent to + L to search for previous releases. The query will search for + BackPAN archives by default, unless you specify C<--dev> option, in + which case, archived versions will be filtered out. + + For a git repository, you can specify a branch, tag, or commit SHA to + build. The default is C + + cpanm git://github.com/plack/Plack.git@1.0000 # tag + cpanm git://github.com/plack/Plack.git@devel # branch + + =item -i, --install + + Installs the modules. This is a default behavior and this is just a + compatibility option to make it work like L or L. + + =item --self-upgrade + + Upgrades itself. It's just an alias for: + + cpanm App::cpanminus + + =item --info + + Displays the distribution information in + C format in the standard out. + + =item --installdeps + + Installs the dependencies of the target distribution but won't build + itself. Handy if you want to try the application from a version + controlled repository such as git. + + cpanm --installdeps . + + =item --look + + Download and unpack the distribution and then open the directory with + your shell. Handy to poke around the source code or do manual + testing. + + =item -h, --help + + Displays the help message. + + =item -V, --version + + Displays the version number. + + =back + + =head1 OPTIONS + + You can specify the default options in C environment variable. + + =over 4 + + =item -f, --force + + Force install modules even when testing failed. + + =item -n, --notest + + Skip the testing of modules. Use this only when you just want to save + time for installing hundreds of distributions to the same perl and + architecture you've already tested to make sure it builds fine. + + Defaults to false, and you can say C<--no-notest> to override when it + is set in the default options in C. + + =item --test-only + + Run the tests only, and do not install the specified module or + distributions. Handy if you want to verify the new (or even old) + releases pass its unit tests without installing the module. + + Note that if you specify this option with a module or distribution + that has dependencies, these dependencies will be installed if you + don't currently have them. + + =item -S, --sudo + + Switch to the root user with C when installing modules. Use this + if you want to install modules to the system perl include path. + + Defaults to false, and you can say C<--no-sudo> to override when it is + set in the default options in C. + + =item -v, --verbose + + Makes the output verbose. It also enables the interactive + configuration. (See --interactive) + + =item -q, --quiet + + Makes the output even more quiet than the default. It only shows the + successful/failed dependencies to the output. + + =item -l, --local-lib + + Sets the L compatible path to install modules to. You + don't need to set this if you already configure the shell environment + variables using L, but this can be used to override that + as well. + + =item -L, --local-lib-contained + + Same with C<--local-lib> but with L<--self-contained> set. All + non-core dependencies will be installed even if they're already + installed. + + For instance, + + cpanm -L extlib Plack + + would install Plack and all of its non-core dependencies into the + directory C, which can be loaded from your application with: + + use local::lib '/path/to/extlib'; + + Note that this option does B reliably work with perl installations + supplied by operating system vendors that strips standard modules from perl, + such as RHEL, Fedora and CentOS, B you also install packages supplying + all the modules that have been stripped. For these systems you will probably + want to install the C meta-package which does just that. + + =item --self-contained + + When examining the dependencies, assume no non-core modules are + installed on the system. Handy if you want to bundle application + dependencies in one directory so you can distribute to other machines. + + =item --exclude-vendor + + Don't include modules installed under the 'vendor' paths when searching for + core modules when the C<--self-contained> flag is in effect. This restores + the behaviour from before version 1.7023 + + =item --mirror + + Specifies the base URL for the CPAN mirror to use, such as + C (you can omit the trailing slash). You + can specify multiple mirror URLs by repeating the command line option. + + You can use a local directory that has a CPAN mirror structure + (created by tools such as L or L) by using a special + URL scheme C. If the given URL begins with `/` (without any + scheme), it is considered as a file scheme as well. + + cpanm --mirror file:///path/to/mirror + cpanm --mirror ~/minicpan # Because shell expands ~ to /home/user + + Defaults to C. + + =item --mirror-only + + Download the mirror's 02packages.details.txt.gz index file instead of + querying the CPAN Meta DB. This will also effectively opt out sending + your local perl versions to backend database servers such as CPAN Meta + DB and MetaCPAN. + + Select this option if you are using a local mirror of CPAN, such as + minicpan when you're offline, or your own CPAN index (a.k.a darkpan). + + =item --from, -M + + cpanm -M https://cpan.metacpan.org/ + cpanm --from https://cpan.metacpan.org/ + + Use the given mirror URL and its index as the I source to search + and download modules from. + + It works similar to C<--mirror> and C<--mirror-only> combined, with a + small difference: unlike C<--mirror> which I the URL to the + list of mirrors, C<--from> (or C<-M> for short) uses the specified URL + as its I source to download index and modules from. This makes + the option always override the default mirror, which might have been + set via global options such as the one set by C + environment variable. + + B It might be useful if you name these options with your shell + aliases, like: + + alias minicpanm='cpanm --from ~/minicpan' + alias darkpan='cpanm --from http://mycompany.example.com/DPAN' + + =item --mirror-index + + B: Specifies the file path to C<02packages.details.txt> + for module search index. + + =item --cpanmetadb + + B: Specifies an alternate URI for CPAN MetaDB index lookups. + + =item --metacpan + + Prefers MetaCPAN API over CPAN MetaDB. + + =item --cpanfile + + B: Specified an alternate path for cpanfile to search for, + when C<--installdeps> command is in use. Defaults to C. + + =item --prompt + + Prompts when a test fails so that you can skip, force install, retry + or look in the shell to see what's going wrong. It also prompts when + one of the dependency failed if you want to proceed the installation. + + Defaults to false, and you can say C<--no-prompt> to override if it's + set in the default options in C. + + =item --dev + + B: search for a newer developer release as well. Defaults to false. + + =item --reinstall + + cpanm, when given a module name in the command line (i.e. C), checks the locally installed version first and skips if it is + already installed. This option makes it skip the check, so: + + cpanm --reinstall Plack + + would reinstall L even if your locally installed version is + latest, or even newer (which would happen if you install a developer + release from version control repositories). + + Defaults to false. + + =item --interactive + + Makes the configuration (such as C and C) + interactive, so you can answer questions in the distribution that + requires custom configuration or Task:: distributions. + + Defaults to false, and you can say C<--no-interactive> to override + when it's set in the default options in C. + + =item --pp, --pureperl + + Prefer Pure perl build of modules by setting C for + MakeMaker and C<--pureperl-only> for Build.PL based + distributions. Note that not all of the CPAN modules support this + convention yet. + + =item --with-recommends, --with-suggests + + B: Installs dependencies declared as C and + C respectively, per META spec. When these dependencies fail + to install, cpanm continues the installation, since they're just + recommendation/suggestion. + + Enabling this could potentially make a circular dependency for a few + modules on CPAN, when C adds a module that C + back the module in return. + + There's also C<--without-recommend> and C<--without-suggests> to + override the default decision made earlier in C. + + Defaults to false for both. + + =item --with-develop + + B: Installs develop phase dependencies in META files or + C when used with C<--installdeps>. Defaults to false. + + =item --with-feature, --without-feature, --with-all-features + + B: Specifies the feature to enable, if a module supports + optional features per META spec 2.0. + + cpanm --with-feature=opt_csv Spreadsheet::Read + + the features can also be interactively chosen when C<--interactive> + option is enabled. + + C<--with-all-features> enables all the optional features, and + C<--without-feature> can select a feature to disable. + + =item --configure-timeout, --build-timeout, --test-timeout + + Specify the timeout length (in seconds) to wait for the configure, + build and test process. Current default values are: 60 for configure, + 3600 for build and 1800 for test. + + =item --configure-args, --build-args, --test-args, --install-args + + B: Pass arguments for configure/build/test/install + commands respectively, for a given module to install. + + cpanm DBD::mysql --configure-args="--cflags=... --libs=..." + + The argument is only enabled for the module passed as a command line + argument, not dependencies. + + =item --scandeps + + B: Scans the depencencies of given modules and output the + tree in a text format. (See C<--format> below for more options) + + Because this command doesn't actually install any distributions, it + will be useful that by typing: + + cpanm --scandeps Catalyst::Runtime + + you can make sure what modules will be installed. + + This command takes into account which modules you already have + installed in your system. If you want to see what modules will be + installed against a vanilla perl installation, you might want to + combine it with C<-L> option. + + =item --format + + B: Determines what format to display the scanned + dependency tree. Available options are C, C, C and + C. + + =over 8 + + =item tree + + Displays the tree in a plain text format. This is the default value. + + =item json, yaml + + Outputs the tree in a JSON or YAML format. L and L modules + need to be installed respectively. The output tree is represented as a + recursive tuple of: + + [ distribution, dependencies ] + + and the container is an array containing the root elements. Note that + there may be multiple root nodes, since you can give multiple modules + to the C<--scandeps> command. + + =item dists + + C is a special output format, where it prints the distribution + filename in the I after the dependency resolution, + like: + + GAAS/MIME-Base64-3.13.tar.gz + GAAS/URI-1.58.tar.gz + PETDANCE/HTML-Tagset-3.20.tar.gz + GAAS/HTML-Parser-3.68.tar.gz + GAAS/libwww-perl-5.837.tar.gz + + which means you can install these distributions in this order without + extra dependencies. When combined with C<-L> option, it will be useful + to replay installations on other machines. + + =back + + =item --save-dists + + Specifies the optional directory path to copy downloaded tarballs in + the CPAN mirror compatible directory structure + i.e. I + + If the distro tarball did not come from CPAN, for example from a local + file or from GitHub, then it will be saved under + I. + + =item --uninst-shadows + + Uninstalls the shadow files of the distribution that you're + installing. This eliminates the confusion if you're trying to install + core (dual-life) modules from CPAN against perl 5.10 or older, or + modules that used to be XS-based but switched to pure perl at some + version. + + If you run cpanm as root and use C or equivalent to + specify custom installation path, you SHOULD disable this option so + you won't accidentally uninstall dual-life modules from the core + include path. + + Defaults to true if your perl version is smaller than 5.12, and you + can disable that with C<--no-uninst-shadows>. + + B: Since version 1.3000 this flag is turned off by default for + perl newer than 5.12, since with 5.12 @INC contains site_perl directory + I the perl core library path, and uninstalling shadows is not + necessary anymore and does more harm by deleting files from the core + library path. + + =item --uninstall, -U + + Uninstalls a module from the library path. It finds a packlist for + given modules, and removes all the files included in the same + distribution. + + If you enable local::lib, it only removes files from the local::lib + directory. + + If you try to uninstall a module in C directory (i.e. core + module), an error will be thrown. + + A dialog will be prompted to confirm the files to be deleted. If you pass + C<-f> option as well, the dialog will be skipped and uninstallation + will be forced. + + =item --cascade-search + + B: Specifies whether to cascade search when you specify + multiple mirrors and a mirror doesn't have a module or has a lower + version of the module than requested. Defaults to false. + + =item --skip-installed + + Specifies whether a module given in the command line is skipped if its latest + version is already installed. Defaults to true. + + B: The C environment variable have to be correctly set + for this to work with modules installed using L, unless + you always use the C<-l> option. + + =item --skip-satisfied + + B: Specifies whether a module (and version) given in the + command line is skipped if it's already installed. + + If you run: + + cpanm --skip-satisfied CGI DBI~1.2 + + cpanm won't install them if you already have CGI (for whatever + versions) or have DBI with version higher than 1.2. It is similar to + C<--skip-installed> but while C<--skip-installed> checks if the + I version of CPAN is installed, C<--skip-satisfied> checks if + a requested version (or not, which means any version) is installed. + + Defaults to false. + + =item --verify + + Verify the integrity of distribution files retrieved from PAUSE using + CHECKSUMS and SIGNATURES (if found). Defaults to false. + + =item --report-perl-version + + Whether it reports the locally installed perl version to the various + web server as part of User-Agent. Defaults to true unless CI related + environment variables such as C, C or C + is enabled. You can disable it by using C<--no-report-perl-version>. + + =item --auto-cleanup + + Specifies the number of days in which cpanm's work directories + expire. Defaults to 7, which means old work directories will be + cleaned up in one week. + + You can set the value to C<0> to make cpan never cleanup those + directories. + + =item --man-pages + + Generates man pages for executables (man1) and libraries (man3). + + Defaults to true (man pages generated) unless C<-L|--local-lib-contained> + option is supplied in which case it's set to false. You can disable + it with C<--no-man-pages>. + + =item --lwp + + Uses L module to download stuff over HTTP. Defaults to true, and + you can say C<--no-lwp> to disable using LWP, when you want to upgrade + LWP from CPAN on some broken perl systems. + + =item --wget + + Uses GNU Wget (if available) to download stuff. Defaults to true, and + you can say C<--no-wget> to disable using Wget (versions of Wget older + than 1.9 don't support the C<--retry-connrefused> option used by cpanm). + + =item --curl + + Uses cURL (if available) to download stuff. Defaults to true, and + you can say C<--no-curl> to disable using cURL. + + Normally with C<--lwp>, C<--wget> and C<--curl> options set to true + (which is the default) cpanm tries L, Wget, cURL and L + (in that order) and uses the first one available. + + =back + + =head1 SEE ALSO + + L + + =head1 COPYRIGHT + + Copyright 2010- Tatsuhiko Miyagawa. + + =head1 AUTHOR + + Tatsuhiko Miyagawa + + =cut +APP_CPANMINUS_FATSCRIPT + +$fatpacked{"CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META'; + use 5.006; + use strict; + use warnings; + package CPAN::Meta; + # VERSION + $CPAN::Meta::VERSION = '2.143240'; + #pod =head1 SYNOPSIS + #pod + #pod use v5.10; + #pod use strict; + #pod use warnings; + #pod use CPAN::Meta; + #pod use Module::Load; + #pod + #pod my $meta = CPAN::Meta->load_file('META.json'); + #pod + #pod printf "testing requirements for %s version %s\n", + #pod $meta->name, + #pod $meta->version; + #pod + #pod my $prereqs = $meta->effective_prereqs; + #pod + #pod for my $phase ( qw/configure runtime build test/ ) { + #pod say "Requirements for $phase:"; + #pod my $reqs = $prereqs->requirements_for($phase, "requires"); + #pod for my $module ( sort $reqs->required_modules ) { + #pod my $status; + #pod if ( eval { load $module unless $module eq 'perl'; 1 } ) { + #pod my $version = $module eq 'perl' ? $] : $module->VERSION; + #pod $status = $reqs->accepts_module($module, $version) + #pod ? "$version ok" : "$version not ok"; + #pod } else { + #pod $status = "missing" + #pod }; + #pod say " $module ($status)"; + #pod } + #pod } + #pod + #pod =head1 DESCRIPTION + #pod + #pod Software distributions released to the CPAN include a F or, for + #pod older distributions, F, which describes the distribution, its + #pod contents, and the requirements for building and installing the distribution. + #pod The data structure stored in the F file is described in + #pod L. + #pod + #pod CPAN::Meta provides a simple class to represent this distribution metadata (or + #pod I), along with some helpful methods for interrogating that data. + #pod + #pod The documentation below is only for the methods of the CPAN::Meta object. For + #pod information on the meaning of individual fields, consult the spec. + #pod + #pod =cut + + use Carp qw(carp croak); + use CPAN::Meta::Feature; + use CPAN::Meta::Prereqs; + use CPAN::Meta::Converter; + use CPAN::Meta::Validator; + use Parse::CPAN::Meta 1.4414 (); + + BEGIN { *_dclone = \&CPAN::Meta::Converter::_dclone } + + #pod =head1 STRING DATA + #pod + #pod The following methods return a single value, which is the value for the + #pod corresponding entry in the distmeta structure. Values should be either undef + #pod or strings. + #pod + #pod =for :list + #pod * abstract + #pod * description + #pod * dynamic_config + #pod * generated_by + #pod * name + #pod * release_status + #pod * version + #pod + #pod =cut + + BEGIN { + my @STRING_READERS = qw( + abstract + description + dynamic_config + generated_by + name + release_status + version + ); + + no strict 'refs'; + for my $attr (@STRING_READERS) { + *$attr = sub { $_[0]{ $attr } }; + } + } + + #pod =head1 LIST DATA + #pod + #pod These methods return lists of string values, which might be represented in the + #pod distmeta structure as arrayrefs or scalars: + #pod + #pod =for :list + #pod * authors + #pod * keywords + #pod * licenses + #pod + #pod The C and C methods may also be called as C and + #pod C, respectively, to match the field name in the distmeta structure. + #pod + #pod =cut + + BEGIN { + my @LIST_READERS = qw( + author + keywords + license + ); + + no strict 'refs'; + for my $attr (@LIST_READERS) { + *$attr = sub { + my $value = $_[0]{ $attr }; + croak "$attr must be called in list context" + unless wantarray; + return @{ _dclone($value) } if ref $value; + return $value; + }; + } + } + + sub authors { $_[0]->author } + sub licenses { $_[0]->license } + + #pod =head1 MAP DATA + #pod + #pod These readers return hashrefs of arbitrary unblessed data structures, each + #pod described more fully in the specification: + #pod + #pod =for :list + #pod * meta_spec + #pod * resources + #pod * provides + #pod * no_index + #pod * prereqs + #pod * optional_features + #pod + #pod =cut + + BEGIN { + my @MAP_READERS = qw( + meta-spec + resources + provides + no_index + + prereqs + optional_features + ); + + no strict 'refs'; + for my $attr (@MAP_READERS) { + (my $subname = $attr) =~ s/-/_/; + *$subname = sub { + my $value = $_[0]{ $attr }; + return _dclone($value) if $value; + return {}; + }; + } + } + + #pod =head1 CUSTOM DATA + #pod + #pod A list of custom keys are available from the C method and + #pod particular keys may be retrieved with the C method. + #pod + #pod say $meta->custom($_) for $meta->custom_keys; + #pod + #pod If a custom key refers to a data structure, a deep clone is returned. + #pod + #pod =cut + + sub custom_keys { + return grep { /^x_/i } keys %{$_[0]}; + } + + sub custom { + my ($self, $attr) = @_; + my $value = $self->{$attr}; + return _dclone($value) if ref $value; + return $value; + } + + #pod =method new + #pod + #pod my $meta = CPAN::Meta->new($distmeta_struct, \%options); + #pod + #pod Returns a valid CPAN::Meta object or dies if the supplied metadata hash + #pod reference fails to validate. Older-format metadata will be up-converted to + #pod version 2 if they validate against the original stated specification. + #pod + #pod It takes an optional hashref of options. Valid options include: + #pod + #pod =over + #pod + #pod =item * + #pod + #pod lazy_validation -- if true, new will attempt to convert the given metadata + #pod to version 2 before attempting to validate it. This means than any + #pod fixable errors will be handled by CPAN::Meta::Converter before validation. + #pod (Note that this might result in invalid optional data being silently + #pod dropped.) The default is false. + #pod + #pod =back + #pod + #pod =cut + + sub _new { + my ($class, $struct, $options) = @_; + my $self; + + if ( $options->{lazy_validation} ) { + # try to convert to a valid structure; if succeeds, then return it + my $cmc = CPAN::Meta::Converter->new( $struct ); + $self = $cmc->convert( version => 2 ); # valid or dies + return bless $self, $class; + } + else { + # validate original struct + my $cmv = CPAN::Meta::Validator->new( $struct ); + unless ( $cmv->is_valid) { + die "Invalid metadata structure. Errors: " + . join(", ", $cmv->errors) . "\n"; + } + } + + # up-convert older spec versions + my $version = $struct->{'meta-spec'}{version} || '1.0'; + if ( $version == 2 ) { + $self = $struct; + } + else { + my $cmc = CPAN::Meta::Converter->new( $struct ); + $self = $cmc->convert( version => 2 ); + } + + return bless $self, $class; + } + + sub new { + my ($class, $struct, $options) = @_; + my $self = eval { $class->_new($struct, $options) }; + croak($@) if $@; + return $self; + } + + #pod =method create + #pod + #pod my $meta = CPAN::Meta->create($distmeta_struct, \%options); + #pod + #pod This is same as C, except that C and C fields + #pod will be generated if not provided. This means the metadata structure is + #pod assumed to otherwise follow the latest L. + #pod + #pod =cut + + sub create { + my ($class, $struct, $options) = @_; + my $version = __PACKAGE__->VERSION || 2; + $struct->{generated_by} ||= __PACKAGE__ . " version $version" ; + $struct->{'meta-spec'}{version} ||= int($version); + my $self = eval { $class->_new($struct, $options) }; + croak ($@) if $@; + return $self; + } + + #pod =method load_file + #pod + #pod my $meta = CPAN::Meta->load_file($distmeta_file, \%options); + #pod + #pod Given a pathname to a file containing metadata, this deserializes the file + #pod according to its file suffix and constructs a new C object, just + #pod like C. It will die if the deserialized version fails to validate + #pod against its stated specification version. + #pod + #pod It takes the same options as C but C defaults to + #pod true. + #pod + #pod =cut + + sub load_file { + my ($class, $file, $options) = @_; + $options->{lazy_validation} = 1 unless exists $options->{lazy_validation}; + + croak "load_file() requires a valid, readable filename" + unless -r $file; + + my $self; + eval { + my $struct = Parse::CPAN::Meta->load_file( $file ); + $self = $class->_new($struct, $options); + }; + croak($@) if $@; + return $self; + } + + #pod =method load_yaml_string + #pod + #pod my $meta = CPAN::Meta->load_yaml_string($yaml, \%options); + #pod + #pod This method returns a new CPAN::Meta object using the first document in the + #pod given YAML string. In other respects it is identical to C. + #pod + #pod =cut + + sub load_yaml_string { + my ($class, $yaml, $options) = @_; + $options->{lazy_validation} = 1 unless exists $options->{lazy_validation}; + + my $self; + eval { + my ($struct) = Parse::CPAN::Meta->load_yaml_string( $yaml ); + $self = $class->_new($struct, $options); + }; + croak($@) if $@; + return $self; + } + + #pod =method load_json_string + #pod + #pod my $meta = CPAN::Meta->load_json_string($json, \%options); + #pod + #pod This method returns a new CPAN::Meta object using the structure represented by + #pod the given JSON string. In other respects it is identical to C. + #pod + #pod =cut + + sub load_json_string { + my ($class, $json, $options) = @_; + $options->{lazy_validation} = 1 unless exists $options->{lazy_validation}; + + my $self; + eval { + my $struct = Parse::CPAN::Meta->load_json_string( $json ); + $self = $class->_new($struct, $options); + }; + croak($@) if $@; + return $self; + } + + #pod =method load_string + #pod + #pod my $meta = CPAN::Meta->load_string($string, \%options); + #pod + #pod If you don't know if a string contains YAML or JSON, this method will use + #pod L to guess. In other respects it is identical to + #pod C. + #pod + #pod =cut + + sub load_string { + my ($class, $string, $options) = @_; + $options->{lazy_validation} = 1 unless exists $options->{lazy_validation}; + + my $self; + eval { + my $struct = Parse::CPAN::Meta->load_string( $string ); + $self = $class->_new($struct, $options); + }; + croak($@) if $@; + return $self; + } + + #pod =method save + #pod + #pod $meta->save($distmeta_file, \%options); + #pod + #pod Serializes the object as JSON and writes it to the given file. The only valid + #pod option is C, which defaults to '2'. On Perl 5.8.1 or later, the file + #pod is saved with UTF-8 encoding. + #pod + #pod For C 2 (or higher), the filename should end in '.json'. L + #pod is the default JSON backend. Using another JSON backend requires L 2.5 or + #pod later and you must set the C<$ENV{PERL_JSON_BACKEND}> to a supported alternate + #pod backend like L. + #pod + #pod For C less than 2, the filename should end in '.yml'. + #pod L is used to generate an older metadata structure, which + #pod is serialized to YAML. CPAN::Meta::YAML is the default YAML backend. You may + #pod set the C<$ENV{PERL_YAML_BACKEND}> to a supported alternative backend, though + #pod this is not recommended due to subtle incompatibilities between YAML parsers on + #pod CPAN. + #pod + #pod =cut + + sub save { + my ($self, $file, $options) = @_; + + my $version = $options->{version} || '2'; + my $layer = $] ge '5.008001' ? ':utf8' : ''; + + if ( $version ge '2' ) { + carp "'$file' should end in '.json'" + unless $file =~ m{\.json$}; + } + else { + carp "'$file' should end in '.yml'" + unless $file =~ m{\.yml$}; + } + + my $data = $self->as_string( $options ); + open my $fh, ">$layer", $file + or die "Error opening '$file' for writing: $!\n"; + + print {$fh} $data; + close $fh + or die "Error closing '$file': $!\n"; + + return 1; + } + + #pod =method meta_spec_version + #pod + #pod This method returns the version part of the C entry in the distmeta + #pod structure. It is equivalent to: + #pod + #pod $meta->meta_spec->{version}; + #pod + #pod =cut + + sub meta_spec_version { + my ($self) = @_; + return $self->meta_spec->{version}; + } + + #pod =method effective_prereqs + #pod + #pod my $prereqs = $meta->effective_prereqs; + #pod + #pod my $prereqs = $meta->effective_prereqs( \@feature_identifiers ); + #pod + #pod This method returns a L object describing all the + #pod prereqs for the distribution. If an arrayref of feature identifiers is given, + #pod the prereqs for the identified features are merged together with the + #pod distribution's core prereqs before the CPAN::Meta::Prereqs object is returned. + #pod + #pod =cut + + sub effective_prereqs { + my ($self, $features) = @_; + $features ||= []; + + my $prereq = CPAN::Meta::Prereqs->new($self->prereqs); + + return $prereq unless @$features; + + my @other = map {; $self->feature($_)->prereqs } @$features; + + return $prereq->with_merged_prereqs(\@other); + } + + #pod =method should_index_file + #pod + #pod ... if $meta->should_index_file( $filename ); + #pod + #pod This method returns true if the given file should be indexed. It decides this + #pod by checking the C and C keys in the C property of + #pod the distmeta structure. Note that neither the version format nor + #pod C are considered. + #pod + #pod C<$filename> should be given in unix format. + #pod + #pod =cut + + sub should_index_file { + my ($self, $filename) = @_; + + for my $no_index_file (@{ $self->no_index->{file} || [] }) { + return if $filename eq $no_index_file; + } + + for my $no_index_dir (@{ $self->no_index->{directory} }) { + $no_index_dir =~ s{$}{/} unless $no_index_dir =~ m{/\z}; + return if index($filename, $no_index_dir) == 0; + } + + return 1; + } + + #pod =method should_index_package + #pod + #pod ... if $meta->should_index_package( $package ); + #pod + #pod This method returns true if the given package should be indexed. It decides + #pod this by checking the C and C keys in the C + #pod property of the distmeta structure. Note that neither the version format nor + #pod C are considered. + #pod + #pod =cut + + sub should_index_package { + my ($self, $package) = @_; + + for my $no_index_pkg (@{ $self->no_index->{package} || [] }) { + return if $package eq $no_index_pkg; + } + + for my $no_index_ns (@{ $self->no_index->{namespace} }) { + return if index($package, "${no_index_ns}::") == 0; + } + + return 1; + } + + #pod =method features + #pod + #pod my @feature_objects = $meta->features; + #pod + #pod This method returns a list of L objects, one for each + #pod optional feature described by the distribution's metadata. + #pod + #pod =cut + + sub features { + my ($self) = @_; + + my $opt_f = $self->optional_features; + my @features = map {; CPAN::Meta::Feature->new($_ => $opt_f->{ $_ }) } + keys %$opt_f; + + return @features; + } + + #pod =method feature + #pod + #pod my $feature_object = $meta->feature( $identifier ); + #pod + #pod This method returns a L object for the optional feature + #pod with the given identifier. If no feature with that identifier exists, an + #pod exception will be raised. + #pod + #pod =cut + + sub feature { + my ($self, $ident) = @_; + + croak "no feature named $ident" + unless my $f = $self->optional_features->{ $ident }; + + return CPAN::Meta::Feature->new($ident, $f); + } + + #pod =method as_struct + #pod + #pod my $copy = $meta->as_struct( \%options ); + #pod + #pod This method returns a deep copy of the object's metadata as an unblessed hash + #pod reference. It takes an optional hashref of options. If the hashref contains + #pod a C argument, the copied metadata will be converted to the version + #pod of the specification and returned. For example: + #pod + #pod my $old_spec = $meta->as_struct( {version => "1.4"} ); + #pod + #pod =cut + + sub as_struct { + my ($self, $options) = @_; + my $struct = _dclone($self); + if ( $options->{version} ) { + my $cmc = CPAN::Meta::Converter->new( $struct ); + $struct = $cmc->convert( version => $options->{version} ); + } + return $struct; + } + + #pod =method as_string + #pod + #pod my $string = $meta->as_string( \%options ); + #pod + #pod This method returns a serialized copy of the object's metadata as a character + #pod string. (The strings are B UTF-8 encoded.) It takes an optional hashref + #pod of options. If the hashref contains a C argument, the copied metadata + #pod will be converted to the version of the specification and returned. For + #pod example: + #pod + #pod my $string = $meta->as_string( {version => "1.4"} ); + #pod + #pod For C greater than or equal to 2, the string will be serialized as + #pod JSON. For C less than 2, the string will be serialized as YAML. In + #pod both cases, the same rules are followed as in the C method for choosing + #pod a serialization backend. + #pod + #pod =cut + + sub as_string { + my ($self, $options) = @_; + + my $version = $options->{version} || '2'; + + my $struct; + if ( $self->meta_spec_version ne $version ) { + my $cmc = CPAN::Meta::Converter->new( $self->as_struct ); + $struct = $cmc->convert( version => $version ); + } + else { + $struct = $self->as_struct; + } + + my ($data, $backend); + if ( $version ge '2' ) { + $backend = Parse::CPAN::Meta->json_backend(); + $data = $backend->new->pretty->canonical->encode($struct); + } + else { + $backend = Parse::CPAN::Meta->yaml_backend(); + $data = eval { no strict 'refs'; &{"$backend\::Dump"}($struct) }; + if ( $@ ) { + croak $backend->can('errstr') ? $backend->errstr : $@ + } + } + + return $data; + } + + # Used by JSON::PP, etc. for "convert_blessed" + sub TO_JSON { + return { %{ $_[0] } }; + } + + 1; + + # ABSTRACT: the distribution metadata for a CPAN dist + + __END__ + + =pod + + =encoding UTF-8 + + =head1 NAME + + CPAN::Meta - the distribution metadata for a CPAN dist + + =head1 VERSION + + version 2.143240 + + =head1 SYNOPSIS + + use v5.10; + use strict; + use warnings; + use CPAN::Meta; + use Module::Load; + + my $meta = CPAN::Meta->load_file('META.json'); + + printf "testing requirements for %s version %s\n", + $meta->name, + $meta->version; + + my $prereqs = $meta->effective_prereqs; + + for my $phase ( qw/configure runtime build test/ ) { + say "Requirements for $phase:"; + my $reqs = $prereqs->requirements_for($phase, "requires"); + for my $module ( sort $reqs->required_modules ) { + my $status; + if ( eval { load $module unless $module eq 'perl'; 1 } ) { + my $version = $module eq 'perl' ? $] : $module->VERSION; + $status = $reqs->accepts_module($module, $version) + ? "$version ok" : "$version not ok"; + } else { + $status = "missing" + }; + say " $module ($status)"; + } + } + + =head1 DESCRIPTION + + Software distributions released to the CPAN include a F or, for + older distributions, F, which describes the distribution, its + contents, and the requirements for building and installing the distribution. + The data structure stored in the F file is described in + L. + + CPAN::Meta provides a simple class to represent this distribution metadata (or + I), along with some helpful methods for interrogating that data. + + The documentation below is only for the methods of the CPAN::Meta object. For + information on the meaning of individual fields, consult the spec. + + =head1 METHODS + + =head2 new + + my $meta = CPAN::Meta->new($distmeta_struct, \%options); + + Returns a valid CPAN::Meta object or dies if the supplied metadata hash + reference fails to validate. Older-format metadata will be up-converted to + version 2 if they validate against the original stated specification. + + It takes an optional hashref of options. Valid options include: + + =over + + =item * + + lazy_validation -- if true, new will attempt to convert the given metadata + to version 2 before attempting to validate it. This means than any + fixable errors will be handled by CPAN::Meta::Converter before validation. + (Note that this might result in invalid optional data being silently + dropped.) The default is false. + + =back + + =head2 create + + my $meta = CPAN::Meta->create($distmeta_struct, \%options); + + This is same as C, except that C and C fields + will be generated if not provided. This means the metadata structure is + assumed to otherwise follow the latest L. + + =head2 load_file + + my $meta = CPAN::Meta->load_file($distmeta_file, \%options); + + Given a pathname to a file containing metadata, this deserializes the file + according to its file suffix and constructs a new C object, just + like C. It will die if the deserialized version fails to validate + against its stated specification version. + + It takes the same options as C but C defaults to + true. + + =head2 load_yaml_string + + my $meta = CPAN::Meta->load_yaml_string($yaml, \%options); + + This method returns a new CPAN::Meta object using the first document in the + given YAML string. In other respects it is identical to C. + + =head2 load_json_string + + my $meta = CPAN::Meta->load_json_string($json, \%options); + + This method returns a new CPAN::Meta object using the structure represented by + the given JSON string. In other respects it is identical to C. + + =head2 load_string + + my $meta = CPAN::Meta->load_string($string, \%options); + + If you don't know if a string contains YAML or JSON, this method will use + L to guess. In other respects it is identical to + C. + + =head2 save + + $meta->save($distmeta_file, \%options); + + Serializes the object as JSON and writes it to the given file. The only valid + option is C, which defaults to '2'. On Perl 5.8.1 or later, the file + is saved with UTF-8 encoding. + + For C 2 (or higher), the filename should end in '.json'. L + is the default JSON backend. Using another JSON backend requires L 2.5 or + later and you must set the C<$ENV{PERL_JSON_BACKEND}> to a supported alternate + backend like L. + + For C less than 2, the filename should end in '.yml'. + L is used to generate an older metadata structure, which + is serialized to YAML. CPAN::Meta::YAML is the default YAML backend. You may + set the C<$ENV{PERL_YAML_BACKEND}> to a supported alternative backend, though + this is not recommended due to subtle incompatibilities between YAML parsers on + CPAN. + + =head2 meta_spec_version + + This method returns the version part of the C entry in the distmeta + structure. It is equivalent to: + + $meta->meta_spec->{version}; + + =head2 effective_prereqs + + my $prereqs = $meta->effective_prereqs; + + my $prereqs = $meta->effective_prereqs( \@feature_identifiers ); + + This method returns a L object describing all the + prereqs for the distribution. If an arrayref of feature identifiers is given, + the prereqs for the identified features are merged together with the + distribution's core prereqs before the CPAN::Meta::Prereqs object is returned. + + =head2 should_index_file + + ... if $meta->should_index_file( $filename ); + + This method returns true if the given file should be indexed. It decides this + by checking the C and C keys in the C property of + the distmeta structure. Note that neither the version format nor + C are considered. + + C<$filename> should be given in unix format. + + =head2 should_index_package + + ... if $meta->should_index_package( $package ); + + This method returns true if the given package should be indexed. It decides + this by checking the C and C keys in the C + property of the distmeta structure. Note that neither the version format nor + C are considered. + + =head2 features + + my @feature_objects = $meta->features; + + This method returns a list of L objects, one for each + optional feature described by the distribution's metadata. + + =head2 feature + + my $feature_object = $meta->feature( $identifier ); + + This method returns a L object for the optional feature + with the given identifier. If no feature with that identifier exists, an + exception will be raised. + + =head2 as_struct + + my $copy = $meta->as_struct( \%options ); + + This method returns a deep copy of the object's metadata as an unblessed hash + reference. It takes an optional hashref of options. If the hashref contains + a C argument, the copied metadata will be converted to the version + of the specification and returned. For example: + + my $old_spec = $meta->as_struct( {version => "1.4"} ); + + =head2 as_string + + my $string = $meta->as_string( \%options ); + + This method returns a serialized copy of the object's metadata as a character + string. (The strings are B UTF-8 encoded.) It takes an optional hashref + of options. If the hashref contains a C argument, the copied metadata + will be converted to the version of the specification and returned. For + example: + + my $string = $meta->as_string( {version => "1.4"} ); + + For C greater than or equal to 2, the string will be serialized as + JSON. For C less than 2, the string will be serialized as YAML. In + both cases, the same rules are followed as in the C method for choosing + a serialization backend. + + =head1 STRING DATA + + The following methods return a single value, which is the value for the + corresponding entry in the distmeta structure. Values should be either undef + or strings. + + =over 4 + + =item * + + abstract + + =item * + + description + + =item * + + dynamic_config + + =item * + + generated_by + + =item * + + name + + =item * + + release_status + + =item * + + version + + =back + + =head1 LIST DATA + + These methods return lists of string values, which might be represented in the + distmeta structure as arrayrefs or scalars: + + =over 4 + + =item * + + authors + + =item * + + keywords + + =item * + + licenses + + =back + + The C and C methods may also be called as C and + C, respectively, to match the field name in the distmeta structure. + + =head1 MAP DATA + + These readers return hashrefs of arbitrary unblessed data structures, each + described more fully in the specification: + + =over 4 + + =item * + + meta_spec + + =item * + + resources + + =item * + + provides + + =item * + + no_index + + =item * + + prereqs + + =item * + + optional_features + + =back + + =head1 CUSTOM DATA + + A list of custom keys are available from the C method and + particular keys may be retrieved with the C method. + + say $meta->custom($_) for $meta->custom_keys; + + If a custom key refers to a data structure, a deep clone is returned. + + =for Pod::Coverage TO_JSON abstract author authors custom custom_keys description dynamic_config + generated_by keywords license licenses meta_spec name no_index + optional_features prereqs provides release_status resources version + + =head1 BUGS + + Please report any bugs or feature using the CPAN Request Tracker. + Bugs can be submitted through the web interface at + L + + When submitting a bug or request, please include a test-file or a patch to an + existing test-file that illustrates the bug or desired feature. + + =head1 SEE ALSO + + =over 4 + + =item * + + L + + =item * + + L + + =back + + =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan + + =head1 SUPPORT + + =head2 Bugs / Feature Requests + + Please report any bugs or feature requests through the issue tracker + at L. + You will be notified automatically of any progress on your issue. + + =head2 Source Code + + This is open source software. The code repository is available for + public review and contribution under the terms of the license. + + L + + git clone https://github.com/Perl-Toolchain-Gang/CPAN-Meta.git + + =head1 AUTHORS + + =over 4 + + =item * + + David Golden + + =item * + + Ricardo Signes + + =back + + =head1 CONTRIBUTORS + + =for stopwords Ansgar Burchardt Avar Arnfjord Bjarmason Christopher J. Madsen Chuck Adams Cory G Watson Damyan Ivanov Eric Wilhelm Graham Knop Gregor Hermann Karen Etheridge Kenichi Ishigaki Ken Williams Lars Dieckow Leon Timmermans majensen Mark Fowler Matt S Trout Michael G. Schwern moznion Olaf Alders Olivier Mengue Randy Sims + + =over 4 + + =item * + + Ansgar Burchardt + + =item * + + Avar Arnfjord Bjarmason + + =item * + + Christopher J. Madsen + + =item * + + Chuck Adams + + =item * + + Cory G Watson + + =item * + + Damyan Ivanov + + =item * + + Eric Wilhelm + + =item * + + Graham Knop + + =item * + + Gregor Hermann + + =item * + + Karen Etheridge + + =item * + + Kenichi Ishigaki + + =item * + + Ken Williams + + =item * + + Lars Dieckow + + =item * + + Leon Timmermans + + =item * + + majensen + + =item * + + Mark Fowler + + =item * + + Matt S Trout + + =item * + + Michael G. Schwern + + =item * + + moznion + + =item * + + Olaf Alders + + =item * + + Olivier Mengue + + =item * + + Randy Sims + + =back + + =head1 COPYRIGHT AND LICENSE + + This software is copyright (c) 2010 by David Golden and Ricardo Signes. + + This is free software; you can redistribute it and/or modify it under + the same terms as the Perl 5 programming language system itself. + + =cut +CPAN_META + +$fatpacked{"CPAN/Meta/Converter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_CONVERTER'; + use 5.006; + use strict; + use warnings; + package CPAN::Meta::Converter; + # VERSION + $CPAN::Meta::Converter::VERSION = '2.143240'; + #pod =head1 SYNOPSIS + #pod + #pod my $struct = decode_json_file('META.json'); + #pod + #pod my $cmc = CPAN::Meta::Converter->new( $struct ); + #pod + #pod my $new_struct = $cmc->convert( version => "2" ); + #pod + #pod =head1 DESCRIPTION + #pod + #pod This module converts CPAN Meta structures from one form to another. The + #pod primary use is to convert older structures to the most modern version of + #pod the specification, but other transformations may be implemented in the + #pod future as needed. (E.g. stripping all custom fields or stripping all + #pod optional fields.) + #pod + #pod =cut + + use CPAN::Meta::Validator; + use CPAN::Meta::Requirements; + use Parse::CPAN::Meta 1.4400 (); + + # To help ExtUtils::MakeMaker bootstrap CPAN::Meta::Requirements on perls + # before 5.10, we fall back to the EUMM bundled compatibility version module if + # that's the only thing available. This shouldn't ever happen in a normal CPAN + # install of CPAN::Meta::Requirements, as version.pm will be picked up from + # prereqs and be available at runtime. + + BEGIN { + eval "use version ()"; ## no critic + if ( my $err = $@ ) { + eval "use ExtUtils::MakeMaker::version" or die $err; ## no critic + } + } + + # Perl 5.10.0 didn't have "is_qv" in version.pm + *_is_qv = version->can('is_qv') ? sub { $_[0]->is_qv } : sub { exists $_[0]->{qv} }; + + sub _dclone { + my $ref = shift; + + # if an object is in the data structure and doesn't specify how to + # turn itself into JSON, we just stringify the object. That does the + # right thing for typical things that might be there, like version objects, + # Path::Class objects, etc. + no warnings 'once'; + no warnings 'redefine'; + local *UNIVERSAL::TO_JSON = sub { "$_[0]" }; + + my $json = Parse::CPAN::Meta->json_backend()->new + ->utf8 + ->allow_blessed + ->convert_blessed; + $json->decode($json->encode($ref)) + } + + my %known_specs = ( + '2' => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec', + '1.4' => 'http://module-build.sourceforge.net/META-spec-v1.4.html', + '1.3' => 'http://module-build.sourceforge.net/META-spec-v1.3.html', + '1.2' => 'http://module-build.sourceforge.net/META-spec-v1.2.html', + '1.1' => 'http://module-build.sourceforge.net/META-spec-v1.1.html', + '1.0' => 'http://module-build.sourceforge.net/META-spec-v1.0.html' + ); + + my @spec_list = sort { $a <=> $b } keys %known_specs; + my ($LOWEST, $HIGHEST) = @spec_list[0,-1]; + + #--------------------------------------------------------------------------# + # converters + # + # called as $converter->($element, $field_name, $full_meta, $to_version) + # + # defined return value used for field + # undef return value means field is skipped + #--------------------------------------------------------------------------# + + sub _keep { $_[0] } + + sub _keep_or_one { defined($_[0]) ? $_[0] : 1 } + + sub _keep_or_zero { defined($_[0]) ? $_[0] : 0 } + + sub _keep_or_unknown { defined($_[0]) && length($_[0]) ? $_[0] : "unknown" } + + sub _generated_by { + my $gen = shift; + my $sig = __PACKAGE__ . " version " . (__PACKAGE__->VERSION || ""); + + return $sig unless defined $gen and length $gen; + return $gen if $gen =~ /\Q$sig/; + return "$gen, $sig"; + } + + sub _listify { ! defined $_[0] ? undef : ref $_[0] eq 'ARRAY' ? $_[0] : [$_[0]] } + + sub _prefix_custom { + my $key = shift; + $key =~ s/^(?!x_) # Unless it already starts with x_ + (?:x-?)? # Remove leading x- or x (if present) + /x_/ix; # and prepend x_ + return $key; + } + + sub _ucfirst_custom { + my $key = shift; + $key = ucfirst $key unless $key =~ /[A-Z]/; + return $key; + } + + sub _no_prefix_ucfirst_custom { + my $key = shift; + $key =~ s/^x_//; + return _ucfirst_custom($key); + } + + sub _change_meta_spec { + my ($element, undef, undef, $version) = @_; + return { + version => $version, + url => $known_specs{$version}, + }; + } + + my @open_source = ( + 'perl', + 'gpl', + 'apache', + 'artistic', + 'artistic_2', + 'lgpl', + 'bsd', + 'gpl', + 'mit', + 'mozilla', + 'open_source', + ); + + my %is_open_source = map {; $_ => 1 } @open_source; + + my @valid_licenses_1 = ( + @open_source, + 'unrestricted', + 'restrictive', + 'unknown', + ); + + my %license_map_1 = ( + ( map { $_ => $_ } @valid_licenses_1 ), + artistic2 => 'artistic_2', + ); + + sub _license_1 { + my ($element) = @_; + return 'unknown' unless defined $element; + if ( $license_map_1{lc $element} ) { + return $license_map_1{lc $element}; + } + else { + return 'unknown'; + } + } + + my @valid_licenses_2 = qw( + agpl_3 + apache_1_1 + apache_2_0 + artistic_1 + artistic_2 + bsd + freebsd + gfdl_1_2 + gfdl_1_3 + gpl_1 + gpl_2 + gpl_3 + lgpl_2_1 + lgpl_3_0 + mit + mozilla_1_0 + mozilla_1_1 + openssl + perl_5 + qpl_1_0 + ssleay + sun + zlib + open_source + restricted + unrestricted + unknown + ); + + # The "old" values were defined by Module::Build, and were often vague. I have + # made the decisions below based on reading Module::Build::API and how clearly + # it specifies the version of the license. + my %license_map_2 = ( + (map { $_ => $_ } @valid_licenses_2), + apache => 'apache_2_0', # clearly stated as 2.0 + artistic => 'artistic_1', # clearly stated as 1 + artistic2 => 'artistic_2', # clearly stated as 2 + gpl => 'open_source', # we don't know which GPL; punt + lgpl => 'open_source', # we don't know which LGPL; punt + mozilla => 'open_source', # we don't know which MPL; punt + perl => 'perl_5', # clearly Perl 5 + restrictive => 'restricted', + ); + + sub _license_2 { + my ($element) = @_; + return [ 'unknown' ] unless defined $element; + $element = [ $element ] unless ref $element eq 'ARRAY'; + my @new_list; + for my $lic ( @$element ) { + next unless defined $lic; + if ( my $new = $license_map_2{lc $lic} ) { + push @new_list, $new; + } + } + return @new_list ? \@new_list : [ 'unknown' ]; + } + + my %license_downgrade_map = qw( + agpl_3 open_source + apache_1_1 apache + apache_2_0 apache + artistic_1 artistic + artistic_2 artistic_2 + bsd bsd + freebsd open_source + gfdl_1_2 open_source + gfdl_1_3 open_source + gpl_1 gpl + gpl_2 gpl + gpl_3 gpl + lgpl_2_1 lgpl + lgpl_3_0 lgpl + mit mit + mozilla_1_0 mozilla + mozilla_1_1 mozilla + openssl open_source + perl_5 perl + qpl_1_0 open_source + ssleay open_source + sun open_source + zlib open_source + open_source open_source + restricted restrictive + unrestricted unrestricted + unknown unknown + ); + + sub _downgrade_license { + my ($element) = @_; + if ( ! defined $element ) { + return "unknown"; + } + elsif( ref $element eq 'ARRAY' ) { + if ( @$element > 1) { + if (grep { !$is_open_source{ $license_downgrade_map{lc $_} || 'unknown' } } @$element) { + return 'unknown'; + } + else { + return 'open_source'; + } + } + elsif ( @$element == 1 ) { + return $license_downgrade_map{lc $element->[0]} || "unknown"; + } + } + elsif ( ! ref $element ) { + return $license_downgrade_map{lc $element} || "unknown"; + } + return "unknown"; + } + + my $no_index_spec_1_2 = { + 'file' => \&_listify, + 'dir' => \&_listify, + 'package' => \&_listify, + 'namespace' => \&_listify, + }; + + my $no_index_spec_1_3 = { + 'file' => \&_listify, + 'directory' => \&_listify, + 'package' => \&_listify, + 'namespace' => \&_listify, + }; + + my $no_index_spec_2 = { + 'file' => \&_listify, + 'directory' => \&_listify, + 'package' => \&_listify, + 'namespace' => \&_listify, + ':custom' => \&_prefix_custom, + }; + + sub _no_index_1_2 { + my (undef, undef, $meta) = @_; + my $no_index = $meta->{no_index} || $meta->{private}; + return unless $no_index; + + # cleanup wrong format + if ( ! ref $no_index ) { + my $item = $no_index; + $no_index = { dir => [ $item ], file => [ $item ] }; + } + elsif ( ref $no_index eq 'ARRAY' ) { + my $list = $no_index; + $no_index = { dir => [ @$list ], file => [ @$list ] }; + } + + # common mistake: files -> file + if ( exists $no_index->{files} ) { + $no_index->{file} = delete $no_index->{file}; + } + # common mistake: modules -> module + if ( exists $no_index->{modules} ) { + $no_index->{module} = delete $no_index->{module}; + } + return _convert($no_index, $no_index_spec_1_2); + } + + sub _no_index_directory { + my ($element, $key, $meta, $version) = @_; + return unless $element; + + # cleanup wrong format + if ( ! ref $element ) { + my $item = $element; + $element = { directory => [ $item ], file => [ $item ] }; + } + elsif ( ref $element eq 'ARRAY' ) { + my $list = $element; + $element = { directory => [ @$list ], file => [ @$list ] }; + } + + if ( exists $element->{dir} ) { + $element->{directory} = delete $element->{dir}; + } + # common mistake: files -> file + if ( exists $element->{files} ) { + $element->{file} = delete $element->{file}; + } + # common mistake: modules -> module + if ( exists $element->{modules} ) { + $element->{module} = delete $element->{module}; + } + my $spec = $version == 2 ? $no_index_spec_2 : $no_index_spec_1_3; + return _convert($element, $spec); + } + + sub _is_module_name { + my $mod = shift; + return unless defined $mod && length $mod; + return $mod =~ m{^[A-Za-z][A-Za-z0-9_]*(?:::[A-Za-z0-9_]+)*$}; + } + + sub _clean_version { + my ($element) = @_; + return 0 if ! defined $element; + + $element =~ s{^\s*}{}; + $element =~ s{\s*$}{}; + $element =~ s{^\.}{0.}; + + return 0 if ! length $element; + return 0 if ( $element eq 'undef' || $element eq '' ); + + my $v = eval { version->new($element) }; + # XXX check defined $v and not just $v because version objects leak memory + # in boolean context -- dagolden, 2012-02-03 + if ( defined $v ) { + return _is_qv($v) ? $v->normal : $element; + } + else { + return 0; + } + } + + sub _bad_version_hook { + my ($v) = @_; + $v =~ s{[a-z]+$}{}; # strip trailing alphabetics + my $vobj = eval { version->new($v) }; + return defined($vobj) ? $vobj : version->new(0); # or give up + } + + sub _version_map { + my ($element) = @_; + return unless defined $element; + if ( ref $element eq 'HASH' ) { + # XXX turn this into CPAN::Meta::Requirements with bad version hook + # and then turn it back into a hash + my $new_map = CPAN::Meta::Requirements->new( + { bad_version_hook => \&_bad_version_hook } # punt + ); + while ( my ($k,$v) = each %$element ) { + next unless _is_module_name($k); + if ( !defined($v) || !length($v) || $v eq 'undef' || $v eq '' ) { + $v = 0; + } + # some weird, old META have bad yml with module => module + # so check if value is like a module name and not like a version + if ( _is_module_name($v) && ! version::is_lax($v) ) { + $new_map->add_minimum($k => 0); + $new_map->add_minimum($v => 0); + } + $new_map->add_string_requirement($k => $v); + } + return $new_map->as_string_hash; + } + elsif ( ref $element eq 'ARRAY' ) { + my $hashref = { map { $_ => 0 } @$element }; + return _version_map($hashref); # cleanup any weird stuff + } + elsif ( ref $element eq '' && length $element ) { + return { $element => 0 } + } + return; + } + + sub _prereqs_from_1 { + my (undef, undef, $meta) = @_; + my $prereqs = {}; + for my $phase ( qw/build configure/ ) { + my $key = "${phase}_requires"; + $prereqs->{$phase}{requires} = _version_map($meta->{$key}) + if $meta->{$key}; + } + for my $rel ( qw/requires recommends conflicts/ ) { + $prereqs->{runtime}{$rel} = _version_map($meta->{$rel}) + if $meta->{$rel}; + } + return $prereqs; + } + + my $prereqs_spec = { + configure => \&_prereqs_rel, + build => \&_prereqs_rel, + test => \&_prereqs_rel, + runtime => \&_prereqs_rel, + develop => \&_prereqs_rel, + ':custom' => \&_prefix_custom, + }; + + my $relation_spec = { + requires => \&_version_map, + recommends => \&_version_map, + suggests => \&_version_map, + conflicts => \&_version_map, + ':custom' => \&_prefix_custom, + }; + + sub _cleanup_prereqs { + my ($prereqs, $key, $meta, $to_version) = @_; + return unless $prereqs && ref $prereqs eq 'HASH'; + return _convert( $prereqs, $prereqs_spec, $to_version ); + } + + sub _prereqs_rel { + my ($relation, $key, $meta, $to_version) = @_; + return unless $relation && ref $relation eq 'HASH'; + return _convert( $relation, $relation_spec, $to_version ); + } + + + BEGIN { + my @old_prereqs = qw( + requires + configure_requires + recommends + conflicts + ); + + for ( @old_prereqs ) { + my $sub = "_get_$_"; + my ($phase,$type) = split qr/_/, $_; + if ( ! defined $type ) { + $type = $phase; + $phase = 'runtime'; + } + no strict 'refs'; + *{$sub} = sub { _extract_prereqs($_[2]->{prereqs},$phase,$type) }; + } + } + + sub _get_build_requires { + my ($data, $key, $meta) = @_; + + my $test_h = _extract_prereqs($_[2]->{prereqs}, qw(test requires)) || {}; + my $build_h = _extract_prereqs($_[2]->{prereqs}, qw(build requires)) || {}; + + my $test_req = CPAN::Meta::Requirements->from_string_hash($test_h); + my $build_req = CPAN::Meta::Requirements->from_string_hash($build_h); + + $test_req->add_requirements($build_req)->as_string_hash; + } + + sub _extract_prereqs { + my ($prereqs, $phase, $type) = @_; + return unless ref $prereqs eq 'HASH'; + return scalar _version_map($prereqs->{$phase}{$type}); + } + + sub _downgrade_optional_features { + my (undef, undef, $meta) = @_; + return unless exists $meta->{optional_features}; + my $origin = $meta->{optional_features}; + my $features = {}; + for my $name ( keys %$origin ) { + $features->{$name} = { + description => $origin->{$name}{description}, + requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','requires'), + configure_requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','configure_requires'), + build_requires => _extract_prereqs($origin->{$name}{prereqs},'runtime','build_requires'), + recommends => _extract_prereqs($origin->{$name}{prereqs},'runtime','recommends'), + conflicts => _extract_prereqs($origin->{$name}{prereqs},'runtime','conflicts'), + }; + for my $k (keys %{$features->{$name}} ) { + delete $features->{$name}{$k} unless defined $features->{$name}{$k}; + } + } + return $features; + } + + sub _upgrade_optional_features { + my (undef, undef, $meta) = @_; + return unless exists $meta->{optional_features}; + my $origin = $meta->{optional_features}; + my $features = {}; + for my $name ( keys %$origin ) { + $features->{$name} = { + description => $origin->{$name}{description}, + prereqs => _prereqs_from_1(undef, undef, $origin->{$name}), + }; + delete $features->{$name}{prereqs}{configure}; + } + return $features; + } + + my $optional_features_2_spec = { + description => \&_keep, + prereqs => \&_cleanup_prereqs, + ':custom' => \&_prefix_custom, + }; + + sub _feature_2 { + my ($element, $key, $meta, $to_version) = @_; + return unless $element && ref $element eq 'HASH'; + _convert( $element, $optional_features_2_spec, $to_version ); + } + + sub _cleanup_optional_features_2 { + my ($element, $key, $meta, $to_version) = @_; + return unless $element && ref $element eq 'HASH'; + my $new_data = {}; + for my $k ( keys %$element ) { + $new_data->{$k} = _feature_2( $element->{$k}, $k, $meta, $to_version ); + } + return unless keys %$new_data; + return $new_data; + } + + sub _optional_features_1_4 { + my ($element) = @_; + return unless $element; + $element = _optional_features_as_map($element); + for my $name ( keys %$element ) { + for my $drop ( qw/requires_packages requires_os excluded_os/ ) { + delete $element->{$name}{$drop}; + } + } + return $element; + } + + sub _optional_features_as_map { + my ($element) = @_; + return unless $element; + if ( ref $element eq 'ARRAY' ) { + my %map; + for my $feature ( @$element ) { + my (@parts) = %$feature; + $map{$parts[0]} = $parts[1]; + } + $element = \%map; + } + return $element; + } + + sub _is_urlish { defined $_[0] && $_[0] =~ m{\A[-+.a-z0-9]+:.+}i } + + sub _url_or_drop { + my ($element) = @_; + return $element if _is_urlish($element); + return; + } + + sub _url_list { + my ($element) = @_; + return unless $element; + $element = _listify( $element ); + $element = [ grep { _is_urlish($_) } @$element ]; + return unless @$element; + return $element; + } + + sub _author_list { + my ($element) = @_; + return [ 'unknown' ] unless $element; + $element = _listify( $element ); + $element = [ map { defined $_ && length $_ ? $_ : 'unknown' } @$element ]; + return [ 'unknown' ] unless @$element; + return $element; + } + + my $resource2_upgrade = { + license => sub { return _is_urlish($_[0]) ? _listify( $_[0] ) : undef }, + homepage => \&_url_or_drop, + bugtracker => sub { + my ($item) = @_; + return unless $item; + if ( $item =~ m{^mailto:(.*)$} ) { return { mailto => $1 } } + elsif( _is_urlish($item) ) { return { web => $item } } + else { return } + }, + repository => sub { return _is_urlish($_[0]) ? { url => $_[0] } : undef }, + ':custom' => \&_prefix_custom, + }; + + sub _upgrade_resources_2 { + my (undef, undef, $meta, $version) = @_; + return unless exists $meta->{resources}; + return _convert($meta->{resources}, $resource2_upgrade); + } + + my $bugtracker2_spec = { + web => \&_url_or_drop, + mailto => \&_keep, + ':custom' => \&_prefix_custom, + }; + + sub _repo_type { + my ($element, $key, $meta, $to_version) = @_; + return $element if defined $element; + return unless exists $meta->{url}; + my $repo_url = $meta->{url}; + for my $type ( qw/git svn/ ) { + return $type if $repo_url =~ m{\A$type}; + } + return; + } + + my $repository2_spec = { + web => \&_url_or_drop, + url => \&_url_or_drop, + type => \&_repo_type, + ':custom' => \&_prefix_custom, + }; + + my $resources2_cleanup = { + license => \&_url_list, + homepage => \&_url_or_drop, + bugtracker => sub { ref $_[0] ? _convert( $_[0], $bugtracker2_spec ) : undef }, + repository => sub { my $data = shift; ref $data ? _convert( $data, $repository2_spec ) : undef }, + ':custom' => \&_prefix_custom, + }; + + sub _cleanup_resources_2 { + my ($resources, $key, $meta, $to_version) = @_; + return unless $resources && ref $resources eq 'HASH'; + return _convert($resources, $resources2_cleanup, $to_version); + } + + my $resource1_spec = { + license => \&_url_or_drop, + homepage => \&_url_or_drop, + bugtracker => \&_url_or_drop, + repository => \&_url_or_drop, + ':custom' => \&_keep, + }; + + sub _resources_1_3 { + my (undef, undef, $meta, $version) = @_; + return unless exists $meta->{resources}; + return _convert($meta->{resources}, $resource1_spec); + } + + *_resources_1_4 = *_resources_1_3; + + sub _resources_1_2 { + my (undef, undef, $meta) = @_; + my $resources = $meta->{resources} || {}; + if ( $meta->{license_url} && ! $resources->{license} ) { + $resources->{license} = $meta->{license_url} + if _is_urlish($meta->{license_url}); + } + return unless keys %$resources; + return _convert($resources, $resource1_spec); + } + + my $resource_downgrade_spec = { + license => sub { return ref $_[0] ? $_[0]->[0] : $_[0] }, + homepage => \&_url_or_drop, + bugtracker => sub { return $_[0]->{web} }, + repository => sub { return $_[0]->{url} || $_[0]->{web} }, + ':custom' => \&_no_prefix_ucfirst_custom, + }; + + sub _downgrade_resources { + my (undef, undef, $meta, $version) = @_; + return unless exists $meta->{resources}; + return _convert($meta->{resources}, $resource_downgrade_spec); + } + + sub _release_status { + my ($element, undef, $meta) = @_; + return $element if $element && $element =~ m{\A(?:stable|testing|unstable)\z}; + return _release_status_from_version(undef, undef, $meta); + } + + sub _release_status_from_version { + my (undef, undef, $meta) = @_; + my $version = $meta->{version} || ''; + return ( $version =~ /_/ ) ? 'testing' : 'stable'; + } + + my $provides_spec = { + file => \&_keep, + version => \&_keep, + }; + + my $provides_spec_2 = { + file => \&_keep, + version => \&_keep, + ':custom' => \&_prefix_custom, + }; + + sub _provides { + my ($element, $key, $meta, $to_version) = @_; + return unless defined $element && ref $element eq 'HASH'; + my $spec = $to_version == 2 ? $provides_spec_2 : $provides_spec; + my $new_data = {}; + for my $k ( keys %$element ) { + $new_data->{$k} = _convert($element->{$k}, $spec, $to_version); + $new_data->{$k}{version} = _clean_version($element->{$k}{version}) + if exists $element->{$k}{version}; + } + return $new_data; + } + + sub _convert { + my ($data, $spec, $to_version, $is_fragment) = @_; + + my $new_data = {}; + for my $key ( keys %$spec ) { + next if $key eq ':custom' || $key eq ':drop'; + next unless my $fcn = $spec->{$key}; + if ( $is_fragment && $key eq 'generated_by' ) { + $fcn = \&_keep; + } + die "spec for '$key' is not a coderef" + unless ref $fcn && ref $fcn eq 'CODE'; + my $new_value = $fcn->($data->{$key}, $key, $data, $to_version); + $new_data->{$key} = $new_value if defined $new_value; + } + + my $drop_list = $spec->{':drop'}; + my $customizer = $spec->{':custom'} || \&_keep; + + for my $key ( keys %$data ) { + next if $drop_list && grep { $key eq $_ } @$drop_list; + next if exists $spec->{$key}; # we handled it + $new_data->{ $customizer->($key) } = $data->{$key}; + } + + return $new_data; + } + + #--------------------------------------------------------------------------# + # define converters for each conversion + #--------------------------------------------------------------------------# + + # each converts from prior version + # special ":custom" field is used for keys not recognized in spec + my %up_convert = ( + '2-from-1.4' => { + # PRIOR MANDATORY + 'abstract' => \&_keep_or_unknown, + 'author' => \&_author_list, + 'generated_by' => \&_generated_by, + 'license' => \&_license_2, + 'meta-spec' => \&_change_meta_spec, + 'name' => \&_keep, + 'version' => \&_keep, + # CHANGED TO MANDATORY + 'dynamic_config' => \&_keep_or_one, + # ADDED MANDATORY + 'release_status' => \&_release_status_from_version, + # PRIOR OPTIONAL + 'keywords' => \&_keep, + 'no_index' => \&_no_index_directory, + 'optional_features' => \&_upgrade_optional_features, + 'provides' => \&_provides, + 'resources' => \&_upgrade_resources_2, + # ADDED OPTIONAL + 'description' => \&_keep, + 'prereqs' => \&_prereqs_from_1, + + # drop these deprecated fields, but only after we convert + ':drop' => [ qw( + build_requires + configure_requires + conflicts + distribution_type + license_url + private + recommends + requires + ) ], + + # other random keys need x_ prefixing + ':custom' => \&_prefix_custom, + }, + '1.4-from-1.3' => { + # PRIOR MANDATORY + 'abstract' => \&_keep_or_unknown, + 'author' => \&_author_list, + 'generated_by' => \&_generated_by, + 'license' => \&_license_1, + 'meta-spec' => \&_change_meta_spec, + 'name' => \&_keep, + 'version' => \&_keep, + # PRIOR OPTIONAL + 'build_requires' => \&_version_map, + 'conflicts' => \&_version_map, + 'distribution_type' => \&_keep, + 'dynamic_config' => \&_keep_or_one, + 'keywords' => \&_keep, + 'no_index' => \&_no_index_directory, + 'optional_features' => \&_optional_features_1_4, + 'provides' => \&_provides, + 'recommends' => \&_version_map, + 'requires' => \&_version_map, + 'resources' => \&_resources_1_4, + # ADDED OPTIONAL + 'configure_requires' => \&_keep, + + # drop these deprecated fields, but only after we convert + ':drop' => [ qw( + license_url + private + )], + + # other random keys are OK if already valid + ':custom' => \&_keep + }, + '1.3-from-1.2' => { + # PRIOR MANDATORY + 'abstract' => \&_keep_or_unknown, + 'author' => \&_author_list, + 'generated_by' => \&_generated_by, + 'license' => \&_license_1, + 'meta-spec' => \&_change_meta_spec, + 'name' => \&_keep, + 'version' => \&_keep, + # PRIOR OPTIONAL + 'build_requires' => \&_version_map, + 'conflicts' => \&_version_map, + 'distribution_type' => \&_keep, + 'dynamic_config' => \&_keep_or_one, + 'keywords' => \&_keep, + 'no_index' => \&_no_index_directory, + 'optional_features' => \&_optional_features_as_map, + 'provides' => \&_provides, + 'recommends' => \&_version_map, + 'requires' => \&_version_map, + 'resources' => \&_resources_1_3, + + # drop these deprecated fields, but only after we convert + ':drop' => [ qw( + license_url + private + )], + + # other random keys are OK if already valid + ':custom' => \&_keep + }, + '1.2-from-1.1' => { + # PRIOR MANDATORY + 'version' => \&_keep, + # CHANGED TO MANDATORY + 'license' => \&_license_1, + 'name' => \&_keep, + 'generated_by' => \&_generated_by, + # ADDED MANDATORY + 'abstract' => \&_keep_or_unknown, + 'author' => \&_author_list, + 'meta-spec' => \&_change_meta_spec, + # PRIOR OPTIONAL + 'build_requires' => \&_version_map, + 'conflicts' => \&_version_map, + 'distribution_type' => \&_keep, + 'dynamic_config' => \&_keep_or_one, + 'recommends' => \&_version_map, + 'requires' => \&_version_map, + # ADDED OPTIONAL + 'keywords' => \&_keep, + 'no_index' => \&_no_index_1_2, + 'optional_features' => \&_optional_features_as_map, + 'provides' => \&_provides, + 'resources' => \&_resources_1_2, + + # drop these deprecated fields, but only after we convert + ':drop' => [ qw( + license_url + private + )], + + # other random keys are OK if already valid + ':custom' => \&_keep + }, + '1.1-from-1.0' => { + # CHANGED TO MANDATORY + 'version' => \&_keep, + # IMPLIED MANDATORY + 'name' => \&_keep, + # PRIOR OPTIONAL + 'build_requires' => \&_version_map, + 'conflicts' => \&_version_map, + 'distribution_type' => \&_keep, + 'dynamic_config' => \&_keep_or_one, + 'generated_by' => \&_generated_by, + 'license' => \&_license_1, + 'recommends' => \&_version_map, + 'requires' => \&_version_map, + # ADDED OPTIONAL + 'license_url' => \&_url_or_drop, + 'private' => \&_keep, + + # other random keys are OK if already valid + ':custom' => \&_keep + }, + ); + + my %down_convert = ( + '1.4-from-2' => { + # MANDATORY + 'abstract' => \&_keep_or_unknown, + 'author' => \&_author_list, + 'generated_by' => \&_generated_by, + 'license' => \&_downgrade_license, + 'meta-spec' => \&_change_meta_spec, + 'name' => \&_keep, + 'version' => \&_keep, + # OPTIONAL + 'build_requires' => \&_get_build_requires, + 'configure_requires' => \&_get_configure_requires, + 'conflicts' => \&_get_conflicts, + 'distribution_type' => \&_keep, + 'dynamic_config' => \&_keep_or_one, + 'keywords' => \&_keep, + 'no_index' => \&_no_index_directory, + 'optional_features' => \&_downgrade_optional_features, + 'provides' => \&_provides, + 'recommends' => \&_get_recommends, + 'requires' => \&_get_requires, + 'resources' => \&_downgrade_resources, + + # drop these unsupported fields (after conversion) + ':drop' => [ qw( + description + prereqs + release_status + )], + + # custom keys will be left unchanged + ':custom' => \&_keep + }, + '1.3-from-1.4' => { + # MANDATORY + 'abstract' => \&_keep_or_unknown, + 'author' => \&_author_list, + 'generated_by' => \&_generated_by, + 'license' => \&_license_1, + 'meta-spec' => \&_change_meta_spec, + 'name' => \&_keep, + 'version' => \&_keep, + # OPTIONAL + 'build_requires' => \&_version_map, + 'conflicts' => \&_version_map, + 'distribution_type' => \&_keep, + 'dynamic_config' => \&_keep_or_one, + 'keywords' => \&_keep, + 'no_index' => \&_no_index_directory, + 'optional_features' => \&_optional_features_as_map, + 'provides' => \&_provides, + 'recommends' => \&_version_map, + 'requires' => \&_version_map, + 'resources' => \&_resources_1_3, + + # drop these unsupported fields, but only after we convert + ':drop' => [ qw( + configure_requires + )], + + # other random keys are OK if already valid + ':custom' => \&_keep, + }, + '1.2-from-1.3' => { + # MANDATORY + 'abstract' => \&_keep_or_unknown, + 'author' => \&_author_list, + 'generated_by' => \&_generated_by, + 'license' => \&_license_1, + 'meta-spec' => \&_change_meta_spec, + 'name' => \&_keep, + 'version' => \&_keep, + # OPTIONAL + 'build_requires' => \&_version_map, + 'conflicts' => \&_version_map, + 'distribution_type' => \&_keep, + 'dynamic_config' => \&_keep_or_one, + 'keywords' => \&_keep, + 'no_index' => \&_no_index_1_2, + 'optional_features' => \&_optional_features_as_map, + 'provides' => \&_provides, + 'recommends' => \&_version_map, + 'requires' => \&_version_map, + 'resources' => \&_resources_1_3, + + # other random keys are OK if already valid + ':custom' => \&_keep, + }, + '1.1-from-1.2' => { + # MANDATORY + 'version' => \&_keep, + # IMPLIED MANDATORY + 'name' => \&_keep, + 'meta-spec' => \&_change_meta_spec, + # OPTIONAL + 'build_requires' => \&_version_map, + 'conflicts' => \&_version_map, + 'distribution_type' => \&_keep, + 'dynamic_config' => \&_keep_or_one, + 'generated_by' => \&_generated_by, + 'license' => \&_license_1, + 'private' => \&_keep, + 'recommends' => \&_version_map, + 'requires' => \&_version_map, + + # drop unsupported fields + ':drop' => [ qw( + abstract + author + provides + no_index + keywords + resources + )], + + # other random keys are OK if already valid + ':custom' => \&_keep, + }, + '1.0-from-1.1' => { + # IMPLIED MANDATORY + 'name' => \&_keep, + 'meta-spec' => \&_change_meta_spec, + 'version' => \&_keep, + # PRIOR OPTIONAL + 'build_requires' => \&_version_map, + 'conflicts' => \&_version_map, + 'distribution_type' => \&_keep, + 'dynamic_config' => \&_keep_or_one, + 'generated_by' => \&_generated_by, + 'license' => \&_license_1, + 'recommends' => \&_version_map, + 'requires' => \&_version_map, + + # other random keys are OK if already valid + ':custom' => \&_keep, + }, + ); + + my %cleanup = ( + '2' => { + # PRIOR MANDATORY + 'abstract' => \&_keep_or_unknown, + 'author' => \&_author_list, + 'generated_by' => \&_generated_by, + 'license' => \&_license_2, + 'meta-spec' => \&_change_meta_spec, + 'name' => \&_keep, + 'version' => \&_keep, + # CHANGED TO MANDATORY + 'dynamic_config' => \&_keep_or_one, + # ADDED MANDATORY + 'release_status' => \&_release_status, + # PRIOR OPTIONAL + 'keywords' => \&_keep, + 'no_index' => \&_no_index_directory, + 'optional_features' => \&_cleanup_optional_features_2, + 'provides' => \&_provides, + 'resources' => \&_cleanup_resources_2, + # ADDED OPTIONAL + 'description' => \&_keep, + 'prereqs' => \&_cleanup_prereqs, + + # drop these deprecated fields, but only after we convert + ':drop' => [ qw( + build_requires + configure_requires + conflicts + distribution_type + license_url + private + recommends + requires + ) ], + + # other random keys need x_ prefixing + ':custom' => \&_prefix_custom, + }, + '1.4' => { + # PRIOR MANDATORY + 'abstract' => \&_keep_or_unknown, + 'author' => \&_author_list, + 'generated_by' => \&_generated_by, + 'license' => \&_license_1, + 'meta-spec' => \&_change_meta_spec, + 'name' => \&_keep, + 'version' => \&_keep, + # PRIOR OPTIONAL + 'build_requires' => \&_version_map, + 'conflicts' => \&_version_map, + 'distribution_type' => \&_keep, + 'dynamic_config' => \&_keep_or_one, + 'keywords' => \&_keep, + 'no_index' => \&_no_index_directory, + 'optional_features' => \&_optional_features_1_4, + 'provides' => \&_provides, + 'recommends' => \&_version_map, + 'requires' => \&_version_map, + 'resources' => \&_resources_1_4, + # ADDED OPTIONAL + 'configure_requires' => \&_keep, + + # other random keys are OK if already valid + ':custom' => \&_keep + }, + '1.3' => { + # PRIOR MANDATORY + 'abstract' => \&_keep_or_unknown, + 'author' => \&_author_list, + 'generated_by' => \&_generated_by, + 'license' => \&_license_1, + 'meta-spec' => \&_change_meta_spec, + 'name' => \&_keep, + 'version' => \&_keep, + # PRIOR OPTIONAL + 'build_requires' => \&_version_map, + 'conflicts' => \&_version_map, + 'distribution_type' => \&_keep, + 'dynamic_config' => \&_keep_or_one, + 'keywords' => \&_keep, + 'no_index' => \&_no_index_directory, + 'optional_features' => \&_optional_features_as_map, + 'provides' => \&_provides, + 'recommends' => \&_version_map, + 'requires' => \&_version_map, + 'resources' => \&_resources_1_3, + + # other random keys are OK if already valid + ':custom' => \&_keep + }, + '1.2' => { + # PRIOR MANDATORY + 'version' => \&_keep, + # CHANGED TO MANDATORY + 'license' => \&_license_1, + 'name' => \&_keep, + 'generated_by' => \&_generated_by, + # ADDED MANDATORY + 'abstract' => \&_keep_or_unknown, + 'author' => \&_author_list, + 'meta-spec' => \&_change_meta_spec, + # PRIOR OPTIONAL + 'build_requires' => \&_version_map, + 'conflicts' => \&_version_map, + 'distribution_type' => \&_keep, + 'dynamic_config' => \&_keep_or_one, + 'recommends' => \&_version_map, + 'requires' => \&_version_map, + # ADDED OPTIONAL + 'keywords' => \&_keep, + 'no_index' => \&_no_index_1_2, + 'optional_features' => \&_optional_features_as_map, + 'provides' => \&_provides, + 'resources' => \&_resources_1_2, + + # other random keys are OK if already valid + ':custom' => \&_keep + }, + '1.1' => { + # CHANGED TO MANDATORY + 'version' => \&_keep, + # IMPLIED MANDATORY + 'name' => \&_keep, + 'meta-spec' => \&_change_meta_spec, + # PRIOR OPTIONAL + 'build_requires' => \&_version_map, + 'conflicts' => \&_version_map, + 'distribution_type' => \&_keep, + 'dynamic_config' => \&_keep_or_one, + 'generated_by' => \&_generated_by, + 'license' => \&_license_1, + 'recommends' => \&_version_map, + 'requires' => \&_version_map, + # ADDED OPTIONAL + 'license_url' => \&_url_or_drop, + 'private' => \&_keep, + + # other random keys are OK if already valid + ':custom' => \&_keep + }, + '1.0' => { + # IMPLIED MANDATORY + 'name' => \&_keep, + 'meta-spec' => \&_change_meta_spec, + 'version' => \&_keep, + # IMPLIED OPTIONAL + 'build_requires' => \&_version_map, + 'conflicts' => \&_version_map, + 'distribution_type' => \&_keep, + 'dynamic_config' => \&_keep_or_one, + 'generated_by' => \&_generated_by, + 'license' => \&_license_1, + 'recommends' => \&_version_map, + 'requires' => \&_version_map, + + # other random keys are OK if already valid + ':custom' => \&_keep, + }, + ); + + # for a given field in a spec version, what fields will it feed + # into in the *latest* spec (i.e. v2); meta-spec omitted because + # we always expect a meta-spec to be generated + my %fragments_generate = ( + '2' => { + 'abstract' => 'abstract', + 'author' => 'author', + 'generated_by' => 'generated_by', + 'license' => 'license', + 'name' => 'name', + 'version' => 'version', + 'dynamic_config' => 'dynamic_config', + 'release_status' => 'release_status', + 'keywords' => 'keywords', + 'no_index' => 'no_index', + 'optional_features' => 'optional_features', + 'provides' => 'provides', + 'resources' => 'resources', + 'description' => 'description', + 'prereqs' => 'prereqs', + }, + '1.4' => { + 'abstract' => 'abstract', + 'author' => 'author', + 'generated_by' => 'generated_by', + 'license' => 'license', + 'name' => 'name', + 'version' => 'version', + 'build_requires' => 'prereqs', + 'conflicts' => 'prereqs', + 'distribution_type' => 'distribution_type', + 'dynamic_config' => 'dynamic_config', + 'keywords' => 'keywords', + 'no_index' => 'no_index', + 'optional_features' => 'optional_features', + 'provides' => 'provides', + 'recommends' => 'prereqs', + 'requires' => 'prereqs', + 'resources' => 'resources', + 'configure_requires' => 'prereqs', + }, + ); + # this is not quite true but will work well enough + # as 1.4 is a superset of earlier ones + $fragments_generate{$_} = $fragments_generate{'1.4'} for qw/1.3 1.2 1.1 1.0/; + + #--------------------------------------------------------------------------# + # Code + #--------------------------------------------------------------------------# + + #pod =method new + #pod + #pod my $cmc = CPAN::Meta::Converter->new( $struct ); + #pod + #pod The constructor should be passed a valid metadata structure but invalid + #pod structures are accepted. If no meta-spec version is provided, version 1.0 will + #pod be assumed. + #pod + #pod Optionally, you can provide a C argument after C<$struct>: + #pod + #pod my $cmc = CPAN::Meta::Converter->new( $struct, default_version => "1.4" ); + #pod + #pod This is only needed when converting a metadata fragment that does not include a + #pod C field. + #pod + #pod =cut + + sub new { + my ($class,$data,%args) = @_; + + # create an attributes hash + my $self = { + 'data' => $data, + 'spec' => _extract_spec_version($data, $args{default_version}), + }; + + # create the object + return bless $self, $class; + } + + sub _extract_spec_version { + my ($data, $default) = @_; + my $spec = $data->{'meta-spec'}; + + # is meta-spec there and valid? + return( $default || "1.0" ) unless defined $spec && ref $spec eq 'HASH'; # before meta-spec? + + # does the version key look like a valid version? + my $v = $spec->{version}; + if ( defined $v && $v =~ /^\d+(?:\.\d+)?$/ ) { + return $v if defined $v && grep { $v eq $_ } keys %known_specs; # known spec + return $v+0 if defined $v && grep { $v == $_ } keys %known_specs; # 2.0 => 2 + } + + # otherwise, use heuristics: look for 1.x vs 2.0 fields + return "2" if exists $data->{prereqs}; + return "1.4" if exists $data->{configure_requires}; + return( $default || "1.2" ); # when meta-spec was first defined + } + + #pod =method convert + #pod + #pod my $new_struct = $cmc->convert( version => "2" ); + #pod + #pod Returns a new hash reference with the metadata converted to a different form. + #pod C will die if any conversion/standardization still results in an + #pod invalid structure. + #pod + #pod Valid parameters include: + #pod + #pod =over + #pod + #pod =item * + #pod + #pod C -- Indicates the desired specification version (e.g. "1.0", "1.1" ... "1.4", "2"). + #pod Defaults to the latest version of the CPAN Meta Spec. + #pod + #pod =back + #pod + #pod Conversion proceeds through each version in turn. For example, a version 1.2 + #pod structure might be converted to 1.3 then 1.4 then finally to version 2. The + #pod conversion process attempts to clean-up simple errors and standardize data. + #pod For example, if C is given as a scalar, it will converted to an array + #pod reference containing the item. (Converting a structure to its own version will + #pod also clean-up and standardize.) + #pod + #pod When data are cleaned and standardized, missing or invalid fields will be + #pod replaced with sensible defaults when possible. This may be lossy or imprecise. + #pod For example, some badly structured META.yml files on CPAN have prerequisite + #pod modules listed as both keys and values: + #pod + #pod requires => { 'Foo::Bar' => 'Bam::Baz' } + #pod + #pod These would be split and each converted to a prerequisite with a minimum + #pod version of zero. + #pod + #pod When some mandatory fields are missing or invalid, the conversion will attempt + #pod to provide a sensible default or will fill them with a value of 'unknown'. For + #pod example a missing or unrecognized C field will result in a C + #pod field of 'unknown'. Fields that may get an 'unknown' include: + #pod + #pod =for :list + #pod * abstract + #pod * author + #pod * license + #pod + #pod =cut + + sub convert { + my ($self, %args) = @_; + my $args = { %args }; + + my $new_version = $args->{version} || $HIGHEST; + my $is_fragment = $args->{is_fragment}; + + my ($old_version) = $self->{spec}; + my $converted = _dclone($self->{data}); + + if ( $old_version == $new_version ) { + $converted = _convert( $converted, $cleanup{$old_version}, $old_version, $is_fragment ); + unless ( $args->{is_fragment} ) { + my $cmv = CPAN::Meta::Validator->new( $converted ); + unless ( $cmv->is_valid ) { + my $errs = join("\n", $cmv->errors); + die "Failed to clean-up $old_version metadata. Errors:\n$errs\n"; + } + } + return $converted; + } + elsif ( $old_version > $new_version ) { + my @vers = sort { $b <=> $a } keys %known_specs; + for my $i ( 0 .. $#vers-1 ) { + next if $vers[$i] > $old_version; + last if $vers[$i+1] < $new_version; + my $spec_string = "$vers[$i+1]-from-$vers[$i]"; + $converted = _convert( $converted, $down_convert{$spec_string}, $vers[$i+1], $is_fragment ); + unless ( $args->{is_fragment} ) { + my $cmv = CPAN::Meta::Validator->new( $converted ); + unless ( $cmv->is_valid ) { + my $errs = join("\n", $cmv->errors); + die "Failed to downconvert metadata to $vers[$i+1]. Errors:\n$errs\n"; + } + } + } + return $converted; + } + else { + my @vers = sort { $a <=> $b } keys %known_specs; + for my $i ( 0 .. $#vers-1 ) { + next if $vers[$i] < $old_version; + last if $vers[$i+1] > $new_version; + my $spec_string = "$vers[$i+1]-from-$vers[$i]"; + $converted = _convert( $converted, $up_convert{$spec_string}, $vers[$i+1], $is_fragment ); + unless ( $args->{is_fragment} ) { + my $cmv = CPAN::Meta::Validator->new( $converted ); + unless ( $cmv->is_valid ) { + my $errs = join("\n", $cmv->errors); + die "Failed to upconvert metadata to $vers[$i+1]. Errors:\n$errs\n"; + } + } + } + return $converted; + } + } + + #pod =method upgrade_fragment + #pod + #pod my $new_struct = $cmc->upgrade_fragment; + #pod + #pod Returns a new hash reference with the metadata converted to the latest version + #pod of the CPAN Meta Spec. No validation is done on the result -- you must + #pod validate after merging fragments into a complete metadata document. + #pod + #pod =cut + + sub upgrade_fragment { + my ($self) = @_; + my ($old_version) = $self->{spec}; + my %expected = + map {; $_ => 1 } + grep { defined } + map { $fragments_generate{$old_version}{$_} } + keys %{ $self->{data} }; + my $converted = $self->convert( version => $HIGHEST, is_fragment => 1 ); + for my $key ( keys %$converted ) { + next if $key =~ /^x_/i || $key eq 'meta-spec'; + delete $converted->{$key} unless $expected{$key}; + } + return $converted; + } + + 1; + + # ABSTRACT: Convert CPAN distribution metadata structures + + =pod + + =encoding UTF-8 + + =head1 NAME + + CPAN::Meta::Converter - Convert CPAN distribution metadata structures + + =head1 VERSION + + version 2.143240 + + =head1 SYNOPSIS + + my $struct = decode_json_file('META.json'); + + my $cmc = CPAN::Meta::Converter->new( $struct ); + + my $new_struct = $cmc->convert( version => "2" ); + + =head1 DESCRIPTION + + This module converts CPAN Meta structures from one form to another. The + primary use is to convert older structures to the most modern version of + the specification, but other transformations may be implemented in the + future as needed. (E.g. stripping all custom fields or stripping all + optional fields.) + + =head1 METHODS + + =head2 new + + my $cmc = CPAN::Meta::Converter->new( $struct ); + + The constructor should be passed a valid metadata structure but invalid + structures are accepted. If no meta-spec version is provided, version 1.0 will + be assumed. + + Optionally, you can provide a C argument after C<$struct>: + + my $cmc = CPAN::Meta::Converter->new( $struct, default_version => "1.4" ); + + This is only needed when converting a metadata fragment that does not include a + C field. + + =head2 convert + + my $new_struct = $cmc->convert( version => "2" ); + + Returns a new hash reference with the metadata converted to a different form. + C will die if any conversion/standardization still results in an + invalid structure. + + Valid parameters include: + + =over + + =item * + + C -- Indicates the desired specification version (e.g. "1.0", "1.1" ... "1.4", "2"). + Defaults to the latest version of the CPAN Meta Spec. + + =back + + Conversion proceeds through each version in turn. For example, a version 1.2 + structure might be converted to 1.3 then 1.4 then finally to version 2. The + conversion process attempts to clean-up simple errors and standardize data. + For example, if C is given as a scalar, it will converted to an array + reference containing the item. (Converting a structure to its own version will + also clean-up and standardize.) + + When data are cleaned and standardized, missing or invalid fields will be + replaced with sensible defaults when possible. This may be lossy or imprecise. + For example, some badly structured META.yml files on CPAN have prerequisite + modules listed as both keys and values: + + requires => { 'Foo::Bar' => 'Bam::Baz' } + + These would be split and each converted to a prerequisite with a minimum + version of zero. + + When some mandatory fields are missing or invalid, the conversion will attempt + to provide a sensible default or will fill them with a value of 'unknown'. For + example a missing or unrecognized C field will result in a C + field of 'unknown'. Fields that may get an 'unknown' include: + + =over 4 + + =item * + + abstract + + =item * + + author + + =item * + + license + + =back + + =head2 upgrade_fragment + + my $new_struct = $cmc->upgrade_fragment; + + Returns a new hash reference with the metadata converted to the latest version + of the CPAN Meta Spec. No validation is done on the result -- you must + validate after merging fragments into a complete metadata document. + + =head1 BUGS + + Please report any bugs or feature using the CPAN Request Tracker. + Bugs can be submitted through the web interface at + L + + When submitting a bug or request, please include a test-file or a patch to an + existing test-file that illustrates the bug or desired feature. + + =head1 AUTHORS + + =over 4 + + =item * + + David Golden + + =item * + + Ricardo Signes + + =back + + =head1 COPYRIGHT AND LICENSE + + This software is copyright (c) 2010 by David Golden and Ricardo Signes. + + This is free software; you can redistribute it and/or modify it under + the same terms as the Perl 5 programming language system itself. + + =cut + + __END__ + + + # vim: ts=2 sts=2 sw=2 et: +CPAN_META_CONVERTER + +$fatpacked{"CPAN/Meta/Feature.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_FEATURE'; + use 5.006; + use strict; + use warnings; + package CPAN::Meta::Feature; + # VERSION + $CPAN::Meta::Feature::VERSION = '2.143240'; + use CPAN::Meta::Prereqs; + + #pod =head1 DESCRIPTION + #pod + #pod A CPAN::Meta::Feature object describes an optional feature offered by a CPAN + #pod distribution and specified in the distribution's F (or F) + #pod file. + #pod + #pod For the most part, this class will only be used when operating on the result of + #pod the C or C methods on a L object. + #pod + #pod =method new + #pod + #pod my $feature = CPAN::Meta::Feature->new( $identifier => \%spec ); + #pod + #pod This returns a new Feature object. The C<%spec> argument to the constructor + #pod should be the same as the value of the C entry in the + #pod distmeta. It must contain entries for C and C. + #pod + #pod =cut + + sub new { + my ($class, $identifier, $spec) = @_; + + my %guts = ( + identifier => $identifier, + description => $spec->{description}, + prereqs => CPAN::Meta::Prereqs->new($spec->{prereqs}), + ); + + bless \%guts => $class; + } + + #pod =method identifier + #pod + #pod This method returns the feature's identifier. + #pod + #pod =cut + + sub identifier { $_[0]{identifier} } + + #pod =method description + #pod + #pod This method returns the feature's long description. + #pod + #pod =cut + + sub description { $_[0]{description} } + + #pod =method prereqs + #pod + #pod This method returns the feature's prerequisites as a L + #pod object. + #pod + #pod =cut + + sub prereqs { $_[0]{prereqs} } + + 1; + + # ABSTRACT: an optional feature provided by a CPAN distribution + + __END__ + + =pod + + =encoding UTF-8 + + =head1 NAME + + CPAN::Meta::Feature - an optional feature provided by a CPAN distribution + + =head1 VERSION + + version 2.143240 + + =head1 DESCRIPTION + + A CPAN::Meta::Feature object describes an optional feature offered by a CPAN + distribution and specified in the distribution's F (or F) + file. + + For the most part, this class will only be used when operating on the result of + the C or C methods on a L object. + + =head1 METHODS + + =head2 new + + my $feature = CPAN::Meta::Feature->new( $identifier => \%spec ); + + This returns a new Feature object. The C<%spec> argument to the constructor + should be the same as the value of the C entry in the + distmeta. It must contain entries for C and C. + + =head2 identifier + + This method returns the feature's identifier. + + =head2 description + + This method returns the feature's long description. + + =head2 prereqs + + This method returns the feature's prerequisites as a L + object. + + =head1 BUGS + + Please report any bugs or feature using the CPAN Request Tracker. + Bugs can be submitted through the web interface at + L + + When submitting a bug or request, please include a test-file or a patch to an + existing test-file that illustrates the bug or desired feature. + + =head1 AUTHORS + + =over 4 + + =item * + + David Golden + + =item * + + Ricardo Signes + + =back + + =head1 COPYRIGHT AND LICENSE + + This software is copyright (c) 2010 by David Golden and Ricardo Signes. + + This is free software; you can redistribute it and/or modify it under + the same terms as the Perl 5 programming language system itself. + + =cut +CPAN_META_FEATURE + +$fatpacked{"CPAN/Meta/History.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_HISTORY'; + # vi:tw=72 + use 5.006; + use strict; + use warnings; + package CPAN::Meta::History; + # VERSION + $CPAN::Meta::History::VERSION = '2.143240'; + 1; + + # ABSTRACT: history of CPAN Meta Spec changes + + __END__ + + =pod + + =encoding UTF-8 + + =head1 NAME + + CPAN::Meta::History - history of CPAN Meta Spec changes + + =head1 VERSION + + version 2.143240 + + =head1 DESCRIPTION + + The CPAN Meta Spec has gone through several iterations. It was + originally written in HTML and later revised into POD (though published + in HTML generated from the POD). Fields were added, removed or changed, + sometimes by design and sometimes to reflect real-world usage after the + fact. + + This document reconstructs the history of the CPAN Meta Spec based on + change logs, repository commit messages and the published HTML files. + In some cases, particularly prior to version 1.2, the exact version + when certain fields were introduced or changed is inconsistent between + sources. When in doubt, the published HTML files for versions 1.0 to + 1.4 as they existed when version 2 was developed are used as the + definitive source. + + Starting with version 2, the specification document is part of the + CPAN-Meta distribution and will be published on CPAN as + L. + + Going forward, specification version numbers will be integers and + decimal portions will correspond to a release date for the CPAN::Meta + library. + + =head1 HISTORY + + =head2 Version 2 + + April 2010 + + =over + + =item * + + Revised spec examples as perl data structures rather than YAML + + =item * + + Switched to JSON serialization from YAML + + =item * + + Specified allowed version number formats + + =item * + + Replaced 'requires', 'build_requires', 'configure_requires', + 'recommends' and 'conflicts' with new 'prereqs' data structure divided + by I (configure, build, test, runtime, etc.) and I + (requires, recommends, suggests, conflicts) + + =item * + + Added support for 'develop' phase for requirements for maintaining + a list of authoring tools + + =item * + + Changed 'license' to a list and revised the set of valid licenses + + =item * + + Made 'dynamic_config' mandatory to reduce confusion + + =item * + + Changed 'resources' subkey 'repository' to a hash that clarifies + repository type, url for browsing and url for checkout + + =item * + + Changed 'resources' subkey 'bugtracker' to a hash for either web + or mailto resource + + =item * + + Changed specification of 'optional_features': + + =over + + =item * + + Added formal specification and usage guide instead of just example + + =item * + + Changed to use new prereqs data structure instead of individual keys + + =back + + =item * + + Clarified intended use of 'author' as generalized contact list + + =item * + + Added 'release_status' field to indicate stable, testing or unstable + status to provide hints to indexers + + =item * + + Added 'description' field for a longer description of the distribution + + =item * + + Formalized use of "x_" or "X_" for all custom keys not listed in the + official spec + + =back + + =head2 Version 1.4 + + June 2008 + + =over + + =item * + + Noted explicit support for 'perl' in prerequisites + + =item * + + Added 'configure_requires' prerequisite type + + =item * + + Changed 'optional_features' + + =over + + =item * + + Example corrected to show map of maps instead of list of maps + (though descriptive text said 'map' even in v1.3) + + =item * + + Removed 'requires_packages', 'requires_os' and 'excluded_os' + as valid subkeys + + =back + + =back + + =head2 Version 1.3 + + November 2006 + + =over + + =item * + + Added 'no_index' subkey 'directory' and removed 'dir' to match actual + usage in the wild + + =item * + + Added a 'repository' subkey to 'resources' + + =back + + =head2 Version 1.2 + + August 2005 + + =over + + =item * + + Re-wrote and restructured spec in POD syntax + + =item * + + Changed 'name' to be mandatory + + =item * + + Changed 'generated_by' to be mandatory + + =item * + + Changed 'license' to be mandatory + + =item * + + Added version range specifications for prerequisites + + =item * + + Added required 'abstract' field + + =item * + + Added required 'author' field + + =item * + + Added required 'meta-spec' field to define 'version' (and 'url') of the + CPAN Meta Spec used for metadata + + =item * + + Added 'provides' field + + =item * + + Added 'no_index' field and deprecated 'private' field. 'no_index' + subkeys include 'file', 'dir', 'package' and 'namespace' + + =item * + + Added 'keywords' field + + =item * + + Added 'resources' field with subkeys 'homepage', 'license', and + 'bugtracker' + + =item * + + Added 'optional_features' field as an alternate under 'recommends'. + Includes 'description', 'requires', 'build_requires', 'conflicts', + 'requires_packages', 'requires_os' and 'excluded_os' as valid subkeys + + =item * + + Removed 'license_uri' field + + =back + + =head2 Version 1.1 + + May 2003 + + =over + + =item * + + Changed 'version' to be mandatory + + =item * + + Added 'private' field + + =item * + + Added 'license_uri' field + + =back + + =head2 Version 1.0 + + March 2003 + + =over + + =item * + + Original release (in HTML format only) + + =item * + + Included 'name', 'version', 'license', 'distribution_type', 'requires', + 'recommends', 'build_requires', 'conflicts', 'dynamic_config', + 'generated_by' + + =back + + =head1 AUTHORS + + =over 4 + + =item * + + David Golden + + =item * + + Ricardo Signes + + =back + + =head1 COPYRIGHT AND LICENSE + + This software is copyright (c) 2010 by David Golden and Ricardo Signes. + + This is free software; you can redistribute it and/or modify it under + the same terms as the Perl 5 programming language system itself. + + =cut +CPAN_META_HISTORY + +$fatpacked{"CPAN/Meta/Merge.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_MERGE'; + use strict; + use warnings; + + package CPAN::Meta::Merge; + # VERSION + $CPAN::Meta::Merge::VERSION = '2.143240'; + use Carp qw/croak/; + use Scalar::Util qw/blessed/; + use CPAN::Meta::Converter; + + sub _identical { + my ($left, $right, $path) = @_; + croak sprintf "Can't merge attribute %s: '%s' does not equal '%s'", join('.', @{$path}), $left, $right unless $left eq $right; + return $left; + } + + sub _merge { + my ($current, $next, $mergers, $path) = @_; + for my $key (keys %{$next}) { + if (not exists $current->{$key}) { + $current->{$key} = $next->{$key}; + } + elsif (my $merger = $mergers->{$key}) { + $current->{$key} = $merger->($current->{$key}, $next->{$key}, [ @{$path}, $key ]); + } + elsif ($merger = $mergers->{':default'}) { + $current->{$key} = $merger->($current->{$key}, $next->{$key}, [ @{$path}, $key ]); + } + else { + croak sprintf "Can't merge unknown attribute '%s'", join '.', @{$path}, $key; + } + } + return $current; + } + + sub _uniq { + my %seen = (); + return grep { not $seen{$_}++ } @_; + } + + sub _set_addition { + my ($left, $right) = @_; + return [ +_uniq(@{$left}, @{$right}) ]; + } + + sub _uniq_map { + my ($left, $right, $path) = @_; + for my $key (keys %{$right}) { + if (not exists $left->{$key}) { + $left->{$key} = $right->{$key}; + } + else { + croak 'Duplication of element ' . join '.', @{$path}, $key; + } + } + return $left; + } + + sub _improvize { + my ($left, $right, $path) = @_; + my ($name) = reverse @{$path}; + if ($name =~ /^x_/) { + if (ref($left) eq 'ARRAY') { + return _set_addition($left, $right, $path); + } + elsif (ref($left) eq 'HASH') { + return _uniq_map($left, $right, $path); + } + else { + return _identical($left, $right, $path); + } + } + croak sprintf "Can't merge '%s'", join '.', @{$path}; + } + + sub _optional_features { + my ($left, $right, $path) = @_; + + for my $key (keys %{$right}) { + if (not exists $left->{$key}) { + $left->{$key} = $right->{$key}; + } + else { + for my $subkey (keys %{ $right->{$key} }) { + next if $subkey eq 'prereqs'; + if (not exists $left->{$key}{$subkey}) { + $left->{$key}{$subkey} = $right->{$key}{$subkey}; + } + else { + Carp::croak "Cannot merge two optional_features named '$key' with different '$subkey' values" + if do { no warnings 'uninitialized'; $left->{$key}{$subkey} ne $right->{$key}{$subkey} }; + } + } + + require CPAN::Meta::Prereqs; + $left->{$key}{prereqs} = + CPAN::Meta::Prereqs->new($left->{$key}{prereqs}) + ->with_merged_prereqs(CPAN::Meta::Prereqs->new($right->{$key}{prereqs})) + ->as_string_hash; + } + } + return $left; + } + + + my %default = ( + abstract => \&_identical, + author => \&_set_addition, + dynamic_config => sub { + my ($left, $right) = @_; + return $left || $right; + }, + generated_by => sub { + my ($left, $right) = @_; + return join ', ', _uniq(split(/, /, $left), split(/, /, $right)); + }, + license => \&_set_addition, + 'meta-spec' => { + version => \&_identical, + url => \&_identical + }, + name => \&_identical, + release_status => \&_identical, + version => \&_identical, + description => \&_identical, + keywords => \&_set_addition, + no_index => { map { ($_ => \&_set_addition) } qw/file directory package namespace/ }, + optional_features => \&_optional_features, + prereqs => sub { + require CPAN::Meta::Prereqs; + my ($left, $right) = map { CPAN::Meta::Prereqs->new($_) } @_[0,1]; + return $left->with_merged_prereqs($right)->as_string_hash; + }, + provides => \&_uniq_map, + resources => { + license => \&_set_addition, + homepage => \&_identical, + bugtracker => \&_uniq_map, + repository => \&_uniq_map, + ':default' => \&_improvize, + }, + ':default' => \&_improvize, + ); + + sub new { + my ($class, %arguments) = @_; + croak 'default version required' if not exists $arguments{default_version}; + my %mapping = %default; + my %extra = %{ $arguments{extra_mappings} || {} }; + for my $key (keys %extra) { + if (ref($mapping{$key}) eq 'HASH') { + $mapping{$key} = { %{ $mapping{$key} }, %{ $extra{$key} } }; + } + else { + $mapping{$key} = $extra{$key}; + } + } + return bless { + default_version => $arguments{default_version}, + mapping => _coerce_mapping(\%mapping, []), + }, $class; + } + + my %coderef_for = ( + set_addition => \&_set_addition, + uniq_map => \&_uniq_map, + identical => \&_identical, + improvize => \&_improvize, + ); + + sub _coerce_mapping { + my ($orig, $map_path) = @_; + my %ret; + for my $key (keys %{$orig}) { + my $value = $orig->{$key}; + if (ref($orig->{$key}) eq 'CODE') { + $ret{$key} = $value; + } + elsif (ref($value) eq 'HASH') { + my $mapping = _coerce_mapping($value, [ @{$map_path}, $key ]); + $ret{$key} = sub { + my ($left, $right, $path) = @_; + return _merge($left, $right, $mapping, [ @{$path} ]); + }; + } + elsif ($coderef_for{$value}) { + $ret{$key} = $coderef_for{$value}; + } + else { + croak "Don't know what to do with " . join '.', @{$map_path}, $key; + } + } + return \%ret; + } + + sub merge { + my ($self, @items) = @_; + my $current = {}; + for my $next (@items) { + if ( blessed($next) && $next->isa('CPAN::Meta') ) { + $next = $next->as_struct; + } + elsif ( ref($next) eq 'HASH' ) { + my $cmc = CPAN::Meta::Converter->new( + $next, default_version => $self->{default_version} + ); + $next = $cmc->upgrade_fragment; + } + else { + croak "Don't know how to merge '$next'"; + } + $current = _merge($current, $next, $self->{mapping}, []); + } + return $current; + } + + 1; + + # ABSTRACT: Merging CPAN Meta fragments + + __END__ + + =pod + + =encoding UTF-8 + + =head1 NAME + + CPAN::Meta::Merge - Merging CPAN Meta fragments + + =head1 VERSION + + version 2.143240 + + =head1 SYNOPSIS + + my $merger = CPAN::Meta::Merge->new(default_version => "2"); + my $meta = $merger->merge($base, @additional); + + =head1 DESCRIPTION + + =head1 METHODS + + =head2 new + + This creates a CPAN::Meta::Merge object. It takes one mandatory named + argument, C, declaring the version of the meta-spec that must be + used for the merge. It can optionally take an C argument + that allows one to add additional merging functions for specific elements. + + =head2 merge(@fragments) + + Merge all C<@fragments> together. It will accept both CPAN::Meta objects and + (possibly incomplete) hashrefs of metadata. + + =head1 AUTHORS + + =over 4 + + =item * + + David Golden + + =item * + + Ricardo Signes + + =back + + =head1 COPYRIGHT AND LICENSE + + This software is copyright (c) 2010 by David Golden and Ricardo Signes. + + This is free software; you can redistribute it and/or modify it under + the same terms as the Perl 5 programming language system itself. + + =cut +CPAN_META_MERGE + +$fatpacked{"CPAN/Meta/Prereqs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_PREREQS'; + use 5.006; + use strict; + use warnings; + package CPAN::Meta::Prereqs; + # VERSION + $CPAN::Meta::Prereqs::VERSION = '2.143240'; + #pod =head1 DESCRIPTION + #pod + #pod A CPAN::Meta::Prereqs object represents the prerequisites for a CPAN + #pod distribution or one of its optional features. Each set of prereqs is + #pod organized by phase and type, as described in L. + #pod + #pod =cut + + use Carp qw(confess); + use Scalar::Util qw(blessed); + use CPAN::Meta::Requirements 2.121; + + #pod =method new + #pod + #pod my $prereq = CPAN::Meta::Prereqs->new( \%prereq_spec ); + #pod + #pod This method returns a new set of Prereqs. The input should look like the + #pod contents of the C field described in L, meaning + #pod something more or less like this: + #pod + #pod my $prereq = CPAN::Meta::Prereqs->new({ + #pod runtime => { + #pod requires => { + #pod 'Some::Module' => '1.234', + #pod ..., + #pod }, + #pod ..., + #pod }, + #pod ..., + #pod }); + #pod + #pod You can also construct an empty set of prereqs with: + #pod + #pod my $prereqs = CPAN::Meta::Prereqs->new; + #pod + #pod This empty set of prereqs is useful for accumulating new prereqs before finally + #pod dumping the whole set into a structure or string. + #pod + #pod =cut + + sub __legal_phases { qw(configure build test runtime develop) } + sub __legal_types { qw(requires recommends suggests conflicts) } + + # expect a prereq spec from META.json -- rjbs, 2010-04-11 + sub new { + my ($class, $prereq_spec) = @_; + $prereq_spec ||= {}; + + my %is_legal_phase = map {; $_ => 1 } $class->__legal_phases; + my %is_legal_type = map {; $_ => 1 } $class->__legal_types; + + my %guts; + PHASE: for my $phase (keys %$prereq_spec) { + next PHASE unless $phase =~ /\Ax_/i or $is_legal_phase{$phase}; + + my $phase_spec = $prereq_spec->{ $phase }; + next PHASE unless keys %$phase_spec; + + TYPE: for my $type (keys %$phase_spec) { + next TYPE unless $type =~ /\Ax_/i or $is_legal_type{$type}; + + my $spec = $phase_spec->{ $type }; + + next TYPE unless keys %$spec; + + $guts{prereqs}{$phase}{$type} = CPAN::Meta::Requirements->from_string_hash( + $spec + ); + } + } + + return bless \%guts => $class; + } + + #pod =method requirements_for + #pod + #pod my $requirements = $prereqs->requirements_for( $phase, $type ); + #pod + #pod This method returns a L object for the given + #pod phase/type combination. If no prerequisites are registered for that + #pod combination, a new CPAN::Meta::Requirements object will be returned, and it may + #pod be added to as needed. + #pod + #pod If C<$phase> or C<$type> are undefined or otherwise invalid, an exception will + #pod be raised. + #pod + #pod =cut + + sub requirements_for { + my ($self, $phase, $type) = @_; + + confess "requirements_for called without phase" unless defined $phase; + confess "requirements_for called without type" unless defined $type; + + unless ($phase =~ /\Ax_/i or grep { $phase eq $_ } $self->__legal_phases) { + confess "requested requirements for unknown phase: $phase"; + } + + unless ($type =~ /\Ax_/i or grep { $type eq $_ } $self->__legal_types) { + confess "requested requirements for unknown type: $type"; + } + + my $req = ($self->{prereqs}{$phase}{$type} ||= CPAN::Meta::Requirements->new); + + $req->finalize if $self->is_finalized; + + return $req; + } + + #pod =method with_merged_prereqs + #pod + #pod my $new_prereqs = $prereqs->with_merged_prereqs( $other_prereqs ); + #pod + #pod my $new_prereqs = $prereqs->with_merged_prereqs( \@other_prereqs ); + #pod + #pod This method returns a new CPAN::Meta::Prereqs objects in which all the + #pod other prerequisites given are merged into the current set. This is primarily + #pod provided for combining a distribution's core prereqs with the prereqs of one of + #pod its optional features. + #pod + #pod The new prereqs object has no ties to the originals, and altering it further + #pod will not alter them. + #pod + #pod =cut + + sub with_merged_prereqs { + my ($self, $other) = @_; + + my @other = blessed($other) ? $other : @$other; + + my @prereq_objs = ($self, @other); + + my %new_arg; + + for my $phase ($self->__legal_phases) { + for my $type ($self->__legal_types) { + my $req = CPAN::Meta::Requirements->new; + + for my $prereq (@prereq_objs) { + my $this_req = $prereq->requirements_for($phase, $type); + next unless $this_req->required_modules; + + $req->add_requirements($this_req); + } + + next unless $req->required_modules; + + $new_arg{ $phase }{ $type } = $req->as_string_hash; + } + } + + return (ref $self)->new(\%new_arg); + } + + #pod =method merged_requirements + #pod + #pod my $new_reqs = $prereqs->merged_requirements( \@phases, \@types ); + #pod my $new_reqs = $prereqs->merged_requirements( \@phases ); + #pod my $new_reqs = $preerqs->merged_requirements(); + #pod + #pod This method joins together all requirements across a number of phases + #pod and types into a new L object. If arguments + #pod are omitted, it defaults to "runtime", "build" and "test" for phases + #pod and "requires" and "recommends" for types. + #pod + #pod =cut + + sub merged_requirements { + my ($self, $phases, $types) = @_; + $phases = [qw/runtime build test/] unless defined $phases; + $types = [qw/requires recommends/] unless defined $types; + + confess "merged_requirements phases argument must be an arrayref" + unless ref $phases eq 'ARRAY'; + confess "merged_requirements types argument must be an arrayref" + unless ref $types eq 'ARRAY'; + + my $req = CPAN::Meta::Requirements->new; + + for my $phase ( @$phases ) { + unless ($phase =~ /\Ax_/i or grep { $phase eq $_ } $self->__legal_phases) { + confess "requested requirements for unknown phase: $phase"; + } + for my $type ( @$types ) { + unless ($type =~ /\Ax_/i or grep { $type eq $_ } $self->__legal_types) { + confess "requested requirements for unknown type: $type"; + } + $req->add_requirements( $self->requirements_for($phase, $type) ); + } + } + + $req->finalize if $self->is_finalized; + + return $req; + } + + + #pod =method as_string_hash + #pod + #pod This method returns a hashref containing structures suitable for dumping into a + #pod distmeta data structure. It is made up of hashes and strings, only; there will + #pod be no Prereqs, CPAN::Meta::Requirements, or C objects inside it. + #pod + #pod =cut + + sub as_string_hash { + my ($self) = @_; + + my %hash; + + for my $phase ($self->__legal_phases) { + for my $type ($self->__legal_types) { + my $req = $self->requirements_for($phase, $type); + next unless $req->required_modules; + + $hash{ $phase }{ $type } = $req->as_string_hash; + } + } + + return \%hash; + } + + #pod =method is_finalized + #pod + #pod This method returns true if the set of prereqs has been marked "finalized," and + #pod cannot be altered. + #pod + #pod =cut + + sub is_finalized { $_[0]{finalized} } + + #pod =method finalize + #pod + #pod Calling C on a Prereqs object will close it for further modification. + #pod Attempting to make any changes that would actually alter the prereqs will + #pod result in an exception being thrown. + #pod + #pod =cut + + sub finalize { + my ($self) = @_; + + $self->{finalized} = 1; + + for my $phase (keys %{ $self->{prereqs} }) { + $_->finalize for values %{ $self->{prereqs}{$phase} }; + } + } + + #pod =method clone + #pod + #pod my $cloned_prereqs = $prereqs->clone; + #pod + #pod This method returns a Prereqs object that is identical to the original object, + #pod but can be altered without affecting the original object. Finalization does + #pod not survive cloning, meaning that you may clone a finalized set of prereqs and + #pod then modify the clone. + #pod + #pod =cut + + sub clone { + my ($self) = @_; + + my $clone = (ref $self)->new( $self->as_string_hash ); + } + + 1; + + # ABSTRACT: a set of distribution prerequisites by phase and type + + __END__ + + =pod + + =encoding UTF-8 + + =head1 NAME + + CPAN::Meta::Prereqs - a set of distribution prerequisites by phase and type + + =head1 VERSION + + version 2.143240 + + =head1 DESCRIPTION + + A CPAN::Meta::Prereqs object represents the prerequisites for a CPAN + distribution or one of its optional features. Each set of prereqs is + organized by phase and type, as described in L. + + =head1 METHODS + + =head2 new + + my $prereq = CPAN::Meta::Prereqs->new( \%prereq_spec ); + + This method returns a new set of Prereqs. The input should look like the + contents of the C field described in L, meaning + something more or less like this: + + my $prereq = CPAN::Meta::Prereqs->new({ + runtime => { + requires => { + 'Some::Module' => '1.234', + ..., + }, + ..., + }, + ..., + }); + + You can also construct an empty set of prereqs with: + + my $prereqs = CPAN::Meta::Prereqs->new; + + This empty set of prereqs is useful for accumulating new prereqs before finally + dumping the whole set into a structure or string. + + =head2 requirements_for + + my $requirements = $prereqs->requirements_for( $phase, $type ); + + This method returns a L object for the given + phase/type combination. If no prerequisites are registered for that + combination, a new CPAN::Meta::Requirements object will be returned, and it may + be added to as needed. + + If C<$phase> or C<$type> are undefined or otherwise invalid, an exception will + be raised. + + =head2 with_merged_prereqs + + my $new_prereqs = $prereqs->with_merged_prereqs( $other_prereqs ); + + my $new_prereqs = $prereqs->with_merged_prereqs( \@other_prereqs ); + + This method returns a new CPAN::Meta::Prereqs objects in which all the + other prerequisites given are merged into the current set. This is primarily + provided for combining a distribution's core prereqs with the prereqs of one of + its optional features. + + The new prereqs object has no ties to the originals, and altering it further + will not alter them. + + =head2 merged_requirements + + my $new_reqs = $prereqs->merged_requirements( \@phases, \@types ); + my $new_reqs = $prereqs->merged_requirements( \@phases ); + my $new_reqs = $preerqs->merged_requirements(); + + This method joins together all requirements across a number of phases + and types into a new L object. If arguments + are omitted, it defaults to "runtime", "build" and "test" for phases + and "requires" and "recommends" for types. + + =head2 as_string_hash + + This method returns a hashref containing structures suitable for dumping into a + distmeta data structure. It is made up of hashes and strings, only; there will + be no Prereqs, CPAN::Meta::Requirements, or C objects inside it. + + =head2 is_finalized + + This method returns true if the set of prereqs has been marked "finalized," and + cannot be altered. + + =head2 finalize + + Calling C on a Prereqs object will close it for further modification. + Attempting to make any changes that would actually alter the prereqs will + result in an exception being thrown. + + =head2 clone + + my $cloned_prereqs = $prereqs->clone; + + This method returns a Prereqs object that is identical to the original object, + but can be altered without affecting the original object. Finalization does + not survive cloning, meaning that you may clone a finalized set of prereqs and + then modify the clone. + + =head1 BUGS + + Please report any bugs or feature using the CPAN Request Tracker. + Bugs can be submitted through the web interface at + L + + When submitting a bug or request, please include a test-file or a patch to an + existing test-file that illustrates the bug or desired feature. + + =head1 AUTHORS + + =over 4 + + =item * + + David Golden + + =item * + + Ricardo Signes + + =back + + =head1 COPYRIGHT AND LICENSE + + This software is copyright (c) 2010 by David Golden and Ricardo Signes. + + This is free software; you can redistribute it and/or modify it under + the same terms as the Perl 5 programming language system itself. + + =cut +CPAN_META_PREREQS + +$fatpacked{"CPAN/Meta/Requirements.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_REQUIREMENTS'; + use strict; + use warnings; + package CPAN::Meta::Requirements; + # ABSTRACT: a set of version requirements for a CPAN dist + + our $VERSION = '2.131'; + + #pod =head1 SYNOPSIS + #pod + #pod use CPAN::Meta::Requirements; + #pod + #pod my $build_requires = CPAN::Meta::Requirements->new; + #pod + #pod $build_requires->add_minimum('Library::Foo' => 1.208); + #pod + #pod $build_requires->add_minimum('Library::Foo' => 2.602); + #pod + #pod $build_requires->add_minimum('Module::Bar' => 'v1.2.3'); + #pod + #pod $METAyml->{build_requires} = $build_requires->as_string_hash; + #pod + #pod =head1 DESCRIPTION + #pod + #pod A CPAN::Meta::Requirements object models a set of version constraints like + #pod those specified in the F or F files in CPAN distributions, + #pod and as defined by L; + #pod It can be built up by adding more and more constraints, and it will reduce them + #pod to the simplest representation. + #pod + #pod Logically impossible constraints will be identified immediately by thrown + #pod exceptions. + #pod + #pod =cut + + use Carp (); + + # To help ExtUtils::MakeMaker bootstrap CPAN::Meta::Requirements on perls + # before 5.10, we fall back to the EUMM bundled compatibility version module if + # that's the only thing available. This shouldn't ever happen in a normal CPAN + # install of CPAN::Meta::Requirements, as version.pm will be picked up from + # prereqs and be available at runtime. + + BEGIN { + eval "use version ()"; ## no critic + if ( my $err = $@ ) { + eval "require ExtUtils::MakeMaker::version" or die $err; ## no critic + } + } + + # Perl 5.10.0 didn't have "is_qv" in version.pm + *_is_qv = version->can('is_qv') ? sub { $_[0]->is_qv } : sub { exists $_[0]->{qv} }; + + # construct once, reuse many times + my $V0 = version->new(0); + + #pod =method new + #pod + #pod my $req = CPAN::Meta::Requirements->new; + #pod + #pod This returns a new CPAN::Meta::Requirements object. It takes an optional + #pod hash reference argument. Currently, only one key is supported: + #pod + #pod =for :list + #pod * C -- if provided, when a version cannot be parsed into + #pod a version object, this code reference will be called with the invalid + #pod version string as first argument, and the module name as second + #pod argument. It must return a valid version object. + #pod + #pod All other keys are ignored. + #pod + #pod =cut + + my @valid_options = qw( bad_version_hook ); + + sub new { + my ($class, $options) = @_; + $options ||= {}; + Carp::croak "Argument to $class\->new() must be a hash reference" + unless ref $options eq 'HASH'; + my %self = map {; $_ => $options->{$_}} @valid_options; + + return bless \%self => $class; + } + + # from version::vpp + sub _find_magic_vstring { + my $value = shift; + my $tvalue = ''; + require B; + my $sv = B::svref_2object(\$value); + my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef; + while ( $magic ) { + if ( $magic->TYPE eq 'V' ) { + $tvalue = $magic->PTR; + $tvalue =~ s/^v?(.+)$/v$1/; + last; + } + else { + $magic = $magic->MOREMAGIC; + } + } + return $tvalue; + } + + # safe if given an unblessed reference + sub _isa_version { + UNIVERSAL::isa( $_[0], 'UNIVERSAL' ) && $_[0]->isa('version') + } + + sub _version_object { + my ($self, $module, $version) = @_; + + my $vobj; + + # hack around version::vpp not handling <3 character vstring literals + if ( $INC{'version/vpp.pm'} || $INC{'ExtUtils/MakeMaker/version/vpp.pm'} ) { + my $magic = _find_magic_vstring( $version ); + $version = $magic if length $magic; + } + + eval { + if (not defined $version or $version eq '0') { + $vobj = $V0; + } + elsif ( ref($version) eq 'version' || _isa_version($version) ) { + $vobj = $version; + } + else { + local $SIG{__WARN__} = sub { die "Invalid version: $_[0]" }; + $vobj = version->new($version); + } + }; + + if ( my $err = $@ ) { + my $hook = $self->{bad_version_hook}; + $vobj = eval { $hook->($version, $module) } + if ref $hook eq 'CODE'; + unless (eval { $vobj->isa("version") }) { + $err =~ s{ at .* line \d+.*$}{}; + die "Can't convert '$version': $err"; + } + } + + # ensure no leading '.' + if ( $vobj =~ m{\A\.} ) { + $vobj = version->new("0$vobj"); + } + + # ensure normal v-string form + if ( _is_qv($vobj) ) { + $vobj = version->new($vobj->normal); + } + + return $vobj; + } + + #pod =method add_minimum + #pod + #pod $req->add_minimum( $module => $version ); + #pod + #pod This adds a new minimum version requirement. If the new requirement is + #pod redundant to the existing specification, this has no effect. + #pod + #pod Minimum requirements are inclusive. C<$version> is required, along with any + #pod greater version number. + #pod + #pod This method returns the requirements object. + #pod + #pod =method add_maximum + #pod + #pod $req->add_maximum( $module => $version ); + #pod + #pod This adds a new maximum version requirement. If the new requirement is + #pod redundant to the existing specification, this has no effect. + #pod + #pod Maximum requirements are inclusive. No version strictly greater than the given + #pod version is allowed. + #pod + #pod This method returns the requirements object. + #pod + #pod =method add_exclusion + #pod + #pod $req->add_exclusion( $module => $version ); + #pod + #pod This adds a new excluded version. For example, you might use these three + #pod method calls: + #pod + #pod $req->add_minimum( $module => '1.00' ); + #pod $req->add_maximum( $module => '1.82' ); + #pod + #pod $req->add_exclusion( $module => '1.75' ); + #pod + #pod Any version between 1.00 and 1.82 inclusive would be acceptable, except for + #pod 1.75. + #pod + #pod This method returns the requirements object. + #pod + #pod =method exact_version + #pod + #pod $req->exact_version( $module => $version ); + #pod + #pod This sets the version required for the given module to I the given + #pod version. No other version would be considered acceptable. + #pod + #pod This method returns the requirements object. + #pod + #pod =cut + + BEGIN { + for my $type (qw(maximum exclusion exact_version)) { + my $method = "with_$type"; + my $to_add = $type eq 'exact_version' ? $type : "add_$type"; + + my $code = sub { + my ($self, $name, $version) = @_; + + $version = $self->_version_object( $name, $version ); + + $self->__modify_entry_for($name, $method, $version); + + return $self; + }; + + no strict 'refs'; + *$to_add = $code; + } + } + + sub add_minimum { + my ($self, $name, $version) = @_; + + if (not defined $version or $version eq '0') { + return $self if $self->__entry_for($name); + Carp::confess("can't add new requirements to finalized requirements") + if $self->is_finalized; + + $self->{requirements}{ $name } = + CPAN::Meta::Requirements::_Range::Range->with_minimum($V0); + } + else { + $version = $self->_version_object( $name, $version ); + + $self->__modify_entry_for($name, 'with_minimum', $version); + } + return $self; + } + + #pod =method add_requirements + #pod + #pod $req->add_requirements( $another_req_object ); + #pod + #pod This method adds all the requirements in the given CPAN::Meta::Requirements object + #pod to the requirements object on which it was called. If there are any conflicts, + #pod an exception is thrown. + #pod + #pod This method returns the requirements object. + #pod + #pod =cut + + sub add_requirements { + my ($self, $req) = @_; + + for my $module ($req->required_modules) { + my $modifiers = $req->__entry_for($module)->as_modifiers; + for my $modifier (@$modifiers) { + my ($method, @args) = @$modifier; + $self->$method($module => @args); + }; + } + + return $self; + } + + #pod =method accepts_module + #pod + #pod my $bool = $req->accepts_module($module => $version); + #pod + #pod Given an module and version, this method returns true if the version + #pod specification for the module accepts the provided version. In other words, + #pod given: + #pod + #pod Module => '>= 1.00, < 2.00' + #pod + #pod We will accept 1.00 and 1.75 but not 0.50 or 2.00. + #pod + #pod For modules that do not appear in the requirements, this method will return + #pod true. + #pod + #pod =cut + + sub accepts_module { + my ($self, $module, $version) = @_; + + $version = $self->_version_object( $module, $version ); + + return 1 unless my $range = $self->__entry_for($module); + return $range->_accepts($version); + } + + #pod =method clear_requirement + #pod + #pod $req->clear_requirement( $module ); + #pod + #pod This removes the requirement for a given module from the object. + #pod + #pod This method returns the requirements object. + #pod + #pod =cut + + sub clear_requirement { + my ($self, $module) = @_; + + return $self unless $self->__entry_for($module); + + Carp::confess("can't clear requirements on finalized requirements") + if $self->is_finalized; + + delete $self->{requirements}{ $module }; + + return $self; + } + + #pod =method requirements_for_module + #pod + #pod $req->requirements_for_module( $module ); + #pod + #pod This returns a string containing the version requirements for a given module in + #pod the format described in L or undef if the given module has no + #pod requirements. This should only be used for informational purposes such as error + #pod messages and should not be interpreted or used for comparison (see + #pod L instead.) + #pod + #pod =cut + + sub requirements_for_module { + my ($self, $module) = @_; + my $entry = $self->__entry_for($module); + return unless $entry; + return $entry->as_string; + } + + #pod =method required_modules + #pod + #pod This method returns a list of all the modules for which requirements have been + #pod specified. + #pod + #pod =cut + + sub required_modules { keys %{ $_[0]{requirements} } } + + #pod =method clone + #pod + #pod $req->clone; + #pod + #pod This method returns a clone of the invocant. The clone and the original object + #pod can then be changed independent of one another. + #pod + #pod =cut + + sub clone { + my ($self) = @_; + my $new = (ref $self)->new; + + return $new->add_requirements($self); + } + + sub __entry_for { $_[0]{requirements}{ $_[1] } } + + sub __modify_entry_for { + my ($self, $name, $method, $version) = @_; + + my $fin = $self->is_finalized; + my $old = $self->__entry_for($name); + + Carp::confess("can't add new requirements to finalized requirements") + if $fin and not $old; + + my $new = ($old || 'CPAN::Meta::Requirements::_Range::Range') + ->$method($version); + + Carp::confess("can't modify finalized requirements") + if $fin and $old->as_string ne $new->as_string; + + $self->{requirements}{ $name } = $new; + } + + #pod =method is_simple + #pod + #pod This method returns true if and only if all requirements are inclusive minimums + #pod -- that is, if their string expression is just the version number. + #pod + #pod =cut + + sub is_simple { + my ($self) = @_; + for my $module ($self->required_modules) { + # XXX: This is a complete hack, but also entirely correct. + return if $self->__entry_for($module)->as_string =~ /\s/; + } + + return 1; + } + + #pod =method is_finalized + #pod + #pod This method returns true if the requirements have been finalized by having the + #pod C method called on them. + #pod + #pod =cut + + sub is_finalized { $_[0]{finalized} } + + #pod =method finalize + #pod + #pod This method marks the requirements finalized. Subsequent attempts to change + #pod the requirements will be fatal, I they would result in a change. If they + #pod would not alter the requirements, they have no effect. + #pod + #pod If a finalized set of requirements is cloned, the cloned requirements are not + #pod also finalized. + #pod + #pod =cut + + sub finalize { $_[0]{finalized} = 1 } + + #pod =method as_string_hash + #pod + #pod This returns a reference to a hash describing the requirements using the + #pod strings in the L specification. + #pod + #pod For example after the following program: + #pod + #pod my $req = CPAN::Meta::Requirements->new; + #pod + #pod $req->add_minimum('CPAN::Meta::Requirements' => 0.102); + #pod + #pod $req->add_minimum('Library::Foo' => 1.208); + #pod + #pod $req->add_maximum('Library::Foo' => 2.602); + #pod + #pod $req->add_minimum('Module::Bar' => 'v1.2.3'); + #pod + #pod $req->add_exclusion('Module::Bar' => 'v1.2.8'); + #pod + #pod $req->exact_version('Xyzzy' => '6.01'); + #pod + #pod my $hashref = $req->as_string_hash; + #pod + #pod C<$hashref> would contain: + #pod + #pod { + #pod 'CPAN::Meta::Requirements' => '0.102', + #pod 'Library::Foo' => '>= 1.208, <= 2.206', + #pod 'Module::Bar' => '>= v1.2.3, != v1.2.8', + #pod 'Xyzzy' => '== 6.01', + #pod } + #pod + #pod =cut + + sub as_string_hash { + my ($self) = @_; + + my %hash = map {; $_ => $self->{requirements}{$_}->as_string } + $self->required_modules; + + return \%hash; + } + + #pod =method add_string_requirement + #pod + #pod $req->add_string_requirement('Library::Foo' => '>= 1.208, <= 2.206'); + #pod $req->add_string_requirement('Library::Foo' => v1.208); + #pod + #pod This method parses the passed in string and adds the appropriate requirement + #pod for the given module. A version can be a Perl "v-string". It understands + #pod version ranges as described in the L. For + #pod example: + #pod + #pod =over 4 + #pod + #pod =item 1.3 + #pod + #pod =item >= 1.3 + #pod + #pod =item <= 1.3 + #pod + #pod =item == 1.3 + #pod + #pod =item != 1.3 + #pod + #pod =item > 1.3 + #pod + #pod =item < 1.3 + #pod + #pod =item >= 1.3, != 1.5, <= 2.0 + #pod + #pod A version number without an operator is equivalent to specifying a minimum + #pod (C=>). Extra whitespace is allowed. + #pod + #pod =back + #pod + #pod =cut + + my %methods_for_op = ( + '==' => [ qw(exact_version) ], + '!=' => [ qw(add_exclusion) ], + '>=' => [ qw(add_minimum) ], + '<=' => [ qw(add_maximum) ], + '>' => [ qw(add_minimum add_exclusion) ], + '<' => [ qw(add_maximum add_exclusion) ], + ); + + sub add_string_requirement { + my ($self, $module, $req) = @_; + + unless ( defined $req && length $req ) { + $req = 0; + $self->_blank_carp($module); + } + + my $magic = _find_magic_vstring( $req ); + if (length $magic) { + $self->add_minimum($module => $magic); + return; + } + + my @parts = split qr{\s*,\s*}, $req; + + for my $part (@parts) { + my ($op, $ver) = $part =~ m{\A\s*(==|>=|>|<=|<|!=)\s*(.*)\z}; + + if (! defined $op) { + $self->add_minimum($module => $part); + } else { + Carp::confess("illegal requirement string: $req") + unless my $methods = $methods_for_op{ $op }; + + $self->$_($module => $ver) for @$methods; + } + } + } + + #pod =method from_string_hash + #pod + #pod my $req = CPAN::Meta::Requirements->from_string_hash( \%hash ); + #pod my $req = CPAN::Meta::Requirements->from_string_hash( \%hash, \%opts ); + #pod + #pod This is an alternate constructor for a CPAN::Meta::Requirements + #pod object. It takes a hash of module names and version requirement + #pod strings and returns a new CPAN::Meta::Requirements object. As with + #pod add_string_requirement, a version can be a Perl "v-string". Optionally, + #pod you can supply a hash-reference of options, exactly as with the L + #pod method. + #pod + #pod =cut + + sub _blank_carp { + my ($self, $module) = @_; + Carp::carp("Undefined requirement for $module treated as '0'"); + } + + sub from_string_hash { + my ($class, $hash, $options) = @_; + + my $self = $class->new($options); + + for my $module (keys %$hash) { + my $req = $hash->{$module}; + unless ( defined $req && length $req ) { + $req = 0; + $class->_blank_carp($module); + } + $self->add_string_requirement($module, $req); + } + + return $self; + } + + ############################################################## + + { + package + CPAN::Meta::Requirements::_Range::Exact; + sub _new { bless { version => $_[1] } => $_[0] } + + sub _accepts { return $_[0]{version} == $_[1] } + + sub as_string { return "== $_[0]{version}" } + + sub as_modifiers { return [ [ exact_version => $_[0]{version} ] ] } + + sub _clone { + (ref $_[0])->_new( version->new( $_[0]{version} ) ) + } + + sub with_exact_version { + my ($self, $version) = @_; + + return $self->_clone if $self->_accepts($version); + + Carp::confess("illegal requirements: unequal exact version specified"); + } + + sub with_minimum { + my ($self, $minimum) = @_; + return $self->_clone if $self->{version} >= $minimum; + Carp::confess("illegal requirements: minimum above exact specification"); + } + + sub with_maximum { + my ($self, $maximum) = @_; + return $self->_clone if $self->{version} <= $maximum; + Carp::confess("illegal requirements: maximum below exact specification"); + } + + sub with_exclusion { + my ($self, $exclusion) = @_; + return $self->_clone unless $exclusion == $self->{version}; + Carp::confess("illegal requirements: excluded exact specification"); + } + } + + ############################################################## + + { + package + CPAN::Meta::Requirements::_Range::Range; + + sub _self { ref($_[0]) ? $_[0] : (bless { } => $_[0]) } + + sub _clone { + return (bless { } => $_[0]) unless ref $_[0]; + + my ($s) = @_; + my %guts = ( + (exists $s->{minimum} ? (minimum => version->new($s->{minimum})) : ()), + (exists $s->{maximum} ? (maximum => version->new($s->{maximum})) : ()), + + (exists $s->{exclusions} + ? (exclusions => [ map { version->new($_) } @{ $s->{exclusions} } ]) + : ()), + ); + + bless \%guts => ref($s); + } + + sub as_modifiers { + my ($self) = @_; + my @mods; + push @mods, [ add_minimum => $self->{minimum} ] if exists $self->{minimum}; + push @mods, [ add_maximum => $self->{maximum} ] if exists $self->{maximum}; + push @mods, map {; [ add_exclusion => $_ ] } @{$self->{exclusions} || []}; + return \@mods; + } + + sub as_string { + my ($self) = @_; + + return 0 if ! keys %$self; + + return "$self->{minimum}" if (keys %$self) == 1 and exists $self->{minimum}; + + my @exclusions = @{ $self->{exclusions} || [] }; + + my @parts; + + for my $pair ( + [ qw( >= > minimum ) ], + [ qw( <= < maximum ) ], + ) { + my ($op, $e_op, $k) = @$pair; + if (exists $self->{$k}) { + my @new_exclusions = grep { $_ != $self->{ $k } } @exclusions; + if (@new_exclusions == @exclusions) { + push @parts, "$op $self->{ $k }"; + } else { + push @parts, "$e_op $self->{ $k }"; + @exclusions = @new_exclusions; + } + } + } + + push @parts, map {; "!= $_" } @exclusions; + + return join q{, }, @parts; + } + + sub with_exact_version { + my ($self, $version) = @_; + $self = $self->_clone; + + Carp::confess("illegal requirements: exact specification outside of range") + unless $self->_accepts($version); + + return CPAN::Meta::Requirements::_Range::Exact->_new($version); + } + + sub _simplify { + my ($self) = @_; + + if (defined $self->{minimum} and defined $self->{maximum}) { + if ($self->{minimum} == $self->{maximum}) { + Carp::confess("illegal requirements: excluded all values") + if grep { $_ == $self->{minimum} } @{ $self->{exclusions} || [] }; + + return CPAN::Meta::Requirements::_Range::Exact->_new($self->{minimum}) + } + + Carp::confess("illegal requirements: minimum exceeds maximum") + if $self->{minimum} > $self->{maximum}; + } + + # eliminate irrelevant exclusions + if ($self->{exclusions}) { + my %seen; + @{ $self->{exclusions} } = grep { + (! defined $self->{minimum} or $_ >= $self->{minimum}) + and + (! defined $self->{maximum} or $_ <= $self->{maximum}) + and + ! $seen{$_}++ + } @{ $self->{exclusions} }; + } + + return $self; + } + + sub with_minimum { + my ($self, $minimum) = @_; + $self = $self->_clone; + + if (defined (my $old_min = $self->{minimum})) { + $self->{minimum} = (sort { $b cmp $a } ($minimum, $old_min))[0]; + } else { + $self->{minimum} = $minimum; + } + + return $self->_simplify; + } + + sub with_maximum { + my ($self, $maximum) = @_; + $self = $self->_clone; + + if (defined (my $old_max = $self->{maximum})) { + $self->{maximum} = (sort { $a cmp $b } ($maximum, $old_max))[0]; + } else { + $self->{maximum} = $maximum; + } + + return $self->_simplify; + } + + sub with_exclusion { + my ($self, $exclusion) = @_; + $self = $self->_clone; + + push @{ $self->{exclusions} ||= [] }, $exclusion; + + return $self->_simplify; + } + + sub _accepts { + my ($self, $version) = @_; + + return if defined $self->{minimum} and $version < $self->{minimum}; + return if defined $self->{maximum} and $version > $self->{maximum}; + return if defined $self->{exclusions} + and grep { $version == $_ } @{ $self->{exclusions} }; + + return 1; + } + } + + 1; + # vim: ts=2 sts=2 sw=2 et: + + __END__ + + =pod + + =encoding UTF-8 + + =head1 NAME + + CPAN::Meta::Requirements - a set of version requirements for a CPAN dist + + =head1 VERSION + + version 2.131 + + =head1 SYNOPSIS + + use CPAN::Meta::Requirements; + + my $build_requires = CPAN::Meta::Requirements->new; + + $build_requires->add_minimum('Library::Foo' => 1.208); + + $build_requires->add_minimum('Library::Foo' => 2.602); + + $build_requires->add_minimum('Module::Bar' => 'v1.2.3'); + + $METAyml->{build_requires} = $build_requires->as_string_hash; + + =head1 DESCRIPTION + + A CPAN::Meta::Requirements object models a set of version constraints like + those specified in the F or F files in CPAN distributions, + and as defined by L; + It can be built up by adding more and more constraints, and it will reduce them + to the simplest representation. + + Logically impossible constraints will be identified immediately by thrown + exceptions. + + =head1 METHODS + + =head2 new + + my $req = CPAN::Meta::Requirements->new; + + This returns a new CPAN::Meta::Requirements object. It takes an optional + hash reference argument. Currently, only one key is supported: + + =over 4 + + =item * + + C -- if provided, when a version cannot be parsed into a version object, this code reference will be called with the invalid version string as first argument, and the module name as second argument. It must return a valid version object. + + =back + + All other keys are ignored. + + =head2 add_minimum + + $req->add_minimum( $module => $version ); + + This adds a new minimum version requirement. If the new requirement is + redundant to the existing specification, this has no effect. + + Minimum requirements are inclusive. C<$version> is required, along with any + greater version number. + + This method returns the requirements object. + + =head2 add_maximum + + $req->add_maximum( $module => $version ); + + This adds a new maximum version requirement. If the new requirement is + redundant to the existing specification, this has no effect. + + Maximum requirements are inclusive. No version strictly greater than the given + version is allowed. + + This method returns the requirements object. + + =head2 add_exclusion + + $req->add_exclusion( $module => $version ); + + This adds a new excluded version. For example, you might use these three + method calls: + + $req->add_minimum( $module => '1.00' ); + $req->add_maximum( $module => '1.82' ); + + $req->add_exclusion( $module => '1.75' ); + + Any version between 1.00 and 1.82 inclusive would be acceptable, except for + 1.75. + + This method returns the requirements object. + + =head2 exact_version + + $req->exact_version( $module => $version ); + + This sets the version required for the given module to I the given + version. No other version would be considered acceptable. + + This method returns the requirements object. + + =head2 add_requirements + + $req->add_requirements( $another_req_object ); + + This method adds all the requirements in the given CPAN::Meta::Requirements object + to the requirements object on which it was called. If there are any conflicts, + an exception is thrown. + + This method returns the requirements object. + + =head2 accepts_module + + my $bool = $req->accepts_module($module => $version); + + Given an module and version, this method returns true if the version + specification for the module accepts the provided version. In other words, + given: + + Module => '>= 1.00, < 2.00' + + We will accept 1.00 and 1.75 but not 0.50 or 2.00. + + For modules that do not appear in the requirements, this method will return + true. + + =head2 clear_requirement + + $req->clear_requirement( $module ); + + This removes the requirement for a given module from the object. + + This method returns the requirements object. + + =head2 requirements_for_module + + $req->requirements_for_module( $module ); + + This returns a string containing the version requirements for a given module in + the format described in L or undef if the given module has no + requirements. This should only be used for informational purposes such as error + messages and should not be interpreted or used for comparison (see + L instead.) + + =head2 required_modules + + This method returns a list of all the modules for which requirements have been + specified. + + =head2 clone + + $req->clone; + + This method returns a clone of the invocant. The clone and the original object + can then be changed independent of one another. + + =head2 is_simple + + This method returns true if and only if all requirements are inclusive minimums + -- that is, if their string expression is just the version number. + + =head2 is_finalized + + This method returns true if the requirements have been finalized by having the + C method called on them. + + =head2 finalize + + This method marks the requirements finalized. Subsequent attempts to change + the requirements will be fatal, I they would result in a change. If they + would not alter the requirements, they have no effect. + + If a finalized set of requirements is cloned, the cloned requirements are not + also finalized. + + =head2 as_string_hash + + This returns a reference to a hash describing the requirements using the + strings in the L specification. + + For example after the following program: + + my $req = CPAN::Meta::Requirements->new; + + $req->add_minimum('CPAN::Meta::Requirements' => 0.102); + + $req->add_minimum('Library::Foo' => 1.208); + + $req->add_maximum('Library::Foo' => 2.602); + + $req->add_minimum('Module::Bar' => 'v1.2.3'); + + $req->add_exclusion('Module::Bar' => 'v1.2.8'); + + $req->exact_version('Xyzzy' => '6.01'); + + my $hashref = $req->as_string_hash; + + C<$hashref> would contain: + + { + 'CPAN::Meta::Requirements' => '0.102', + 'Library::Foo' => '>= 1.208, <= 2.206', + 'Module::Bar' => '>= v1.2.3, != v1.2.8', + 'Xyzzy' => '== 6.01', + } + + =head2 add_string_requirement + + $req->add_string_requirement('Library::Foo' => '>= 1.208, <= 2.206'); + $req->add_string_requirement('Library::Foo' => v1.208); + + This method parses the passed in string and adds the appropriate requirement + for the given module. A version can be a Perl "v-string". It understands + version ranges as described in the L. For + example: + + =over 4 + + =item 1.3 + + =item >= 1.3 + + =item <= 1.3 + + =item == 1.3 + + =item != 1.3 + + =item > 1.3 + + =item < 1.3 + + =item >= 1.3, != 1.5, <= 2.0 + + A version number without an operator is equivalent to specifying a minimum + (C=>). Extra whitespace is allowed. + + =back + + =head2 from_string_hash + + my $req = CPAN::Meta::Requirements->from_string_hash( \%hash ); + my $req = CPAN::Meta::Requirements->from_string_hash( \%hash, \%opts ); + + This is an alternate constructor for a CPAN::Meta::Requirements + object. It takes a hash of module names and version requirement + strings and returns a new CPAN::Meta::Requirements object. As with + add_string_requirement, a version can be a Perl "v-string". Optionally, + you can supply a hash-reference of options, exactly as with the L + method. + + =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan + + =head1 SUPPORT + + =head2 Bugs / Feature Requests + + Please report any bugs or feature requests through the issue tracker + at L. + You will be notified automatically of any progress on your issue. + + =head2 Source Code + + This is open source software. The code repository is available for + public review and contribution under the terms of the license. + + L + + git clone https://github.com/dagolden/CPAN-Meta-Requirements.git + + =head1 AUTHORS + + =over 4 + + =item * + + David Golden + + =item * + + Ricardo Signes + + =back + + =head1 CONTRIBUTORS + + =for stopwords Ed J Karen Etheridge Leon Timmermans robario + + =over 4 + + =item * + + Ed J + + =item * + + Karen Etheridge + + =item * + + Leon Timmermans + + =item * + + robario + + =back + + =head1 COPYRIGHT AND LICENSE + + This software is copyright (c) 2010 by David Golden and Ricardo Signes. + + This is free software; you can redistribute it and/or modify it under + the same terms as the Perl 5 programming language system itself. + + =cut +CPAN_META_REQUIREMENTS + +$fatpacked{"CPAN/Meta/Spec.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_SPEC'; + # XXX RULES FOR PATCHING THIS FILE XXX + # Patches that fix typos or formatting are acceptable. Patches + # that change semantics are not acceptable without prior approval + # by David Golden or Ricardo Signes. + + use 5.006; + use strict; + use warnings; + package CPAN::Meta::Spec; + # VERSION + $CPAN::Meta::Spec::VERSION = '2.143240'; + 1; + + # ABSTRACT: specification for CPAN distribution metadata + + + # vi:tw=72 + + __END__ + + =pod + + =encoding UTF-8 + + =head1 NAME + + CPAN::Meta::Spec - specification for CPAN distribution metadata + + =head1 VERSION + + version 2.143240 + + =head1 SYNOPSIS + + my $distmeta = { + name => 'Module-Build', + abstract => 'Build and install Perl modules', + description => "Module::Build is a system for " + . "building, testing, and installing Perl modules. " + . "It is meant to ... blah blah blah ...", + version => '0.36', + release_status => 'stable', + author => [ + 'Ken Williams ', + 'Module-Build List ', # additional contact + ], + license => [ 'perl_5' ], + prereqs => { + runtime => { + requires => { + 'perl' => '5.006', + 'ExtUtils::Install' => '0', + 'File::Basename' => '0', + 'File::Compare' => '0', + 'IO::File' => '0', + }, + recommends => { + 'Archive::Tar' => '1.00', + 'ExtUtils::Install' => '0.3', + 'ExtUtils::ParseXS' => '2.02', + }, + }, + build => { + requires => { + 'Test::More' => '0', + }, + } + }, + resources => { + license => ['http://dev.perl.org/licenses/'], + }, + optional_features => { + domination => { + description => 'Take over the world', + prereqs => { + develop => { requires => { 'Genius::Evil' => '1.234' } }, + runtime => { requires => { 'Machine::Weather' => '2.0' } }, + }, + }, + }, + dynamic_config => 1, + keywords => [ qw/ toolchain cpan dual-life / ], + 'meta-spec' => { + version => '2', + url => 'https://metacpan.org/pod/CPAN::Meta::Spec', + }, + generated_by => 'Module::Build version 0.36', + }; + + =head1 DESCRIPTION + + This document describes version 2 of the CPAN distribution metadata + specification, also known as the "CPAN Meta Spec". + + Revisions of this specification for typo corrections and prose + clarifications may be issued as CPAN::Meta::Spec 2.I. These + revisions will never change semantics or add or remove specified + behavior. + + Distribution metadata describe important properties of Perl + distributions. Distribution building tools like Module::Build, + Module::Install, ExtUtils::MakeMaker or Dist::Zilla should create a + metadata file in accordance with this specification and include it with + the distribution for use by automated tools that index, examine, package + or install Perl distributions. + + =head1 TERMINOLOGY + + =over 4 + + =item distribution + + This is the primary object described by the metadata. In the context of + this document it usually refers to a collection of modules, scripts, + and/or documents that are distributed together for other developers to + use. Examples of distributions are C, C, + or C. + + =item module + + This refers to a reusable library of code contained in a single file. + Modules usually contain one or more packages and are often referred + to by the name of a primary package that can be mapped to the file + name. For example, one might refer to C instead of + F + + =item package + + This refers to a namespace declared with the Perl C statement. + In Perl, packages often have a version number property given by the + C<$VERSION> variable in the namespace. + + =item consumer + + This refers to code that reads a metadata file, deserializes it into a + data structure in memory, or interprets a data structure of metadata + elements. + + =item producer + + This refers to code that constructs a metadata data structure, + serializes into a bytestream and/or writes it to disk. + + =item must, should, may, etc. + + These terms are interpreted as described in IETF RFC 2119. + + =back + + =head1 DATA TYPES + + Fields in the L section describe data elements, each of + which has an associated data type as described herein. There are four + primitive types: Boolean, String, List and Map. Other types are + subtypes of primitives and define compound data structures or define + constraints on the values of a data element. + + =head2 Boolean + + A I is used to provide a true or false value. It B be + represented as a defined value. + + =head2 String + + A I is data element containing a non-zero length sequence of + Unicode characters, such as an ordinary Perl scalar that is not a + reference. + + =head2 List + + A I is an ordered collection of zero or more data elements. + Elements of a List may be of mixed types. + + Producers B represent List elements using a data structure which + unambiguously indicates that multiple values are possible, such as a + reference to a Perl array (an "arrayref"). + + Consumers expecting a List B consider a String as equivalent to a + List of length 1. + + =head2 Map + + A I is an unordered collection of zero or more data elements + ("values"), indexed by associated String elements ("keys"). The Map's + value elements may be of mixed types. + + =head2 License String + + A I is a subtype of String with a restricted set of + values. Valid values are described in detail in the description of + the L field. + + =head2 URL + + I is a subtype of String containing a Uniform Resource Locator or + Identifier. [ This type is called URL and not URI for historical reasons. ] + + =head2 Version + + A I is a subtype of String containing a value that describes + the version number of packages or distributions. Restrictions on format + are described in detail in the L section. + + =head2 Version Range + + The I type is a subtype of String. It describes a range + of Versions that may be present or installed to fulfill prerequisites. + It is specified in detail in the L section. + + =head1 STRUCTURE + + The metadata structure is a data element of type Map. This section + describes valid keys within the Map. + + Any keys not described in this specification document (whether top-level + or within compound data structures described herein) are considered + I and B begin with an "x" or "X" and be followed by an + underscore; i.e. they must match the pattern: C<< qr{\Ax_}i >>. If a + custom key refers to a compound data structure, subkeys within it do not + need an "x_" or "X_" prefix. + + Consumers of metadata may ignore any or all custom keys. All other keys + not described herein are invalid and should be ignored by consumers. + Producers must not generate or output invalid keys. + + For each key, an example is provided followed by a description. The + description begins with the version of spec in which the key was added + or in which the definition was modified, whether the key is I + or I and the data type of the corresponding data element. + These items are in parentheses, brackets and braces, respectively. + + If a data type is a Map or Map subtype, valid subkeys will be described + as well. + + Some fields are marked I. These are shown for historical + context and must not be produced in or consumed from any metadata structure + of version 2 or higher. + + =head2 REQUIRED FIELDS + + =head3 abstract + + Example: + + abstract => 'Build and install Perl modules' + + (Spec 1.2) [required] {String} + + This is a short description of the purpose of the distribution. + + =head3 author + + Example: + + author => [ 'Ken Williams ' ] + + (Spec 1.2) [required] {List of one or more Strings} + + This List indicates the person(s) to contact concerning the + distribution. The preferred form of the contact string is: + + contact-name + + This field provides a general contact list independent of other + structured fields provided within the L field, such as + C. The addressee(s) can be contacted for any purpose + including but not limited to (security) problems with the distribution, + questions about the distribution or bugs in the distribution. + + A distribution's original author is usually the contact listed within + this field. Co-maintainers, successor maintainers or mailing lists + devoted to the distribution may also be listed in addition to or instead + of the original author. + + =head3 dynamic_config + + Example: + + dynamic_config => 1 + + (Spec 2) [required] {Boolean} + + A boolean flag indicating whether a F or F (or + similar) must be executed to determine prerequisites. + + This field should be set to a true value if the distribution performs + some dynamic configuration (asking questions, sensing the environment, + etc.) as part of its configuration. This field should be set to a false + value to indicate that prerequisites included in metadata may be + considered final and valid for static analysis. + + Note: when this field is true, post-configuration prerequisites are not + guaranteed to bear any relation whatsoever to those stated in the metadata, + and relying on them doing so is an error. See also + L in the implementors' + notes. + + This field explicitly B indicate whether installation may be + safely performed without using a Makefile or Build file, as there may be + special files to install or custom installation targets (e.g. for + dual-life modules that exist on CPAN as well as in the Perl core). This + field only defines whether or not prerequisites are exactly as given in the + metadata. + + =head3 generated_by + + Example: + + generated_by => 'Module::Build version 0.36' + + (Spec 1.0) [required] {String} + + This field indicates the tool that was used to create this metadata. + There are no defined semantics for this field, but it is traditional to + use a string in the form "Generating::Package version 1.23" or the + author's name, if the file was generated by hand. + + =head3 license + + Example: + + license => [ 'perl_5' ] + + license => [ 'apache_2_0', 'mozilla_1_0' ] + + (Spec 2) [required] {List of one or more License Strings} + + One or more licenses that apply to some or all of the files in the + distribution. If multiple licenses are listed, the distribution + documentation should be consulted to clarify the interpretation of + multiple licenses. + + The following list of license strings are valid: + + string description + ------------- ----------------------------------------------- + agpl_3 GNU Affero General Public License, Version 3 + apache_1_1 Apache Software License, Version 1.1 + apache_2_0 Apache License, Version 2.0 + artistic_1 Artistic License, (Version 1) + artistic_2 Artistic License, Version 2.0 + bsd BSD License (three-clause) + freebsd FreeBSD License (two-clause) + gfdl_1_2 GNU Free Documentation License, Version 1.2 + gfdl_1_3 GNU Free Documentation License, Version 1.3 + gpl_1 GNU General Public License, Version 1 + gpl_2 GNU General Public License, Version 2 + gpl_3 GNU General Public License, Version 3 + lgpl_2_1 GNU Lesser General Public License, Version 2.1 + lgpl_3_0 GNU Lesser General Public License, Version 3.0 + mit MIT (aka X11) License + mozilla_1_0 Mozilla Public License, Version 1.0 + mozilla_1_1 Mozilla Public License, Version 1.1 + openssl OpenSSL License + perl_5 The Perl 5 License (Artistic 1 & GPL 1 or later) + qpl_1_0 Q Public License, Version 1.0 + ssleay Original SSLeay License + sun Sun Internet Standards Source License (SISSL) + zlib zlib License + + The following license strings are also valid and indicate other + licensing not described above: + + string description + ------------- ----------------------------------------------- + open_source Other Open Source Initiative (OSI) approved license + restricted Requires special permission from copyright holder + unrestricted Not an OSI approved license, but not restricted + unknown License not provided in metadata + + All other strings are invalid in the license field. + + =head3 meta-spec + + Example: + + 'meta-spec' => { + version => '2', + url => 'http://search.cpan.org/perldoc?CPAN::Meta::Spec', + } + + (Spec 1.2) [required] {Map} + + This field indicates the version of the CPAN Meta Spec that should be + used to interpret the metadata. Consumers must check this key as soon + as possible and abort further metadata processing if the meta-spec + version is not supported by the consumer. + + The following keys are valid, but only C is required. + + =over + + =item version + + This subkey gives the integer I of the CPAN Meta Spec against + which the document was generated. + + =item url + + This is a I of the metadata specification document corresponding to + the given version. This is strictly for human-consumption and should + not impact the interpretation of the document. + + For the version 2 spec, either of these are recommended: + + =over 4 + + =item * + + C + + =item * + + C + + =back + + =back + + =head3 name + + Example: + + name => 'Module-Build' + + (Spec 1.0) [required] {String} + + This field is the name of the distribution. This is often created by + taking the "main package" in the distribution and changing C<::> to + C<->, but the name may be completely unrelated to the packages within + the distribution. For example, L is distributed as part + of the distribution name "libwww-perl". + + =head3 release_status + + Example: + + release_status => 'stable' + + (Spec 2) [required] {String} + + This field provides the release status of this distribution. If the + C field contains an underscore character, then + C B be "stable." + + The C field B have one of the following values: + + =over + + =item stable + + This indicates an ordinary, "final" release that should be indexed by PAUSE + or other indexers. + + =item testing + + This indicates a "beta" release that is substantially complete, but has an + elevated risk of bugs and requires additional testing. The distribution + should not be installed over a stable release without an explicit request + or other confirmation from a user. This release status may also be used + for "release candidate" versions of a distribution. + + =item unstable + + This indicates an "alpha" release that is under active development, but has + been released for early feedback or testing and may be missing features or + may have serious bugs. The distribution should not be installed over a + stable release without an explicit request or other confirmation from a + user. + + =back + + Consumers B use this field to determine how to index the + distribution for CPAN or other repositories in addition to or in + replacement of heuristics based on version number or file name. + + =head3 version + + Example: + + version => '0.36' + + (Spec 1.0) [required] {Version} + + This field gives the version of the distribution to which the metadata + structure refers. + + =head2 OPTIONAL FIELDS + + =head3 description + + Example: + + description => "Module::Build is a system for " + . "building, testing, and installing Perl modules. " + . "It is meant to ... blah blah blah ...", + + (Spec 2) [optional] {String} + + A longer, more complete description of the purpose or intended use of + the distribution than the one provided by the C key. + + =head3 keywords + + Example: + + keywords => [ qw/ toolchain cpan dual-life / ] + + (Spec 1.1) [optional] {List of zero or more Strings} + + A List of keywords that describe this distribution. Keywords + B include whitespace. + + =head3 no_index + + Example: + + no_index => { + file => [ 'My/Module.pm' ], + directory => [ 'My/Private' ], + package => [ 'My::Module::Secret' ], + namespace => [ 'My::Module::Sample' ], + } + + (Spec 1.2) [optional] {Map} + + This Map describes any files, directories, packages, and namespaces that + are private to the packaging or implementation of the distribution and + should be ignored by indexing or search tools. Note that this is a list of + exclusions, and the spec does not define what to I - see + L in the implementors notes for more + information. + + Valid subkeys are as follows: + + =over + + =item file + + A I of relative paths to files. Paths B specified with + unix conventions. + + =item directory + + A I of relative paths to directories. Paths B specified + with unix conventions. + + [ Note: previous editions of the spec had C instead of C ] + + =item package + + A I of package names. + + =item namespace + + A I of package namespaces, where anything below the namespace + must be ignored, but I the namespace itself. + + In the example above for C, C would + be ignored, but C would not. + + =back + + =head3 optional_features + + Example: + + optional_features => { + sqlite => { + description => 'Provides SQLite support', + prereqs => { + runtime => { + requires => { + 'DBD::SQLite' => '1.25' + } + } + } + } + } + + (Spec 2) [optional] {Map} + + This Map describes optional features with incremental prerequisites. + Each key of the C Map is a String used to identify + the feature and each value is a Map with additional information about + the feature. Valid subkeys include: + + =over + + =item description + + This is a String describing the feature. Every optional feature + should provide a description + + =item prereqs + + This entry is required and has the same structure as that of the + C> key. It provides a list of package requirements + that must be satisfied for the feature to be supported or enabled. + + There is one crucial restriction: the prereqs of an optional feature + B include C phase prereqs. + + =back + + Consumers B include optional features as prerequisites without + explicit instruction from users (whether via interactive prompting, + a function parameter or a configuration value, etc. ). + + If an optional feature is used by a consumer to add additional + prerequisites, the consumer should merge the optional feature + prerequisites into those given by the C key using the same + semantics. See L for details on + merging prerequisites. + + I Because there is currently no way for a + distribution to specify a dependency on an optional feature of another + dependency, the use of C is discouraged. Instead, + create a separate, installable distribution that ensures the desired + feature is available. For example, if C has a C feature, + release a separate C distribution that satisfies + requirements for the feature. + + =head3 prereqs + + Example: + + prereqs => { + runtime => { + requires => { + 'perl' => '5.006', + 'File::Spec' => '0.86', + 'JSON' => '2.16', + }, + recommends => { + 'JSON::XS' => '2.26', + }, + suggests => { + 'Archive::Tar' => '0', + }, + }, + build => { + requires => { + 'Alien::SDL' => '1.00', + }, + }, + test => { + recommends => { + 'Test::Deep' => '0.10', + }, + } + } + + (Spec 2) [optional] {Map} + + This is a Map that describes all the prerequisites of the distribution. + The keys are phases of activity, such as C, C, C + or C. Values are Maps in which the keys name the type of + prerequisite relationship such as C, C, or + C and the value provides a set of prerequisite relations. The + set of relations B be specified as a Map of package names to + version ranges. + + The full definition for this field is given in the L + section. + + =head3 provides + + Example: + + provides => { + 'Foo::Bar' => { + file => 'lib/Foo/Bar.pm', + version => '0.27_02', + }, + 'Foo::Bar::Blah' => { + file => 'lib/Foo/Bar/Blah.pm', + }, + 'Foo::Bar::Baz' => { + file => 'lib/Foo/Bar/Baz.pm', + version => '0.3', + }, + } + + (Spec 1.2) [optional] {Map} + + This describes all packages provided by this distribution. This + information is used by distribution and automation mechanisms like + PAUSE, CPAN, metacpan.org and search.cpan.org to build indexes saying in + which distribution various packages can be found. + + The keys of C are package names that can be found within + the distribution. If a package name key is provided, it must + have a Map with the following valid subkeys: + + =over + + =item file + + This field is required. It must contain a Unix-style relative file path + from the root of the distribution directory to a file that contains or + generates the package. It may be given as C or C + to claim a package for indexing without needing a C<*.pm>. + + =item version + + If it exists, this field must contains a I String for the + package. If the package does not have a C<$VERSION>, this field must + be omitted. + + =back + + =head3 resources + + Example: + + resources => { + license => [ 'http://dev.perl.org/licenses/' ], + homepage => 'http://sourceforge.net/projects/module-build', + bugtracker => { + web => 'http://rt.cpan.org/Public/Dist/Display.html?Name=CPAN-Meta', + mailto => 'meta-bugs@example.com', + }, + repository => { + url => 'git://github.com/dagolden/cpan-meta.git', + web => 'http://github.com/dagolden/cpan-meta', + type => 'git', + }, + x_twitter => 'http://twitter.com/cpan_linked/', + } + + (Spec 2) [optional] {Map} + + This field describes resources related to this distribution. + + Valid subkeys include: + + =over + + =item homepage + + The official home of this project on the web. + + =item license + + A List of I's that relate to this distribution's license. As with the + top-level C field, distribution documentation should be consulted + to clarify the interpretation of multiple licenses provided here. + + =item bugtracker + + This entry describes the bug tracking system for this distribution. It + is a Map with the following valid keys: + + web - a URL pointing to a web front-end for the bug tracker + mailto - an email address to which bugs can be sent + + =item repository + + This entry describes the source control repository for this distribution. It + is a Map with the following valid keys: + + url - a URL pointing to the repository itself + web - a URL pointing to a web front-end for the repository + type - a lowercase string indicating the VCS used + + Because a url like C is ambiguous as to + type, producers should provide a C whenever a C key is given. + The C field should be the name of the most common program used + to work with the repository, e.g. C, C, C, C, + C or C. + + =back + + =head2 DEPRECATED FIELDS + + =head3 build_requires + + I<(Deprecated in Spec 2)> [optional] {String} + + Replaced by C + + =head3 configure_requires + + I<(Deprecated in Spec 2)> [optional] {String} + + Replaced by C + + =head3 conflicts + + I<(Deprecated in Spec 2)> [optional] {String} + + Replaced by C + + =head3 distribution_type + + I<(Deprecated in Spec 2)> [optional] {String} + + This field indicated 'module' or 'script' but was considered + meaningless, since many distributions are hybrids of several kinds of + things. + + =head3 license_uri + + I<(Deprecated in Spec 1.2)> [optional] {URL} + + Replaced by C in C + + =head3 private + + I<(Deprecated in Spec 1.2)> [optional] {Map} + + This field has been renamed to L. + + =head3 recommends + + I<(Deprecated in Spec 2)> [optional] {String} + + Replaced by C + + =head3 requires + + I<(Deprecated in Spec 2)> [optional] {String} + + Replaced by C + + =head1 VERSION NUMBERS + + =head2 Version Formats + + This section defines the Version type, used by several fields in the + CPAN Meta Spec. + + Version numbers must be treated as strings, not numbers. For + example, C<1.200> B be serialized as C<1.2>. Version + comparison should be delegated to the Perl L module, version + 0.80 or newer. + + Unless otherwise specified, version numbers B appear in one of two + formats: + + =over + + =item Decimal versions + + Decimal versions are regular "decimal numbers", with some limitations. + They B be non-negative and B begin and end with a digit. A + single underscore B be included, but B be between two digits. + They B use exponential notation ("1.23e-2"). + + version => '1.234' # OK + version => '1.23_04' # OK + + version => '1.23_04_05' # Illegal + version => '1.' # Illegal + version => '.1' # Illegal + + =item Dotted-integer versions + + Dotted-integer (also known as dotted-decimal) versions consist of + positive integers separated by full stop characters (i.e. "dots", + "periods" or "decimal points"). This are equivalent in format to Perl + "v-strings", with some additional restrictions on form. They must be + given in "normal" form, which has a leading "v" character and at least + three integer components. To retain a one-to-one mapping with decimal + versions, all components after the first B be restricted to the + range 0 to 999. The final component B be separated by an + underscore character instead of a period. + + version => 'v1.2.3' # OK + version => 'v1.2_3' # OK + version => 'v1.2.3.4' # OK + version => 'v1.2.3_4' # OK + version => 'v2009.10.31' # OK + + version => 'v1.2' # Illegal + version => '1.2.3' # Illegal + version => 'v1.2_3_4' # Illegal + version => 'v1.2009.10.31' # Not recommended + + =back + + =head2 Version Ranges + + Some fields (prereq, optional_features) indicate the particular + version(s) of some other module that may be required as a prerequisite. + This section details the Version Range type used to provide this + information. + + The simplest format for a Version Range is just the version + number itself, e.g. C<2.4>. This means that B version 2.4 + must be present. To indicate that B version of a prerequisite is + okay, even if the prerequisite doesn't define a version at all, use + the version C<0>. + + Alternatively, a version range B use the operators E (less than), + E= (less than or equal), E (greater than), E= (greater than + or equal), == (equal), and != (not equal). For example, the + specification C 2.0> means that any version of the prerequisite + less than 2.0 is suitable. + + For more complicated situations, version specifications B be AND-ed + together using commas. The specification C= 1.2, != 1.5, E + 2.0> indicates a version that must be B 1.2, B 2.0, + and B 1.5. + + =head1 PREREQUISITES + + =head2 Prereq Spec + + The C key in the top-level metadata and within + C define the relationship between a distribution and + other packages. The prereq spec structure is a hierarchical data + structure which divides prerequisites into I of activity in the + installation process and I that indicate how + prerequisites should be resolved. + + For example, to specify that C is C during the + C phase, this entry would appear in the distribution metadata: + + prereqs => { + test => { + requires => { + 'Data::Dumper' => '2.00' + } + } + } + + =head3 Phases + + Requirements for regular use must be listed in the C phase. + Other requirements should be listed in the earliest stage in which they + are required and consumers must accumulate and satisfy requirements + across phases before executing the activity. For example, C + requirements must also be available during the C phase. + + before action requirements that must be met + ---------------- -------------------------------- + perl Build.PL configure + perl Makefile.PL + + make configure, runtime, build + Build + + make test configure, runtime, build, test + Build test + + Consumers that install the distribution must ensure that + I requirements are also installed and may install + dependencies from other phases. + + after action requirements that must be met + ---------------- -------------------------------- + make install runtime + Build install + + =over + + =item configure + + The configure phase occurs before any dynamic configuration has been + attempted. Libraries required by the configure phase B be + available for use before the distribution building tool has been + executed. + + =item build + + The build phase is when the distribution's source code is compiled (if + necessary) and otherwise made ready for installation. + + =item test + + The test phase is when the distribution's automated test suite is run. + Any library that is needed only for testing and not for subsequent use + should be listed here. + + =item runtime + + The runtime phase refers not only to when the distribution's contents + are installed, but also to its continued use. Any library that is a + prerequisite for regular use of this distribution should be indicated + here. + + =item develop + + The develop phase's prereqs are libraries needed to work on the + distribution's source code as its author does. These tools might be + needed to build a release tarball, to run author-only tests, or to + perform other tasks related to developing new versions of the + distribution. + + =back + + =head3 Relationships + + =over + + =item requires + + These dependencies B be installed for proper completion of the + phase. + + =item recommends + + Recommended dependencies are I encouraged and should be + satisfied except in resource constrained environments. + + =item suggests + + These dependencies are optional, but are suggested for enhanced operation + of the described distribution. + + =item conflicts + + These libraries cannot be installed when the phase is in operation. + This is a very rare situation, and the C relationship should + be used with great caution, or not at all. + + =back + + =head2 Merging and Resolving Prerequisites + + Whenever metadata consumers merge prerequisites, either from different + phases or from C, they should merged in a way which + preserves the intended semantics of the prerequisite structure. Generally, + this means concatenating the version specifications using commas, as + described in the L section. + + Another subtle error that can occur in resolving prerequisites comes from + the way that modules in prerequisites are indexed to distribution files on + CPAN. When a module is deleted from a distribution, prerequisites calling + for that module could indicate an older distribution should be installed, + potentially overwriting files from a newer distribution. + + For example, as of Oct 31, 2009, the CPAN index file contained these + module-distribution mappings: + + Class::MOP 0.94 D/DR/DROLSKY/Class-MOP-0.94.tar.gz + Class::MOP::Class 0.94 D/DR/DROLSKY/Class-MOP-0.94.tar.gz + Class::MOP::Class::Immutable 0.04 S/ST/STEVAN/Class-MOP-0.36.tar.gz + + Consider the case where "Class::MOP" 0.94 is installed. If a + distribution specified "Class::MOP::Class::Immutable" as a prerequisite, + it could result in Class-MOP-0.36.tar.gz being installed, overwriting + any files from Class-MOP-0.94.tar.gz. + + Consumers of metadata B test whether prerequisites would result + in installed module files being "downgraded" to an older version and + B warn users or ignore the prerequisite that would cause such a + result. + + =head1 SERIALIZATION + + Distribution metadata should be serialized (as a hashref) as + JSON-encoded data and packaged with distributions as the file + F. + + In the past, the distribution metadata structure had been packed with + distributions as F, a file in the YAML Tiny format (for which, + see L). Tools that consume distribution metadata from disk + should be capable of loading F, but should prefer F + if both are found. + + =head1 NOTES FOR IMPLEMENTORS + + =head2 Extracting Version Numbers from Perl Modules + + To get the version number from a Perl module, consumers should use the + C<< MM->parse_version($file) >> method provided by + L or L. For example, for the + module given by C<$mod>, the version may be retrieved in one of the + following ways: + + # via ExtUtils::MakeMaker + my $file = MM->_installed_file_for_module($mod); + my $version = MM->parse_version($file) + + The private C<_installed_file_for_module> method may be replaced with + other methods for locating a module in C<@INC>. + + # via Module::Metadata + my $info = Module::Metadata->new_from_module($mod); + my $version = $info->version; + + If only a filename is available, the following approach may be used: + + # via Module::Build + my $info = Module::Metadata->new_from_file($file); + my $version = $info->version; + + =head2 Comparing Version Numbers + + The L module provides the most reliable way to compare version + numbers in all the various ways they might be provided or might exist + within modules. Given two strings containing version numbers, C<$v1> and + C<$v2>, they should be converted to C objects before using + ordinary comparison operators. For example: + + use version; + if ( version->new($v1) <=> version->new($v2) ) { + print "Versions are not equal\n"; + } + + If the only comparison needed is whether an installed module is of a + sufficiently high version, a direct test may be done using the string + form of C and the C function. For example, for module C<$mod> + and version prerequisite C<$prereq>: + + if ( eval "use $mod $prereq (); 1" ) { + print "Module $mod version is OK.\n"; + } + + If the values of C<$mod> and C<$prereq> have not been scrubbed, however, + this presents security implications. + + =head2 Prerequisites for dynamically configured distributions + + When C is true, it is an error to presume that the + prerequisites given in distribution metadata will have any relationship + whatsoever to the actual prerequisites of the distribution. + + In practice, however, one can generally expect such prerequisites to be + one of two things: + + =over 4 + + =item * + + The minimum prerequisites for the distribution, to which dynamic configuration will only add items + + =item * + + Whatever the distribution configured with on the releaser's machine at release time + + =back + + The second case often turns out to have identical results to the first case, + albeit only by accident. + + As such, consumers may use this data for informational analysis, but + presenting it to the user as canonical or relying on it as such is + invariably the height of folly. + + =head2 Indexing distributions a la PAUSE + + While no_index tells you what must be ignored when indexing, this spec holds + no opinion on how you should get your initial candidate list of things to + possibly index. For "normal" distributions you might consider simply indexing + the contents of lib/, but there are many fascinating oddities on CPAN and + many dists from the days when it was normal to put the main .pm file in the + root of the distribution archive - so PAUSE currently indexes all .pm and .PL + files that are not either (a) specifically excluded by no_index (b) in + C, C, or C directories, or common 'mistake' directories such as + C. + + Or: If you're trying to be PAUSE-like, make sure you skip C, C and + C as well as anything marked as no_index. + + Also remember: If the META file contains a provides field, you shouldn't be + indexing anything in the first place - just use that. + + =head1 SEE ALSO + + =over 4 + + =item * + + CPAN, L + + =item * + + JSON, L + + =item * + + YAML, L + + =item * + + L + + =item * + + L + + =item * + + L + + =item * + + L + + =item * + + L + + =back + + =head1 HISTORY + + Ken Williams wrote the original CPAN Meta Spec (also known as the + "META.yml spec") in 2003 and maintained it through several revisions + with input from various members of the community. In 2005, Randy + Sims redrafted it from HTML to POD for the version 1.2 release. Ken + continued to maintain the spec through version 1.4. + + In late 2009, David Golden organized the version 2 proposal review + process. David and Ricardo Signes drafted the final version 2 spec + in April 2010 based on the version 1.4 spec and patches contributed + during the proposal process. + + =head1 AUTHORS + + =over 4 + + =item * + + David Golden + + =item * + + Ricardo Signes + + =back + + =head1 COPYRIGHT AND LICENSE + + This software is copyright (c) 2010 by David Golden and Ricardo Signes. + + This is free software; you can redistribute it and/or modify it under + the same terms as the Perl 5 programming language system itself. + + =cut +CPAN_META_SPEC + +$fatpacked{"CPAN/Meta/Validator.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_VALIDATOR'; + use 5.006; + use strict; + use warnings; + package CPAN::Meta::Validator; + # VERSION + $CPAN::Meta::Validator::VERSION = '2.143240'; + #pod =head1 SYNOPSIS + #pod + #pod my $struct = decode_json_file('META.json'); + #pod + #pod my $cmv = CPAN::Meta::Validator->new( $struct ); + #pod + #pod unless ( $cmv->is_valid ) { + #pod my $msg = "Invalid META structure. Errors found:\n"; + #pod $msg .= join( "\n", $cmv->errors ); + #pod die $msg; + #pod } + #pod + #pod =head1 DESCRIPTION + #pod + #pod This module validates a CPAN Meta structure against the version of the + #pod the specification claimed in the C field of the structure. + #pod + #pod =cut + + #--------------------------------------------------------------------------# + # This code copied and adapted from Test::CPAN::Meta + # by Barbie, for Miss Barbell Productions, + # L + #--------------------------------------------------------------------------# + + #--------------------------------------------------------------------------# + # Specification Definitions + #--------------------------------------------------------------------------# + + my %known_specs = ( + '1.4' => 'http://module-build.sourceforge.net/META-spec-v1.4.html', + '1.3' => 'http://module-build.sourceforge.net/META-spec-v1.3.html', + '1.2' => 'http://module-build.sourceforge.net/META-spec-v1.2.html', + '1.1' => 'http://module-build.sourceforge.net/META-spec-v1.1.html', + '1.0' => 'http://module-build.sourceforge.net/META-spec-v1.0.html' + ); + my %known_urls = map {$known_specs{$_} => $_} keys %known_specs; + + my $module_map1 = { 'map' => { ':key' => { name => \&module, value => \&exversion } } }; + + my $module_map2 = { 'map' => { ':key' => { name => \&module, value => \&version } } }; + + my $no_index_2 = { + 'map' => { file => { list => { value => \&string } }, + directory => { list => { value => \&string } }, + 'package' => { list => { value => \&string } }, + namespace => { list => { value => \&string } }, + ':key' => { name => \&custom_2, value => \&anything }, + } + }; + + my $no_index_1_3 = { + 'map' => { file => { list => { value => \&string } }, + directory => { list => { value => \&string } }, + 'package' => { list => { value => \&string } }, + namespace => { list => { value => \&string } }, + ':key' => { name => \&string, value => \&anything }, + } + }; + + my $no_index_1_2 = { + 'map' => { file => { list => { value => \&string } }, + dir => { list => { value => \&string } }, + 'package' => { list => { value => \&string } }, + namespace => { list => { value => \&string } }, + ':key' => { name => \&string, value => \&anything }, + } + }; + + my $no_index_1_1 = { + 'map' => { ':key' => { name => \&string, list => { value => \&string } }, + } + }; + + my $prereq_map = { + map => { + ':key' => { + name => \&phase, + 'map' => { + ':key' => { + name => \&relation, + %$module_map1, + }, + }, + } + }, + }; + + my %definitions = ( + '2' => { + # REQUIRED + 'abstract' => { mandatory => 1, value => \&string }, + 'author' => { mandatory => 1, list => { value => \&string } }, + 'dynamic_config' => { mandatory => 1, value => \&boolean }, + 'generated_by' => { mandatory => 1, value => \&string }, + 'license' => { mandatory => 1, list => { value => \&license } }, + 'meta-spec' => { + mandatory => 1, + 'map' => { + version => { mandatory => 1, value => \&version}, + url => { value => \&url }, + ':key' => { name => \&custom_2, value => \&anything }, + } + }, + 'name' => { mandatory => 1, value => \&string }, + 'release_status' => { mandatory => 1, value => \&release_status }, + 'version' => { mandatory => 1, value => \&version }, + + # OPTIONAL + 'description' => { value => \&string }, + 'keywords' => { list => { value => \&string } }, + 'no_index' => $no_index_2, + 'optional_features' => { + 'map' => { + ':key' => { + name => \&string, + 'map' => { + description => { value => \&string }, + prereqs => $prereq_map, + ':key' => { name => \&custom_2, value => \&anything }, + } + } + } + }, + 'prereqs' => $prereq_map, + 'provides' => { + 'map' => { + ':key' => { + name => \&module, + 'map' => { + file => { mandatory => 1, value => \&file }, + version => { value => \&version }, + ':key' => { name => \&custom_2, value => \&anything }, + } + } + } + }, + 'resources' => { + 'map' => { + license => { list => { value => \&url } }, + homepage => { value => \&url }, + bugtracker => { + 'map' => { + web => { value => \&url }, + mailto => { value => \&string}, + ':key' => { name => \&custom_2, value => \&anything }, + } + }, + repository => { + 'map' => { + web => { value => \&url }, + url => { value => \&url }, + type => { value => \&string }, + ':key' => { name => \&custom_2, value => \&anything }, + } + }, + ':key' => { value => \&string, name => \&custom_2 }, + } + }, + + # CUSTOM -- additional user defined key/value pairs + # note we can only validate the key name, as the structure is user defined + ':key' => { name => \&custom_2, value => \&anything }, + }, + + '1.4' => { + 'meta-spec' => { + mandatory => 1, + 'map' => { + version => { mandatory => 1, value => \&version}, + url => { mandatory => 1, value => \&urlspec }, + ':key' => { name => \&string, value => \&anything }, + }, + }, + + 'name' => { mandatory => 1, value => \&string }, + 'version' => { mandatory => 1, value => \&version }, + 'abstract' => { mandatory => 1, value => \&string }, + 'author' => { mandatory => 1, list => { value => \&string } }, + 'license' => { mandatory => 1, value => \&license }, + 'generated_by' => { mandatory => 1, value => \&string }, + + 'distribution_type' => { value => \&string }, + 'dynamic_config' => { value => \&boolean }, + + 'requires' => $module_map1, + 'recommends' => $module_map1, + 'build_requires' => $module_map1, + 'configure_requires' => $module_map1, + 'conflicts' => $module_map2, + + 'optional_features' => { + 'map' => { + ':key' => { name => \&string, + 'map' => { description => { value => \&string }, + requires => $module_map1, + recommends => $module_map1, + build_requires => $module_map1, + conflicts => $module_map2, + ':key' => { name => \&string, value => \&anything }, + } + } + } + }, + + 'provides' => { + 'map' => { + ':key' => { name => \&module, + 'map' => { + file => { mandatory => 1, value => \&file }, + version => { value => \&version }, + ':key' => { name => \&string, value => \&anything }, + } + } + } + }, + + 'no_index' => $no_index_1_3, + 'private' => $no_index_1_3, + + 'keywords' => { list => { value => \&string } }, + + 'resources' => { + 'map' => { license => { value => \&url }, + homepage => { value => \&url }, + bugtracker => { value => \&url }, + repository => { value => \&url }, + ':key' => { value => \&string, name => \&custom_1 }, + } + }, + + # additional user defined key/value pairs + # note we can only validate the key name, as the structure is user defined + ':key' => { name => \&string, value => \&anything }, + }, + + '1.3' => { + 'meta-spec' => { + mandatory => 1, + 'map' => { + version => { mandatory => 1, value => \&version}, + url => { mandatory => 1, value => \&urlspec }, + ':key' => { name => \&string, value => \&anything }, + }, + }, + + 'name' => { mandatory => 1, value => \&string }, + 'version' => { mandatory => 1, value => \&version }, + 'abstract' => { mandatory => 1, value => \&string }, + 'author' => { mandatory => 1, list => { value => \&string } }, + 'license' => { mandatory => 1, value => \&license }, + 'generated_by' => { mandatory => 1, value => \&string }, + + 'distribution_type' => { value => \&string }, + 'dynamic_config' => { value => \&boolean }, + + 'requires' => $module_map1, + 'recommends' => $module_map1, + 'build_requires' => $module_map1, + 'conflicts' => $module_map2, + + 'optional_features' => { + 'map' => { + ':key' => { name => \&string, + 'map' => { description => { value => \&string }, + requires => $module_map1, + recommends => $module_map1, + build_requires => $module_map1, + conflicts => $module_map2, + ':key' => { name => \&string, value => \&anything }, + } + } + } + }, + + 'provides' => { + 'map' => { + ':key' => { name => \&module, + 'map' => { + file => { mandatory => 1, value => \&file }, + version => { value => \&version }, + ':key' => { name => \&string, value => \&anything }, + } + } + } + }, + + + 'no_index' => $no_index_1_3, + 'private' => $no_index_1_3, + + 'keywords' => { list => { value => \&string } }, + + 'resources' => { + 'map' => { license => { value => \&url }, + homepage => { value => \&url }, + bugtracker => { value => \&url }, + repository => { value => \&url }, + ':key' => { value => \&string, name => \&custom_1 }, + } + }, + + # additional user defined key/value pairs + # note we can only validate the key name, as the structure is user defined + ':key' => { name => \&string, value => \&anything }, + }, + + # v1.2 is misleading, it seems to assume that a number of fields where created + # within v1.1, when they were created within v1.2. This may have been an + # original mistake, and that a v1.1 was retro fitted into the timeline, when + # v1.2 was originally slated as v1.1. But I could be wrong ;) + '1.2' => { + 'meta-spec' => { + mandatory => 1, + 'map' => { + version => { mandatory => 1, value => \&version}, + url => { mandatory => 1, value => \&urlspec }, + ':key' => { name => \&string, value => \&anything }, + }, + }, + + + 'name' => { mandatory => 1, value => \&string }, + 'version' => { mandatory => 1, value => \&version }, + 'license' => { mandatory => 1, value => \&license }, + 'generated_by' => { mandatory => 1, value => \&string }, + 'author' => { mandatory => 1, list => { value => \&string } }, + 'abstract' => { mandatory => 1, value => \&string }, + + 'distribution_type' => { value => \&string }, + 'dynamic_config' => { value => \&boolean }, + + 'keywords' => { list => { value => \&string } }, + + 'private' => $no_index_1_2, + '$no_index' => $no_index_1_2, + + 'requires' => $module_map1, + 'recommends' => $module_map1, + 'build_requires' => $module_map1, + 'conflicts' => $module_map2, + + 'optional_features' => { + 'map' => { + ':key' => { name => \&string, + 'map' => { description => { value => \&string }, + requires => $module_map1, + recommends => $module_map1, + build_requires => $module_map1, + conflicts => $module_map2, + ':key' => { name => \&string, value => \&anything }, + } + } + } + }, + + 'provides' => { + 'map' => { + ':key' => { name => \&module, + 'map' => { + file => { mandatory => 1, value => \&file }, + version => { value => \&version }, + ':key' => { name => \&string, value => \&anything }, + } + } + } + }, + + 'resources' => { + 'map' => { license => { value => \&url }, + homepage => { value => \&url }, + bugtracker => { value => \&url }, + repository => { value => \&url }, + ':key' => { value => \&string, name => \&custom_1 }, + } + }, + + # additional user defined key/value pairs + # note we can only validate the key name, as the structure is user defined + ':key' => { name => \&string, value => \&anything }, + }, + + # note that the 1.1 spec only specifies 'version' as mandatory + '1.1' => { + 'name' => { value => \&string }, + 'version' => { mandatory => 1, value => \&version }, + 'license' => { value => \&license }, + 'generated_by' => { value => \&string }, + + 'license_uri' => { value => \&url }, + 'distribution_type' => { value => \&string }, + 'dynamic_config' => { value => \&boolean }, + + 'private' => $no_index_1_1, + + 'requires' => $module_map1, + 'recommends' => $module_map1, + 'build_requires' => $module_map1, + 'conflicts' => $module_map2, + + # additional user defined key/value pairs + # note we can only validate the key name, as the structure is user defined + ':key' => { name => \&string, value => \&anything }, + }, + + # note that the 1.0 spec doesn't specify optional or mandatory fields + # but we will treat version as mandatory since otherwise META 1.0 is + # completely arbitrary and pointless + '1.0' => { + 'name' => { value => \&string }, + 'version' => { mandatory => 1, value => \&version }, + 'license' => { value => \&license }, + 'generated_by' => { value => \&string }, + + 'license_uri' => { value => \&url }, + 'distribution_type' => { value => \&string }, + 'dynamic_config' => { value => \&boolean }, + + 'requires' => $module_map1, + 'recommends' => $module_map1, + 'build_requires' => $module_map1, + 'conflicts' => $module_map2, + + # additional user defined key/value pairs + # note we can only validate the key name, as the structure is user defined + ':key' => { name => \&string, value => \&anything }, + }, + ); + + #--------------------------------------------------------------------------# + # Code + #--------------------------------------------------------------------------# + + #pod =method new + #pod + #pod my $cmv = CPAN::Meta::Validator->new( $struct ) + #pod + #pod The constructor must be passed a metadata structure. + #pod + #pod =cut + + sub new { + my ($class,$data) = @_; + + # create an attributes hash + my $self = { + 'data' => $data, + 'spec' => eval { $data->{'meta-spec'}{'version'} } || "1.0", + 'errors' => undef, + }; + + # create the object + return bless $self, $class; + } + + #pod =method is_valid + #pod + #pod if ( $cmv->is_valid ) { + #pod ... + #pod } + #pod + #pod Returns a boolean value indicating whether the metadata provided + #pod is valid. + #pod + #pod =cut + + sub is_valid { + my $self = shift; + my $data = $self->{data}; + my $spec_version = $self->{spec}; + $self->check_map($definitions{$spec_version},$data); + return ! $self->errors; + } + + #pod =method errors + #pod + #pod warn( join "\n", $cmv->errors ); + #pod + #pod Returns a list of errors seen during validation. + #pod + #pod =cut + + sub errors { + my $self = shift; + return () unless(defined $self->{errors}); + return @{$self->{errors}}; + } + + #pod =begin :internals + #pod + #pod =head2 Check Methods + #pod + #pod =over + #pod + #pod =item * + #pod + #pod check_map($spec,$data) + #pod + #pod Checks whether a map (or hash) part of the data structure conforms to the + #pod appropriate specification definition. + #pod + #pod =item * + #pod + #pod check_list($spec,$data) + #pod + #pod Checks whether a list (or array) part of the data structure conforms to + #pod the appropriate specification definition. + #pod + #pod =item * + #pod + #pod =back + #pod + #pod =cut + + my $spec_error = "Missing validation action in specification. " + . "Must be one of 'map', 'list', or 'value'"; + + sub check_map { + my ($self,$spec,$data) = @_; + + if(ref($spec) ne 'HASH') { + $self->_error( "Unknown META specification, cannot validate." ); + return; + } + + if(ref($data) ne 'HASH') { + $self->_error( "Expected a map structure from string or file." ); + return; + } + + for my $key (keys %$spec) { + next unless($spec->{$key}->{mandatory}); + next if(defined $data->{$key}); + push @{$self->{stack}}, $key; + $self->_error( "Missing mandatory field, '$key'" ); + pop @{$self->{stack}}; + } + + for my $key (keys %$data) { + push @{$self->{stack}}, $key; + if($spec->{$key}) { + if($spec->{$key}{value}) { + $spec->{$key}{value}->($self,$key,$data->{$key}); + } elsif($spec->{$key}{'map'}) { + $self->check_map($spec->{$key}{'map'},$data->{$key}); + } elsif($spec->{$key}{'list'}) { + $self->check_list($spec->{$key}{'list'},$data->{$key}); + } else { + $self->_error( "$spec_error for '$key'" ); + } + + } elsif ($spec->{':key'}) { + $spec->{':key'}{name}->($self,$key,$key); + if($spec->{':key'}{value}) { + $spec->{':key'}{value}->($self,$key,$data->{$key}); + } elsif($spec->{':key'}{'map'}) { + $self->check_map($spec->{':key'}{'map'},$data->{$key}); + } elsif($spec->{':key'}{'list'}) { + $self->check_list($spec->{':key'}{'list'},$data->{$key}); + } else { + $self->_error( "$spec_error for ':key'" ); + } + + + } else { + $self->_error( "Unknown key, '$key', found in map structure" ); + } + pop @{$self->{stack}}; + } + } + + sub check_list { + my ($self,$spec,$data) = @_; + + if(ref($data) ne 'ARRAY') { + $self->_error( "Expected a list structure" ); + return; + } + + if(defined $spec->{mandatory}) { + if(!defined $data->[0]) { + $self->_error( "Missing entries from mandatory list" ); + } + } + + for my $value (@$data) { + push @{$self->{stack}}, $value || ""; + if(defined $spec->{value}) { + $spec->{value}->($self,'list',$value); + } elsif(defined $spec->{'map'}) { + $self->check_map($spec->{'map'},$value); + } elsif(defined $spec->{'list'}) { + $self->check_list($spec->{'list'},$value); + } elsif ($spec->{':key'}) { + $self->check_map($spec,$value); + } else { + $self->_error( "$spec_error associated with '$self->{stack}[-2]'" ); + } + pop @{$self->{stack}}; + } + } + + #pod =head2 Validator Methods + #pod + #pod =over + #pod + #pod =item * + #pod + #pod header($self,$key,$value) + #pod + #pod Validates that the header is valid. + #pod + #pod Note: No longer used as we now read the data structure, not the file. + #pod + #pod =item * + #pod + #pod url($self,$key,$value) + #pod + #pod Validates that a given value is in an acceptable URL format + #pod + #pod =item * + #pod + #pod urlspec($self,$key,$value) + #pod + #pod Validates that the URL to a META specification is a known one. + #pod + #pod =item * + #pod + #pod string_or_undef($self,$key,$value) + #pod + #pod Validates that the value is either a string or an undef value. Bit of a + #pod catchall function for parts of the data structure that are completely user + #pod defined. + #pod + #pod =item * + #pod + #pod string($self,$key,$value) + #pod + #pod Validates that a string exists for the given key. + #pod + #pod =item * + #pod + #pod file($self,$key,$value) + #pod + #pod Validate that a file is passed for the given key. This may be made more + #pod thorough in the future. For now it acts like \&string. + #pod + #pod =item * + #pod + #pod exversion($self,$key,$value) + #pod + #pod Validates a list of versions, e.g. '<= 5, >=2, ==3, !=4, >1, <6, 0'. + #pod + #pod =item * + #pod + #pod version($self,$key,$value) + #pod + #pod Validates a single version string. Versions of the type '5.8.8' and '0.00_00' + #pod are both valid. A leading 'v' like 'v1.2.3' is also valid. + #pod + #pod =item * + #pod + #pod boolean($self,$key,$value) + #pod + #pod Validates for a boolean value. Currently these values are '1', '0', 'true', + #pod 'false', however the latter 2 may be removed. + #pod + #pod =item * + #pod + #pod license($self,$key,$value) + #pod + #pod Validates that a value is given for the license. Returns 1 if an known license + #pod type, or 2 if a value is given but the license type is not a recommended one. + #pod + #pod =item * + #pod + #pod custom_1($self,$key,$value) + #pod + #pod Validates that the given key is in CamelCase, to indicate a user defined + #pod keyword and only has characters in the class [-_a-zA-Z]. In version 1.X + #pod of the spec, this was only explicitly stated for 'resources'. + #pod + #pod =item * + #pod + #pod custom_2($self,$key,$value) + #pod + #pod Validates that the given key begins with 'x_' or 'X_', to indicate a user + #pod defined keyword and only has characters in the class [-_a-zA-Z] + #pod + #pod =item * + #pod + #pod identifier($self,$key,$value) + #pod + #pod Validates that key is in an acceptable format for the META specification, + #pod for an identifier, i.e. any that matches the regular expression + #pod qr/[a-z][a-z_]/i. + #pod + #pod =item * + #pod + #pod module($self,$key,$value) + #pod + #pod Validates that a given key is in an acceptable module name format, e.g. + #pod 'Test::CPAN::Meta::Version'. + #pod + #pod =back + #pod + #pod =end :internals + #pod + #pod =cut + + sub header { + my ($self,$key,$value) = @_; + if(defined $value) { + return 1 if($value && $value =~ /^--- #YAML:1.0/); + } + $self->_error( "file does not have a valid YAML header." ); + return 0; + } + + sub release_status { + my ($self,$key,$value) = @_; + if(defined $value) { + my $version = $self->{data}{version} || ''; + if ( $version =~ /_/ ) { + return 1 if ( $value =~ /\A(?:testing|unstable)\z/ ); + $self->_error( "'$value' for '$key' is invalid for version '$version'" ); + } + else { + return 1 if ( $value =~ /\A(?:stable|testing|unstable)\z/ ); + $self->_error( "'$value' for '$key' is invalid" ); + } + } + else { + $self->_error( "'$key' is not defined" ); + } + return 0; + } + + # _uri_split taken from URI::Split by Gisle Aas, Copyright 2003 + sub _uri_split { + return $_[0] =~ m,(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?,; + } + + sub url { + my ($self,$key,$value) = @_; + if(defined $value) { + my ($scheme, $auth, $path, $query, $frag) = _uri_split($value); + unless ( defined $scheme && length $scheme ) { + $self->_error( "'$value' for '$key' does not have a URL scheme" ); + return 0; + } + unless ( defined $auth && length $auth ) { + $self->_error( "'$value' for '$key' does not have a URL authority" ); + return 0; + } + return 1; + } + $value ||= ''; + $self->_error( "'$value' for '$key' is not a valid URL." ); + return 0; + } + + sub urlspec { + my ($self,$key,$value) = @_; + if(defined $value) { + return 1 if($value && $known_specs{$self->{spec}} eq $value); + if($value && $known_urls{$value}) { + $self->_error( 'META specification URL does not match version' ); + return 0; + } + } + $self->_error( 'Unknown META specification' ); + return 0; + } + + sub anything { return 1 } + + sub string { + my ($self,$key,$value) = @_; + if(defined $value) { + return 1 if($value || $value =~ /^0$/); + } + $self->_error( "value is an undefined string" ); + return 0; + } + + sub string_or_undef { + my ($self,$key,$value) = @_; + return 1 unless(defined $value); + return 1 if($value || $value =~ /^0$/); + $self->_error( "No string defined for '$key'" ); + return 0; + } + + sub file { + my ($self,$key,$value) = @_; + return 1 if(defined $value); + $self->_error( "No file defined for '$key'" ); + return 0; + } + + sub exversion { + my ($self,$key,$value) = @_; + if(defined $value && ($value || $value =~ /0/)) { + my $pass = 1; + for(split(",",$value)) { $self->version($key,$_) or ($pass = 0); } + return $pass; + } + $value = '' unless(defined $value); + $self->_error( "'$value' for '$key' is not a valid version." ); + return 0; + } + + sub version { + my ($self,$key,$value) = @_; + if(defined $value) { + return 0 unless($value || $value =~ /0/); + return 1 if($value =~ /^\s*((<|<=|>=|>|!=|==)\s*)?v?\d+((\.\d+((_|\.)\d+)?)?)/); + } else { + $value = ''; + } + $self->_error( "'$value' for '$key' is not a valid version." ); + return 0; + } + + sub boolean { + my ($self,$key,$value) = @_; + if(defined $value) { + return 1 if($value =~ /^(0|1|true|false)$/); + } else { + $value = ''; + } + $self->_error( "'$value' for '$key' is not a boolean value." ); + return 0; + } + + my %v1_licenses = ( + 'perl' => 'http://dev.perl.org/licenses/', + 'gpl' => 'http://www.opensource.org/licenses/gpl-license.php', + 'apache' => 'http://apache.org/licenses/LICENSE-2.0', + 'artistic' => 'http://opensource.org/licenses/artistic-license.php', + 'artistic_2' => 'http://opensource.org/licenses/artistic-license-2.0.php', + 'lgpl' => 'http://www.opensource.org/licenses/lgpl-license.php', + 'bsd' => 'http://www.opensource.org/licenses/bsd-license.php', + 'gpl' => 'http://www.opensource.org/licenses/gpl-license.php', + 'mit' => 'http://opensource.org/licenses/mit-license.php', + 'mozilla' => 'http://opensource.org/licenses/mozilla1.1.php', + 'open_source' => undef, + 'unrestricted' => undef, + 'restrictive' => undef, + 'unknown' => undef, + ); + + my %v2_licenses = map { $_ => 1 } qw( + agpl_3 + apache_1_1 + apache_2_0 + artistic_1 + artistic_2 + bsd + freebsd + gfdl_1_2 + gfdl_1_3 + gpl_1 + gpl_2 + gpl_3 + lgpl_2_1 + lgpl_3_0 + mit + mozilla_1_0 + mozilla_1_1 + openssl + perl_5 + qpl_1_0 + ssleay + sun + zlib + open_source + restricted + unrestricted + unknown + ); + + sub license { + my ($self,$key,$value) = @_; + my $licenses = $self->{spec} < 2 ? \%v1_licenses : \%v2_licenses; + if(defined $value) { + return 1 if($value && exists $licenses->{$value}); + } else { + $value = ''; + } + $self->_error( "License '$value' is invalid" ); + return 0; + } + + sub custom_1 { + my ($self,$key) = @_; + if(defined $key) { + # a valid user defined key should be alphabetic + # and contain at least one capital case letter. + return 1 if($key && $key =~ /^[_a-z]+$/i && $key =~ /[A-Z]/); + } else { + $key = ''; + } + $self->_error( "Custom resource '$key' must be in CamelCase." ); + return 0; + } + + sub custom_2 { + my ($self,$key) = @_; + if(defined $key) { + return 1 if($key && $key =~ /^x_/i); # user defined + } else { + $key = ''; + } + $self->_error( "Custom key '$key' must begin with 'x_' or 'X_'." ); + return 0; + } + + sub identifier { + my ($self,$key) = @_; + if(defined $key) { + return 1 if($key && $key =~ /^([a-z][_a-z]+)$/i); # spec 2.0 defined + } else { + $key = ''; + } + $self->_error( "Key '$key' is not a legal identifier." ); + return 0; + } + + sub module { + my ($self,$key) = @_; + if(defined $key) { + return 1 if($key && $key =~ /^[A-Za-z0-9_]+(::[A-Za-z0-9_]+)*$/); + } else { + $key = ''; + } + $self->_error( "Key '$key' is not a legal module name." ); + return 0; + } + + my @valid_phases = qw/ configure build test runtime develop /; + sub phase { + my ($self,$key) = @_; + if(defined $key) { + return 1 if( length $key && grep { $key eq $_ } @valid_phases ); + return 1 if $key =~ /x_/i; + } else { + $key = ''; + } + $self->_error( "Key '$key' is not a legal phase." ); + return 0; + } + + my @valid_relations = qw/ requires recommends suggests conflicts /; + sub relation { + my ($self,$key) = @_; + if(defined $key) { + return 1 if( length $key && grep { $key eq $_ } @valid_relations ); + return 1 if $key =~ /x_/i; + } else { + $key = ''; + } + $self->_error( "Key '$key' is not a legal prereq relationship." ); + return 0; + } + + sub _error { + my $self = shift; + my $mess = shift; + + $mess .= ' ('.join(' -> ',@{$self->{stack}}).')' if($self->{stack}); + $mess .= " [Validation: $self->{spec}]"; + + push @{$self->{errors}}, $mess; + } + + 1; + + # ABSTRACT: validate CPAN distribution metadata structures + + __END__ + + =pod + + =encoding UTF-8 + + =head1 NAME + + CPAN::Meta::Validator - validate CPAN distribution metadata structures + + =head1 VERSION + + version 2.143240 + + =head1 SYNOPSIS + + my $struct = decode_json_file('META.json'); + + my $cmv = CPAN::Meta::Validator->new( $struct ); + + unless ( $cmv->is_valid ) { + my $msg = "Invalid META structure. Errors found:\n"; + $msg .= join( "\n", $cmv->errors ); + die $msg; + } + + =head1 DESCRIPTION + + This module validates a CPAN Meta structure against the version of the + the specification claimed in the C field of the structure. + + =head1 METHODS + + =head2 new + + my $cmv = CPAN::Meta::Validator->new( $struct ) + + The constructor must be passed a metadata structure. + + =head2 is_valid + + if ( $cmv->is_valid ) { + ... + } + + Returns a boolean value indicating whether the metadata provided + is valid. + + =head2 errors + + warn( join "\n", $cmv->errors ); + + Returns a list of errors seen during validation. + + =begin :internals + + =head2 Check Methods + + =over + + =item * + + check_map($spec,$data) + + Checks whether a map (or hash) part of the data structure conforms to the + appropriate specification definition. + + =item * + + check_list($spec,$data) + + Checks whether a list (or array) part of the data structure conforms to + the appropriate specification definition. + + =item * + + =back + + =head2 Validator Methods + + =over + + =item * + + header($self,$key,$value) + + Validates that the header is valid. + + Note: No longer used as we now read the data structure, not the file. + + =item * + + url($self,$key,$value) + + Validates that a given value is in an acceptable URL format + + =item * + + urlspec($self,$key,$value) + + Validates that the URL to a META specification is a known one. + + =item * + + string_or_undef($self,$key,$value) + + Validates that the value is either a string or an undef value. Bit of a + catchall function for parts of the data structure that are completely user + defined. + + =item * + + string($self,$key,$value) + + Validates that a string exists for the given key. + + =item * + + file($self,$key,$value) + + Validate that a file is passed for the given key. This may be made more + thorough in the future. For now it acts like \&string. + + =item * + + exversion($self,$key,$value) + + Validates a list of versions, e.g. '<= 5, >=2, ==3, !=4, >1, <6, 0'. + + =item * + + version($self,$key,$value) + + Validates a single version string. Versions of the type '5.8.8' and '0.00_00' + are both valid. A leading 'v' like 'v1.2.3' is also valid. + + =item * + + boolean($self,$key,$value) + + Validates for a boolean value. Currently these values are '1', '0', 'true', + 'false', however the latter 2 may be removed. + + =item * + + license($self,$key,$value) + + Validates that a value is given for the license. Returns 1 if an known license + type, or 2 if a value is given but the license type is not a recommended one. + + =item * + + custom_1($self,$key,$value) + + Validates that the given key is in CamelCase, to indicate a user defined + keyword and only has characters in the class [-_a-zA-Z]. In version 1.X + of the spec, this was only explicitly stated for 'resources'. + + =item * + + custom_2($self,$key,$value) + + Validates that the given key begins with 'x_' or 'X_', to indicate a user + defined keyword and only has characters in the class [-_a-zA-Z] + + =item * + + identifier($self,$key,$value) + + Validates that key is in an acceptable format for the META specification, + for an identifier, i.e. any that matches the regular expression + qr/[a-z][a-z_]/i. + + =item * + + module($self,$key,$value) + + Validates that a given key is in an acceptable module name format, e.g. + 'Test::CPAN::Meta::Version'. + + =back + + =end :internals + + =for Pod::Coverage anything boolean check_list custom_1 custom_2 exversion file + identifier license module phase relation release_status string string_or_undef + url urlspec version header check_map + + =head1 BUGS + + Please report any bugs or feature using the CPAN Request Tracker. + Bugs can be submitted through the web interface at + L + + When submitting a bug or request, please include a test-file or a patch to an + existing test-file that illustrates the bug or desired feature. + + =head1 AUTHORS + + =over 4 + + =item * + + David Golden + + =item * + + Ricardo Signes + + =back + + =head1 COPYRIGHT AND LICENSE + + This software is copyright (c) 2010 by David Golden and Ricardo Signes. + + This is free software; you can redistribute it and/or modify it under + the same terms as the Perl 5 programming language system itself. + + =cut +CPAN_META_VALIDATOR + +$fatpacked{"CPAN/Meta/YAML.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_YAML'; + use 5.008001; # sane UTF-8 support + use strict; + use warnings; + package CPAN::Meta::YAML; + $CPAN::Meta::YAML::VERSION = '0.011'; + BEGIN { + $CPAN::Meta::YAML::AUTHORITY = 'cpan:ADAMK'; + } + # git description: v1.59-TRIAL-1-g33d9cd2 + ; # original $VERSION removed by Doppelgaenger + # XXX-INGY is 5.8.1 too old/broken for utf8? + # XXX-XDG Lancaster consensus was that it was sufficient until + # proven otherwise + + + ##################################################################### + # The CPAN::Meta::YAML API. + # + # These are the currently documented API functions/methods and + # exports: + + use Exporter; + our @ISA = qw{ Exporter }; + our @EXPORT = qw{ Load Dump }; + our @EXPORT_OK = qw{ LoadFile DumpFile freeze thaw }; + + ### + # Functional/Export API: + + sub Dump { + return CPAN::Meta::YAML->new(@_)->_dump_string; + } + + # XXX-INGY Returning last document seems a bad behavior. + # XXX-XDG I think first would seem more natural, but I don't know + # that it's worth changing now + sub Load { + my $self = CPAN::Meta::YAML->_load_string(@_); + if ( wantarray ) { + return @$self; + } else { + # To match YAML.pm, return the last document + return $self->[-1]; + } + } + + # XXX-INGY Do we really need freeze and thaw? + # XXX-XDG I don't think so. I'd support deprecating them. + BEGIN { + *freeze = \&Dump; + *thaw = \&Load; + } + + sub DumpFile { + my $file = shift; + return CPAN::Meta::YAML->new(@_)->_dump_file($file); + } + + sub LoadFile { + my $file = shift; + my $self = CPAN::Meta::YAML->_load_file($file); + if ( wantarray ) { + return @$self; + } else { + # Return only the last document to match YAML.pm, + return $self->[-1]; + } + } + + + ### + # Object Oriented API: + + # Create an empty CPAN::Meta::YAML object + # XXX-INGY Why do we use ARRAY object? + # NOTE: I get it now, but I think it's confusing and not needed. + # Will change it on a branch later, for review. + # + # XXX-XDG I don't support changing it yet. It's a very well-documented + # "API" of CPAN::Meta::YAML. I'd support deprecating it, but Adam suggested + # we not change it until YAML.pm's own OO API is established so that + # users only have one API change to digest, not two + sub new { + my $class = shift; + bless [ @_ ], $class; + } + + # XXX-INGY It probably doesn't matter, and it's probably too late to + # change, but 'read/write' are the wrong names. Read and Write + # are actions that take data from storage to memory + # characters/strings. These take the data to/from storage to native + # Perl objects, which the terms dump and load are meant. As long as + # this is a legacy quirk to CPAN::Meta::YAML it's ok, but I'd prefer not + # to add new {read,write}_* methods to this API. + + sub read_string { + my $self = shift; + $self->_load_string(@_); + } + + sub write_string { + my $self = shift; + $self->_dump_string(@_); + } + + sub read { + my $self = shift; + $self->_load_file(@_); + } + + sub write { + my $self = shift; + $self->_dump_file(@_); + } + + + + + ##################################################################### + # Constants + + # Printed form of the unprintable characters in the lowest range + # of ASCII characters, listed by ASCII ordinal position. + my @UNPRINTABLE = qw( + 0 x01 x02 x03 x04 x05 x06 a + b t n v f r x0E x0F + x10 x11 x12 x13 x14 x15 x16 x17 + x18 x19 x1A e x1C x1D x1E x1F + ); + + # Printable characters for escapes + my %UNESCAPES = ( + 0 => "\x00", z => "\x00", N => "\x85", + a => "\x07", b => "\x08", t => "\x09", + n => "\x0a", v => "\x0b", f => "\x0c", + r => "\x0d", e => "\x1b", '\\' => '\\', + ); + + # XXX-INGY + # I(ngy) need to decide if these values should be quoted in + # CPAN::Meta::YAML or not. Probably yes. + + # These 3 values have special meaning when unquoted and using the + # default YAML schema. They need quotes if they are strings. + my %QUOTE = map { $_ => 1 } qw{ + null true false + }; + + # The commented out form is simpler, but overloaded the Perl regex + # engine due to recursion and backtracking problems on strings + # larger than 32,000ish characters. Keep it for reference purposes. + # qr/\"((?:\\.|[^\"])*)\"/ + my $re_capture_double_quoted = qr/\"([^\\"]*(?:\\.[^\\"]*)*)\"/; + my $re_capture_single_quoted = qr/\'([^\']*(?:\'\'[^\']*)*)\'/; + # unquoted re gets trailing space that needs to be stripped + my $re_capture_unquoted_key = qr/([^:]+(?::+\S[^:]*)*)(?=\s*\:(?:\s+|$))/; + my $re_trailing_comment = qr/(?:\s+\#.*)?/; + my $re_key_value_separator = qr/\s*:(?:\s+(?:\#.*)?|$)/; + + + + + + ##################################################################### + # CPAN::Meta::YAML Implementation. + # + # These are the private methods that do all the work. They may change + # at any time. + + + ### + # Loader functions: + + # Create an object from a file + sub _load_file { + my $class = ref $_[0] ? ref shift : shift; + + # Check the file + my $file = shift or $class->_error( 'You did not specify a file name' ); + $class->_error( "File '$file' does not exist" ) + unless -e $file; + $class->_error( "'$file' is a directory, not a file" ) + unless -f _; + $class->_error( "Insufficient permissions to read '$file'" ) + unless -r _; + + # Open unbuffered with strict UTF-8 decoding and no translation layers + open( my $fh, "<:unix:encoding(UTF-8)", $file ); + unless ( $fh ) { + $class->_error("Failed to open file '$file': $!"); + } + + # flock if available (or warn if not possible for OS-specific reasons) + if ( _can_flock() ) { + flock( $fh, Fcntl::LOCK_SH() ) + or warn "Couldn't lock '$file' for reading: $!"; + } + + # slurp the contents + my $contents = eval { + use warnings FATAL => 'utf8'; + local $/; + <$fh> + }; + if ( my $err = $@ ) { + $class->_error("Error reading from file '$file': $err"); + } + + # close the file (release the lock) + unless ( close $fh ) { + $class->_error("Failed to close file '$file': $!"); + } + + $class->_load_string( $contents ); + } + + # Create an object from a string + sub _load_string { + my $class = ref $_[0] ? ref shift : shift; + my $self = bless [], $class; + my $string = $_[0]; + eval { + unless ( defined $string ) { + die \"Did not provide a string to load"; + } + + # Check if Perl has it marked as characters, but it's internally + # inconsistent. E.g. maybe latin1 got read on a :utf8 layer + if ( utf8::is_utf8($string) && ! utf8::valid($string) ) { + die \<<'...'; + Read an invalid UTF-8 string (maybe mixed UTF-8 and 8-bit character set). + Did you decode with lax ":utf8" instead of strict ":encoding(UTF-8)"? + ... + } + + # Ensure Unicode character semantics, even for 0x80-0xff + utf8::upgrade($string); + + # Check for and strip any leading UTF-8 BOM + $string =~ s/^\x{FEFF}//; + + # Check for some special cases + return $self unless length $string; + + # Split the file into lines + my @lines = grep { ! /^\s*(?:\#.*)?\z/ } + split /(?:\015{1,2}\012|\015|\012)/, $string; + + # Strip the initial YAML header + @lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines; + + # A nibbling parser + my $in_document = 0; + while ( @lines ) { + # Do we have a document header? + if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) { + # Handle scalar documents + shift @lines; + if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) { + push @$self, + $self->_load_scalar( "$1", [ undef ], \@lines ); + next; + } + $in_document = 1; + } + + if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) { + # A naked document + push @$self, undef; + while ( @lines and $lines[0] !~ /^---/ ) { + shift @lines; + } + $in_document = 0; + + # XXX The final '-+$' is to look for -- which ends up being an + # error later. + } elsif ( ! $in_document && @$self ) { + # only the first document can be explicit + die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'"; + } elsif ( $lines[0] =~ /^\s*\-(?:\s|$|-+$)/ ) { + # An array at the root + my $document = [ ]; + push @$self, $document; + $self->_load_array( $document, [ 0 ], \@lines ); + + } elsif ( $lines[0] =~ /^(\s*)\S/ ) { + # A hash at the root + my $document = { }; + push @$self, $document; + $self->_load_hash( $document, [ length($1) ], \@lines ); + + } else { + # Shouldn't get here. @lines have whitespace-only lines + # stripped, and previous match is a line with any + # non-whitespace. So this clause should only be reachable via + # a perlbug where \s is not symmetric with \S + + # uncoverable statement + die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'"; + } + } + }; + if ( ref $@ eq 'SCALAR' ) { + $self->_error(${$@}); + } elsif ( $@ ) { + $self->_error($@); + } + + return $self; + } + + sub _unquote_single { + my ($self, $string) = @_; + return '' unless length $string; + $string =~ s/\'\'/\'/g; + return $string; + } + + sub _unquote_double { + my ($self, $string) = @_; + return '' unless length $string; + $string =~ s/\\"/"/g; + $string =~ + s{\\([Nnever\\fartz0b]|x([0-9a-fA-F]{2}))} + {(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}}gex; + return $string; + } + + # Load a YAML scalar string to the actual Perl scalar + sub _load_scalar { + my ($self, $string, $indent, $lines) = @_; + + # Trim trailing whitespace + $string =~ s/\s*\z//; + + # Explitic null/undef + return undef if $string eq '~'; + + # Single quote + if ( $string =~ /^$re_capture_single_quoted$re_trailing_comment\z/ ) { + return $self->_unquote_single($1); + } + + # Double quote. + if ( $string =~ /^$re_capture_double_quoted$re_trailing_comment\z/ ) { + return $self->_unquote_double($1); + } + + # Special cases + if ( $string =~ /^[\'\"!&]/ ) { + die \"CPAN::Meta::YAML does not support a feature in line '$string'"; + } + return {} if $string =~ /^{}(?:\s+\#.*)?\z/; + return [] if $string =~ /^\[\](?:\s+\#.*)?\z/; + + # Regular unquoted string + if ( $string !~ /^[>|]/ ) { + die \"CPAN::Meta::YAML found illegal characters in plain scalar: '$string'" + if $string =~ /^(?:-(?:\s|$)|[\@\%\`])/ or + $string =~ /:(?:\s|$)/; + $string =~ s/\s+#.*\z//; + return $string; + } + + # Error + die \"CPAN::Meta::YAML failed to find multi-line scalar content" unless @$lines; + + # Check the indent depth + $lines->[0] =~ /^(\s*)/; + $indent->[-1] = length("$1"); + if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) { + die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'"; + } + + # Pull the lines + my @multiline = (); + while ( @$lines ) { + $lines->[0] =~ /^(\s*)/; + last unless length($1) >= $indent->[-1]; + push @multiline, substr(shift(@$lines), length($1)); + } + + my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n"; + my $t = (substr($string, 1, 1) eq '-') ? '' : "\n"; + return join( $j, @multiline ) . $t; + } + + # Load an array + sub _load_array { + my ($self, $array, $indent, $lines) = @_; + + while ( @$lines ) { + # Check for a new document + if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) { + while ( @$lines and $lines->[0] !~ /^---/ ) { + shift @$lines; + } + return 1; + } + + # Check the indent level + $lines->[0] =~ /^(\s*)/; + if ( length($1) < $indent->[-1] ) { + return 1; + } elsif ( length($1) > $indent->[-1] ) { + die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'"; + } + + if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) { + # Inline nested hash + my $indent2 = length("$1"); + $lines->[0] =~ s/-/ /; + push @$array, { }; + $self->_load_hash( $array->[-1], [ @$indent, $indent2 ], $lines ); + + } elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) { + shift @$lines; + unless ( @$lines ) { + push @$array, undef; + return 1; + } + if ( $lines->[0] =~ /^(\s*)\-/ ) { + my $indent2 = length("$1"); + if ( $indent->[-1] == $indent2 ) { + # Null array entry + push @$array, undef; + } else { + # Naked indenter + push @$array, [ ]; + $self->_load_array( + $array->[-1], [ @$indent, $indent2 ], $lines + ); + } + + } elsif ( $lines->[0] =~ /^(\s*)\S/ ) { + push @$array, { }; + $self->_load_hash( + $array->[-1], [ @$indent, length("$1") ], $lines + ); + + } else { + die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'"; + } + + } elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) { + # Array entry with a value + shift @$lines; + push @$array, $self->_load_scalar( + "$2", [ @$indent, undef ], $lines + ); + + } elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) { + # This is probably a structure like the following... + # --- + # foo: + # - list + # bar: value + # + # ... so lets return and let the hash parser handle it + return 1; + + } else { + die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'"; + } + } + + return 1; + } + + # Load a hash + sub _load_hash { + my ($self, $hash, $indent, $lines) = @_; + + while ( @$lines ) { + # Check for a new document + if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) { + while ( @$lines and $lines->[0] !~ /^---/ ) { + shift @$lines; + } + return 1; + } + + # Check the indent level + $lines->[0] =~ /^(\s*)/; + if ( length($1) < $indent->[-1] ) { + return 1; + } elsif ( length($1) > $indent->[-1] ) { + die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'"; + } + + # Find the key + my $key; + + # Quoted keys + if ( $lines->[0] =~ + s/^\s*$re_capture_single_quoted$re_key_value_separator// + ) { + $key = $self->_unquote_single($1); + } + elsif ( $lines->[0] =~ + s/^\s*$re_capture_double_quoted$re_key_value_separator// + ) { + $key = $self->_unquote_double($1); + } + elsif ( $lines->[0] =~ + s/^\s*$re_capture_unquoted_key$re_key_value_separator// + ) { + $key = $1; + $key =~ s/\s+$//; + } + elsif ( $lines->[0] =~ /^\s*\?/ ) { + die \"CPAN::Meta::YAML does not support a feature in line '$lines->[0]'"; + } + else { + die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'"; + } + + # Do we have a value? + if ( length $lines->[0] ) { + # Yes + $hash->{$key} = $self->_load_scalar( + shift(@$lines), [ @$indent, undef ], $lines + ); + } else { + # An indent + shift @$lines; + unless ( @$lines ) { + $hash->{$key} = undef; + return 1; + } + if ( $lines->[0] =~ /^(\s*)-/ ) { + $hash->{$key} = []; + $self->_load_array( + $hash->{$key}, [ @$indent, length($1) ], $lines + ); + } elsif ( $lines->[0] =~ /^(\s*)./ ) { + my $indent2 = length("$1"); + if ( $indent->[-1] >= $indent2 ) { + # Null hash entry + $hash->{$key} = undef; + } else { + $hash->{$key} = {}; + $self->_load_hash( + $hash->{$key}, [ @$indent, length($1) ], $lines + ); + } + } + } + } + + return 1; + } + + + ### + # Dumper functions: + + # Save an object to a file + sub _dump_file { + my $self = shift; + + require Fcntl; + + # Check the file + my $file = shift or $self->_error( 'You did not specify a file name' ); + + my $fh; + # flock if available (or warn if not possible for OS-specific reasons) + if ( _can_flock() ) { + # Open without truncation (truncate comes after lock) + my $flags = Fcntl::O_WRONLY()|Fcntl::O_CREAT(); + sysopen( $fh, $file, $flags ); + unless ( $fh ) { + $self->_error("Failed to open file '$file' for writing: $!"); + } + + # Use no translation and strict UTF-8 + binmode( $fh, ":raw:encoding(UTF-8)"); + + flock( $fh, Fcntl::LOCK_EX() ) + or warn "Couldn't lock '$file' for reading: $!"; + + # truncate and spew contents + truncate $fh, 0; + seek $fh, 0, 0; + } + else { + open $fh, ">:unix:encoding(UTF-8)", $file; + } + + # serialize and spew to the handle + print {$fh} $self->_dump_string; + + # close the file (release the lock) + unless ( close $fh ) { + $self->_error("Failed to close file '$file': $!"); + } + + return 1; + } + + # Save an object to a string + sub _dump_string { + my $self = shift; + return '' unless ref $self && @$self; + + # Iterate over the documents + my $indent = 0; + my @lines = (); + + eval { + foreach my $cursor ( @$self ) { + push @lines, '---'; + + # An empty document + if ( ! defined $cursor ) { + # Do nothing + + # A scalar document + } elsif ( ! ref $cursor ) { + $lines[-1] .= ' ' . $self->_dump_scalar( $cursor ); + + # A list at the root + } elsif ( ref $cursor eq 'ARRAY' ) { + unless ( @$cursor ) { + $lines[-1] .= ' []'; + next; + } + push @lines, $self->_dump_array( $cursor, $indent, {} ); + + # A hash at the root + } elsif ( ref $cursor eq 'HASH' ) { + unless ( %$cursor ) { + $lines[-1] .= ' {}'; + next; + } + push @lines, $self->_dump_hash( $cursor, $indent, {} ); + + } else { + die \("Cannot serialize " . ref($cursor)); + } + } + }; + if ( ref $@ eq 'SCALAR' ) { + $self->_error(${$@}); + } elsif ( $@ ) { + $self->_error($@); + } + + join '', map { "$_\n" } @lines; + } + + sub _has_internal_string_value { + my $value = shift; + my $b_obj = B::svref_2object(\$value); # for round trip problem + return $b_obj->FLAGS & B::SVf_POK(); + } + + sub _dump_scalar { + my $string = $_[1]; + my $is_key = $_[2]; + # Check this before checking length or it winds up looking like a string! + my $has_string_flag = _has_internal_string_value($string); + return '~' unless defined $string; + return "''" unless length $string; + if (Scalar::Util::looks_like_number($string)) { + # keys and values that have been used as strings get quoted + if ( $is_key || $has_string_flag ) { + return qq['$string']; + } + else { + return $string; + } + } + if ( $string =~ /[\x00-\x09\x0b-\x0d\x0e-\x1f\x7f-\x9f\'\n]/ ) { + $string =~ s/\\/\\\\/g; + $string =~ s/"/\\"/g; + $string =~ s/\n/\\n/g; + $string =~ s/[\x85]/\\N/g; + $string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g; + $string =~ s/([\x7f-\x9f])/'\x' . sprintf("%X",ord($1))/ge; + return qq|"$string"|; + } + if ( $string =~ /(?:^[~!@#%&*|>?:,'"`{}\[\]]|^-+$|\s|:\z)/ or + $QUOTE{$string} + ) { + return "'$string'"; + } + return $string; + } + + sub _dump_array { + my ($self, $array, $indent, $seen) = @_; + if ( $seen->{refaddr($array)}++ ) { + die \"CPAN::Meta::YAML does not support circular references"; + } + my @lines = (); + foreach my $el ( @$array ) { + my $line = (' ' x $indent) . '-'; + my $type = ref $el; + if ( ! $type ) { + $line .= ' ' . $self->_dump_scalar( $el ); + push @lines, $line; + + } elsif ( $type eq 'ARRAY' ) { + if ( @$el ) { + push @lines, $line; + push @lines, $self->_dump_array( $el, $indent + 1, $seen ); + } else { + $line .= ' []'; + push @lines, $line; + } + + } elsif ( $type eq 'HASH' ) { + if ( keys %$el ) { + push @lines, $line; + push @lines, $self->_dump_hash( $el, $indent + 1, $seen ); + } else { + $line .= ' {}'; + push @lines, $line; + } + + } else { + die \"CPAN::Meta::YAML does not support $type references"; + } + } + + @lines; + } + + sub _dump_hash { + my ($self, $hash, $indent, $seen) = @_; + if ( $seen->{refaddr($hash)}++ ) { + die \"CPAN::Meta::YAML does not support circular references"; + } + my @lines = (); + foreach my $name ( sort keys %$hash ) { + my $el = $hash->{$name}; + my $line = (' ' x $indent) . $self->_dump_scalar($name, 1) . ":"; + my $type = ref $el; + if ( ! $type ) { + $line .= ' ' . $self->_dump_scalar( $el ); + push @lines, $line; + + } elsif ( $type eq 'ARRAY' ) { + if ( @$el ) { + push @lines, $line; + push @lines, $self->_dump_array( $el, $indent + 1, $seen ); + } else { + $line .= ' []'; + push @lines, $line; + } + + } elsif ( $type eq 'HASH' ) { + if ( keys %$el ) { + push @lines, $line; + push @lines, $self->_dump_hash( $el, $indent + 1, $seen ); + } else { + $line .= ' {}'; + push @lines, $line; + } + + } else { + die \"CPAN::Meta::YAML does not support $type references"; + } + } + + @lines; + } + + + + ##################################################################### + # DEPRECATED API methods: + + # Error storage (DEPRECATED as of 1.57) + our $errstr = ''; + + # Set error + sub _error { + require Carp; + $errstr = $_[1]; + $errstr =~ s/ at \S+ line \d+.*//; + Carp::croak( $errstr ); + } + + # Retrieve error + my $errstr_warned; + sub errstr { + require Carp; + Carp::carp( "CPAN::Meta::YAML->errstr and \$CPAN::Meta::YAML::errstr is deprecated" ) + unless $errstr_warned++; + $errstr; + } + + + + + ##################################################################### + # Helper functions. Possibly not needed. + + + # Use to detect nv or iv + use B; + + # XXX-INGY Is flock CPAN::Meta::YAML's responsibility? + # Some platforms can't flock :-( + # XXX-XDG I think it is. When reading and writing files, we ought + # to be locking whenever possible. People (foolishly) use YAML + # files for things like session storage, which has race issues. + my $HAS_FLOCK; + sub _can_flock { + if ( defined $HAS_FLOCK ) { + return $HAS_FLOCK; + } + else { + require Config; + my $c = \%Config::Config; + $HAS_FLOCK = grep { $c->{$_} } qw/d_flock d_fcntl_can_lock d_lockf/; + require Fcntl if $HAS_FLOCK; + return $HAS_FLOCK; + } + } + + + # XXX-INGY Is this core in 5.8.1? Can we remove this? + # XXX-XDG Scalar::Util 1.18 didn't land until 5.8.8, so we need this + ##################################################################### + # Use Scalar::Util if possible, otherwise emulate it + + BEGIN { + local $@; + if ( eval { require Scalar::Util } + && $Scalar::Util::VERSION + && eval($Scalar::Util::VERSION) >= 1.18 + ) { + *refaddr = *Scalar::Util::refaddr; + } + else { + eval <<'END_PERL'; + # Scalar::Util failed to load or too old + sub refaddr { + my $pkg = ref($_[0]) or return undef; + if ( !! UNIVERSAL::can($_[0], 'can') ) { + bless $_[0], 'Scalar::Util::Fake'; + } else { + $pkg = undef; + } + "$_[0]" =~ /0x(\w+)/; + my $i = do { no warnings 'portable'; hex $1 }; + bless $_[0], $pkg if defined $pkg; + $i; + } + END_PERL + } + } + + + + + 1; + + # XXX-INGY Doc notes I'm putting up here. Changing the doc when it's wrong + # but leaving grey area stuff up here. + # + # I would like to change Read/Write to Load/Dump below without + # changing the actual API names. + # + # It might be better to put Load/Dump API in the SYNOPSIS instead of the + # dubious OO API. + # + # null and bool explanations may be outdated. + + =pod + + =encoding UTF-8 + + =head1 NAME + + CPAN::Meta::YAML - Read and write a subset of YAML for CPAN Meta files + + =head1 VERSION + + version 0.011 + + =head1 SYNOPSIS + + use CPAN::Meta::YAML; + + # reading a META file + open $fh, "<:utf8", "META.yml"; + $yaml_text = do { local $/; <$fh> }; + $yaml = CPAN::Meta::YAML->read_string($yaml_text) + or die CPAN::Meta::YAML->errstr; + + # finding the metadata + $meta = $yaml->[0]; + + # writing a META file + $yaml_text = $yaml->write_string + or die CPAN::Meta::YAML->errstr; + open $fh, ">:utf8", "META.yml"; + print $fh $yaml_text; + + =head1 DESCRIPTION + + This module implements a subset of the YAML specification for use in reading + and writing CPAN metadata files like F and F. It should + not be used for any other general YAML parsing or generation task. + + NOTE: F (and F) files should be UTF-8 encoded. Users are + responsible for proper encoding and decoding. In particular, the C and + C methods do B support UTF-8 and should not be used. + + =head1 SUPPORT + + This module is currently derived from L by Adam Kennedy. If + there are bugs in how it parses a particular META.yml file, please file + a bug report in the YAML::Tiny bugtracker: + L + + =head1 SEE ALSO + + L, L, L + + =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan + + =head1 SUPPORT + + =head2 Bugs / Feature Requests + + Please report any bugs or feature requests through the issue tracker + at L. + You will be notified automatically of any progress on your issue. + + =head2 Source Code + + This is open source software. The code repository is available for + public review and contribution under the terms of the license. + + L + + git clone https://github.com/dagolden/CPAN-Meta-YAML.git + + =head1 AUTHORS + + =over 4 + + =item * + + Adam Kennedy + + =item * + + David Golden + + =back + + =head1 COPYRIGHT AND LICENSE + + This software is copyright (c) 2010 by Adam Kennedy. + + This is free software; you can redistribute it and/or modify it under + the same terms as the Perl 5 programming language system itself. + + =cut + + __END__ + + + # ABSTRACT: Read and write a subset of YAML for CPAN Meta files + + +CPAN_META_YAML + +$fatpacked{"Carton.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON'; + package Carton; + use strict; + use 5.008_005; + use version; our $VERSION = version->declare("v1.0.22"); + + 1; + __END__ + + =head1 NAME + + Carton - Perl module dependency manager (aka Bundler for Perl) + + =head1 SYNOPSIS + + # On your development environment + > cat cpanfile + requires 'Plack', '0.9980'; + requires 'Starman', '0.2000'; + + > carton install + > git add cpanfile cpanfile.snapshot + > git commit -m "add Plack and Starman" + + # Other developer's machine, or on a deployment box + > carton install + > carton exec starman -p 8080 myapp.psgi + + =head1 AVAILABILITY + + Carton only works with perl installation with the complete set of core + modules. If you use perl installed by a vendor package with modules + stripped from core, Carton is not expected to work correctly. + + Also, Carton requires you to run your command/application with + C command, which means it's difficult or impossible to + run in an embedded perl use case such as mod_perl. + + =head1 DESCRIPTION + + carton is a command line tool to track the Perl module dependencies + for your Perl application. Dependencies are declared using L + format, and the managed dependencies are tracked in a + I file, which is meant to be version controlled, + and the snapshot file allows other developers of your application will + have the exact same versions of the modules. + + For C syntax, see L documentation. + + =head1 TUTORIAL + + =head2 Initializing the environment + + carton will use the I directory to install modules into. You're + recommended to exclude these directories from the version control + system. + + > echo local/ >> .gitignore + > git add cpanfile cpanfile.snapshot + > git commit -m "Start using carton" + + =head2 Tracking the dependencies + + You can manage the dependencies of your application via C. + + # cpanfile + requires 'Plack', '0.9980'; + requires 'Starman', '0.2000'; + + And then you can install these dependencies via: + + > carton install + + The modules are installed into your I directory, and the + dependencies tree and version information are analyzed and saved into + I in your directory. + + Make sure you add I and I to your version + controlled repository and commit changes as you update + dependencies. This will ensure that other developers on your app, as + well as your deployment environment, use exactly the same versions of + the modules you just installed. + + > git add cpanfile cpanfile.snapshot + > git commit -m "Added Plack and Starman" + + =head2 Deploying your application + + Once you've done installing all the dependencies, you can push your + application directory to a remote machine (excluding I and + I<.carton>) and run the following command: + + > carton install --deployment + + This will look at the I and install the exact same + versions of the dependencies into I, and now your application + is ready to run. + + The C<--deployment> flag makes sure that carton will only install + modules and versions available in your snapshot, and won't fallback to + query for CPAN Meta DB for missing modules. + + =head2 Bundling modules + + carton can bundle all the tarballs for your dependencies into a + directory so that you can even install dependencies that are not + available on CPAN, such as internal distribution aka DarkPAN. + + > carton bundle + + will bundle these tarballs into I directory, and + + > carton install --cached + + will install modules using this local cache. Combined with + C<--deployment> option, you can avoid querying for a database like + CPAN Meta DB or downloading files from CPAN mirrors upon deployment + time. + + =head1 PERL VERSIONS + + When you take a snapshot in one perl version and deploy on another + (different) version, you might have troubles with core modules. + + The simplest solution, which might not work for everybody, is to use + the same version of perl in the development and deployment. + + To enforce that, you're recommended to use L and + C<.perl-version> to lock perl versions in development. + + You can also specify the minimum perl required in C: + + requires 'perl', '5.16.3'; + + and carton (and cpanm) will give you errors when deployed on hosts + with perl lower than the specified version. + + =head1 COMMUNITY + + =over 4 + + =item L + + Code repository, Wiki and Issue Tracker + + =item L + + IRC chat room + + =back + + =head1 AUTHOR + + Tatsuhiko Miyagawa + + =head1 COPYRIGHT + + Tatsuhiko Miyagawa 2011- + + =head1 LICENSE + + This software is licensed under the same terms as Perl itself. + + =head1 SEE ALSO + + L + + L + + L + + L + + L + + L + + L + + =cut +CARTON + +$fatpacked{"Carton/Builder.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON_BUILDER'; + package Carton::Builder; + use strict; + use Class::Tiny { + mirror => undef, + index => undef, + cascade => sub { 1 }, + without => sub { [] }, + cpanfile => undef, + fatscript => sub { $_[0]->_build_fatscript }, + }; + + sub effective_mirrors { + my $self = shift; + + # push default CPAN mirror always, as a fallback + # TODO don't pass fallback if --cached is set? + + my @mirrors = ($self->mirror); + push @mirrors, Carton::Mirror->default if $self->custom_mirror; + push @mirrors, Carton::Mirror->new('http://backpan.perl.org/'); + + @mirrors; + } + + sub custom_mirror { + my $self = shift; + ! $self->mirror->is_default; + } + + sub bundle { + my($self, $path, $cache_path, $snapshot) = @_; + + for my $dist ($snapshot->distributions) { + my $source = $path->child("cache/authors/id/" . $dist->pathname); + my $target = $cache_path->child("authors/id/" . $dist->pathname); + + if ($source->exists) { + warn "Copying ", $dist->pathname, "\n"; + $target->parent->mkpath; + $source->copy($target) or warn "$target: $!"; + } else { + warn "Couldn't find @{[ $dist->pathname ]}\n"; + } + } + } + + sub install { + my($self, $path) = @_; + + $self->run_cpanm( + "-L", $path, + (map { ("--mirror", $_->url) } $self->effective_mirrors), + ( $self->index ? ("--mirror-index", $self->index) : () ), + ( $self->cascade ? "--cascade-search" : () ), + ( $self->custom_mirror ? "--mirror-only" : () ), + "--save-dists", "$path/cache", + $self->groups, + "--cpanfile", $self->cpanfile, + "--installdeps", $self->cpanfile->dirname, + ) or die "Installing modules failed\n"; + } + + sub groups { + my $self = shift; + + # TODO support --without test (don't need test on deployment) + my @options = ('--with-all-features', '--with-develop'); + + for my $group (@{$self->without}) { + push @options, '--without-develop' if $group eq 'develop'; + push @options, "--without-feature=$group"; + } + + return @options; + } + + sub update { + my($self, $path, @modules) = @_; + + $self->run_cpanm( + "-L", $path, + (map { ("--mirror", $_->url) } $self->effective_mirrors), + ( $self->custom_mirror ? "--mirror-only" : () ), + "--save-dists", "$path/cache", + @modules + ) or die "Updating modules failed\n"; + } + + sub _build_fatscript { + my $self = shift; + + my $fatscript; + if ($Carton::Fatpacked) { + require Module::Reader; + my $content = Module::Reader::module_content('App::cpanminus::fatscript') + or die "Can't locate App::cpanminus::fatscript"; + $fatscript = Path::Tiny->tempfile; + $fatscript->spew($content); + } else { + require Module::Metadata; + $fatscript = Module::Metadata->find_module_by_name("App::cpanminus::fatscript") + or die "Can't locate App::cpanminus::fatscript"; + } + + return $fatscript; + } + + sub run_cpanm { + my($self, @args) = @_; + local $ENV{PERL_CPANM_OPT}; + !system $^X, $self->fatscript, "--quiet", "--notest", @args; + } + + 1; +CARTON_BUILDER + +$fatpacked{"Carton/CLI.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON_CLI'; + package Carton::CLI; + use strict; + use warnings; + use Config; + use Getopt::Long; + use Path::Tiny; + use Try::Tiny; + use Module::CoreList; + use Scalar::Util qw(blessed); + + use Carton; + use Carton::Builder; + use Carton::Mirror; + use Carton::Snapshot; + use Carton::Util; + use Carton::Environment; + use Carton::Error; + + use constant { SUCCESS => 0, INFO => 1, WARN => 2, ERROR => 3 }; + + our $UseSystem = 0; # 1 for unit testing + + use Class::Tiny { + verbose => undef, + carton => sub { $_[0]->_build_carton }, + mirror => sub { $_[0]->_build_mirror }, + }; + + sub _build_mirror { + my $self = shift; + Carton::Mirror->new($ENV{PERL_CARTON_MIRROR} || $Carton::Mirror::DefaultMirror); + } + + sub run { + my($self, @args) = @_; + + my @commands; + my $p = Getopt::Long::Parser->new( + config => [ "no_ignore_case", "pass_through" ], + ); + $p->getoptionsfromarray( + \@args, + "h|help" => sub { unshift @commands, 'help' }, + "v|version" => sub { unshift @commands, 'version' }, + "verbose!" => sub { $self->verbose($_[1]) }, + ); + + push @commands, @args; + + my $cmd = shift @commands || 'install'; + + my $code = try { + my $call = $self->can("cmd_$cmd") + or Carton::Error::CommandNotFound->throw(error => "Could not find command '$cmd'"); + $self->$call(@commands); + return 0; + } catch { + die $_ unless blessed $_ && $_->can('rethrow'); + + if ($_->isa('Carton::Error::CommandExit')) { + return $_->code || 255; + } elsif ($_->isa('Carton::Error::CommandNotFound')) { + warn $_->error, "\n\n"; + $self->cmd_usage; + return 255; + } elsif ($_->isa('Carton::Error')) { + warn $_->error, "\n"; + return 255; + } + }; + + return $code; + } + + sub commands { + my $self = shift; + + no strict 'refs'; + map { s/^cmd_//; $_ } + grep { /^cmd_.*/ && $self->can($_) } sort keys %{__PACKAGE__."::"}; + } + + sub cmd_usage { + my $self = shift; + $self->print(< + + where is one of: + @{[ join ", ", $self->commands ]} + + Run carton -h for help. + HELP + } + + sub parse_options { + my($self, $args, @spec) = @_; + my $p = Getopt::Long::Parser->new( + config => [ "no_auto_abbrev", "no_ignore_case" ], + ); + $p->getoptionsfromarray($args, @spec); + } + + sub parse_options_pass_through { + my($self, $args, @spec) = @_; + + my $p = Getopt::Long::Parser->new( + config => [ "no_auto_abbrev", "no_ignore_case", "pass_through" ], + ); + $p->getoptionsfromarray($args, @spec); + + # with pass_through keeps -- in args + shift @$args if $args->[0] && $args->[0] eq '--'; + } + + sub printf { + my $self = shift; + my $type = pop; + my($temp, @args) = @_; + $self->print(sprintf($temp, @args), $type); + } + + sub print { + my($self, $msg, $type) = @_; + my $fh = $type && $type >= WARN ? *STDERR : *STDOUT; + print {$fh} $msg; + } + + sub error { + my($self, $msg) = @_; + $self->print($msg, ERROR); + Carton::Error::CommandExit->throw; + } + + sub cmd_help { + my $self = shift; + my $module = $_[0] ? ("Carton::Doc::" . ucfirst $_[0]) : "Carton.pm"; + system "perldoc", $module; + } + + sub cmd_version { + my $self = shift; + $self->print("carton $Carton::VERSION\n"); + } + + sub cmd_bundle { + my($self, @args) = @_; + + my $env = Carton::Environment->build; + $env->snapshot->load; + + $self->print("Bundling modules using @{[$env->cpanfile]}\n"); + + my $builder = Carton::Builder->new( + mirror => $self->mirror, + cpanfile => $env->cpanfile, + ); + $builder->bundle($env->install_path, $env->vendor_cache, $env->snapshot); + + $self->printf("Complete! Modules were bundled into %s\n", $env->vendor_cache, SUCCESS); + } + + sub cmd_fatpack { + my($self, @args) = @_; + + my $env = Carton::Environment->build; + require Carton::Packer; + Carton::Packer->new->fatpack_carton($env->vendor_bin); + } + + sub cmd_install { + my($self, @args) = @_; + + my($install_path, $cpanfile_path, @without); + + $self->parse_options( + \@args, + "p|path=s" => \$install_path, + "cpanfile=s" => \$cpanfile_path, + "without=s" => sub { push @without, split /,/, $_[1] }, + "deployment!" => \my $deployment, + "cached!" => \my $cached, + ); + + my $env = Carton::Environment->build($cpanfile_path, $install_path); + $env->snapshot->load_if_exists; + + if ($deployment && !$env->snapshot->loaded) { + $self->error("--deployment requires cpanfile.snapshot: Run `carton install` and make sure cpanfile.snapshot is checked into your version control.\n"); + } + + my $builder = Carton::Builder->new( + cascade => 1, + mirror => $self->mirror, + without => \@without, + cpanfile => $env->cpanfile, + ); + + # TODO: --without with no .lock won't fetch the groups, resulting in insufficient requirements + + if ($deployment) { + $self->print("Installing modules using @{[$env->cpanfile]} (deployment mode)\n"); + $builder->cascade(0); + } else { + $self->print("Installing modules using @{[$env->cpanfile]}\n"); + } + + # TODO merge CPANfile git to mirror even if lock doesn't exist + if ($env->snapshot->loaded) { + my $index_file = $env->install_path->child("cache/modules/02packages.details.txt"); + $index_file->parent->mkpath; + + $env->snapshot->write_index($index_file); + $builder->index($index_file); + } + + if ($cached) { + $builder->mirror(Carton::Mirror->new($env->vendor_cache)); + } + + $builder->install($env->install_path); + + unless ($deployment) { + $env->cpanfile->load; + $env->snapshot->find_installs($env->install_path, $env->cpanfile->requirements); + $env->snapshot->save; + } + + $self->print("Complete! Modules were installed into @{[$env->install_path]}\n", SUCCESS); + } + + sub cmd_show { + my($self, @args) = @_; + + my $env = Carton::Environment->build; + $env->snapshot->load; + + for my $module (@args) { + my $dist = $env->snapshot->find($module) + or $self->error("Couldn't locate $module in cpanfile.snapshot\n"); + $self->print( $dist->name . "\n" ); + } + } + + sub cmd_list { + my($self, @args) = @_; + + my $format = 'name'; + + $self->parse_options( + \@args, + "distfile" => sub { $format = 'distfile' }, + ); + + my $env = Carton::Environment->build; + $env->snapshot->load; + + for my $dist ($env->snapshot->distributions) { + $self->print($dist->$format . "\n"); + } + } + + sub cmd_tree { + my($self, @args) = @_; + + my $env = Carton::Environment->build; + $env->snapshot->load; + $env->cpanfile->load; + + my %seen; + my $dumper = sub { + my($dependency, $reqs, $level) = @_; + return if $level == 0; + return Carton::Tree::STOP if $dependency->dist->is_core; + return Carton::Tree::STOP if $seen{$dependency->distname}++; + $self->printf( "%s%s (%s)\n", " " x ($level - 1), $dependency->module, $dependency->distname, INFO ); + }; + + $env->tree->walk_down($dumper); + } + + sub cmd_check { + my($self, @args) = @_; + + my $cpanfile_path; + $self->parse_options( + \@args, + "cpanfile=s" => \$cpanfile_path, + ); + + my $env = Carton::Environment->build($cpanfile_path); + $env->snapshot->load; + $env->cpanfile->load; + + # TODO remove snapshot + # TODO pass git spec to Requirements? + my $merged_reqs = $env->tree->merged_requirements; + + my @missing; + for my $module ($merged_reqs->required_modules) { + my $install = $env->snapshot->find_or_core($module); + if ($install) { + unless ($merged_reqs->accepts_module($module => $install->version_for($module))) { + push @missing, [ $module, 1, $install->version_for($module) ]; + } + } else { + push @missing, [ $module, 0 ]; + } + } + + if (@missing) { + $self->print("Following dependencies are not satisfied.\n", INFO); + for my $missing (@missing) { + my($module, $unsatisfied, $version) = @$missing; + if ($unsatisfied) { + $self->printf(" %s has version %s. Needs %s\n", + $module, $version, $merged_reqs->requirements_for_module($module), INFO); + } else { + $self->printf(" %s is not installed. Needs %s\n", + $module, $merged_reqs->requirements_for_module($module), INFO); + } + } + $self->printf("Run `carton install` to install them.\n", INFO); + Carton::Error::CommandExit->throw; + } else { + $self->print("cpanfile's dependencies are satisfied.\n", INFO); + } + } + + sub cmd_update { + my($self, @args) = @_; + + my $env = Carton::Environment->build; + $env->cpanfile->load; + + + my $cpanfile = Module::CPANfile->load($env->cpanfile); + @args = grep { $_ ne 'perl' } $env->cpanfile->required_modules unless @args; + + $env->snapshot->load; + + my @modules; + for my $module (@args) { + my $dist = $env->snapshot->find_or_core($module) + or $self->error("Could not find module $module.\n"); + next if $dist->is_core; + push @modules, "$module~" . $env->cpanfile->requirements_for_module($module); + } + + return unless @modules; + + my $builder = Carton::Builder->new( + mirror => $self->mirror, + cpanfile => $env->cpanfile, + ); + $builder->update($env->install_path, @modules); + + $env->snapshot->find_installs($env->install_path, $env->cpanfile->requirements); + $env->snapshot->save; + } + + sub cmd_exec { + my($self, @args) = @_; + + my $env = Carton::Environment->build; + $env->snapshot->load; + + # allows -Ilib + @args = map { /^(-[I])(.+)/ ? ($1,$2) : $_ } @args; + + while (@args) { + if ($args[0] eq '-I') { + warn "exec -Ilib is deprecated. You might want to run: carton exec perl -Ilib ...\n"; + splice(@args, 0, 2); + } else { + last; + } + } + + $self->parse_options_pass_through(\@args); # to handle -- + + unless (@args) { + $self->error("carton exec needs a command to run.\n"); + } + + # PERL5LIB takes care of arch + my $path = $env->install_path; + local $ENV{PERL5LIB} = "$path/lib/perl5"; + local $ENV{PATH} = "$path/bin:$ENV{PATH}"; + + if ($UseSystem) { + system @args; + } else { + exec @args; + exit 127; # command not found + } + } + + 1; +CARTON_CLI + +$fatpacked{"Carton/CPANfile.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON_CPANFILE'; + package Carton::CPANfile; + use Path::Tiny (); + use Module::CPANfile; + + use overload q{""} => sub { $_[0]->stringify }, fallback => 1; + + use subs 'path'; + + use Class::Tiny { + path => undef, + _cpanfile => undef, + requirements => sub { $_[0]->_build_requirements }, + }; + + sub stringify { shift->path->stringify(@_) } + sub dirname { shift->path->dirname(@_) } + sub prereqs { shift->_cpanfile->prereqs(@_) } + sub required_modules { shift->requirements->required_modules(@_) } + sub requirements_for_module { shift->requirements->requirements_for_module(@_) } + + sub path { + my $self = shift; + if (@_) { + $self->{path} = Path::Tiny->new($_[0]); + } else { + $self->{path}; + } + } + + sub load { + my $self = shift; + $self->_cpanfile( Module::CPANfile->load($self->path) ); + } + + sub _build_requirements { + my $self = shift; + my $reqs = CPAN::Meta::Requirements->new; + $reqs->add_requirements($self->prereqs->requirements_for($_, 'requires')) + for qw( configure build runtime test develop ); + $reqs->clear_requirement('perl'); + $reqs; + } + + 1; +CARTON_CPANFILE + +$fatpacked{"Carton/Dependency.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON_DEPENDENCY'; + package Carton::Dependency; + use strict; + use Class::Tiny { + module => undef, + requirement => undef, + dist => undef, + }; + + sub requirements { shift->dist->requirements(@_) } + + sub distname { + my $self = shift; + $self->dist->name; + } + + sub version { + my $self = shift; + $self->dist->version_for($self->module); + } + + 1; +CARTON_DEPENDENCY + +$fatpacked{"Carton/Dist.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON_DIST'; + package Carton::Dist; + use strict; + use Class::Tiny { + name => undef, + pathname => undef, + provides => sub { +{} }, + requirements => sub { $_[0]->_build_requirements }, + }; + + use CPAN::Meta; + + sub add_string_requirement { shift->requirements->add_string_requirement(@_) } + sub required_modules { shift->requirements->required_modules(@_) } + sub requirements_for_module { shift->requirements->requirements_for_module(@_) } + + sub is_core { 0 } + + sub distfile { + my $self = shift; + $self->pathname; + } + + sub _build_requirements { + CPAN::Meta::Requirements->new; + } + + sub provides_module { + my($self, $module) = @_; + exists $self->provides->{$module}; + } + + sub version_for { + my($self, $module) = @_; + $self->provides->{$module}{version}; + } + + 1; +CARTON_DIST + +$fatpacked{"Carton/Dist/Core.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON_DIST_CORE'; + package Carton::Dist::Core; + use strict; + use parent 'Carton::Dist'; + + use Class::Tiny qw( module_version ); + + sub BUILDARGS { + my($class, %args) = @_; + + # TODO represent dual-life + $args{name} =~ s/::/-/g; + + \%args; + } + + sub is_core { 1 } + + sub version_for { + my($self, $module) = @_; + $self->module_version; + } + + 1; +CARTON_DIST_CORE + +$fatpacked{"Carton/Environment.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON_ENVIRONMENT'; + package Carton::Environment; + use strict; + use Carton::CPANfile; + use Carton::Snapshot; + use Carton::Error; + use Carton::Tree; + use Path::Tiny; + + use Class::Tiny { + cpanfile => undef, + snapshot => sub { $_[0]->_build_snapshot }, + install_path => sub { $_[0]->_build_install_path }, + vendor_cache => sub { $_[0]->_build_vendor_cache }, + tree => sub { $_[0]->_build_tree }, + }; + + sub _build_snapshot { + my $self = shift; + Carton::Snapshot->new(path => $self->cpanfile . ".snapshot"); + } + + sub _build_install_path { + my $self = shift; + if ($ENV{PERL_CARTON_PATH}) { + return Path::Tiny->new($ENV{PERL_CARTON_PATH}); + } else { + return $self->cpanfile->path->parent->child("local"); + } + } + + sub _build_vendor_cache { + my $self = shift; + Path::Tiny->new($self->install_path->dirname . "/vendor/cache"); + } + + sub _build_tree { + my $self = shift; + Carton::Tree->new(cpanfile => $self->cpanfile, snapshot => $self->snapshot); + } + + sub vendor_bin { + my $self = shift; + $self->vendor_cache->parent->child('bin'); + } + + sub build_with { + my($class, $cpanfile) = @_; + + $cpanfile = Path::Tiny->new($cpanfile)->absolute; + if ($cpanfile->is_file) { + return $class->new(cpanfile => Carton::CPANfile->new(path => $cpanfile)); + } else { + Carton::Error::CPANfileNotFound->throw(error => "Can't locate cpanfile: $cpanfile"); + } + } + + sub build { + my($class, $cpanfile_path, $install_path) = @_; + + my $self = $class->new; + + $cpanfile_path &&= Path::Tiny->new($cpanfile_path)->absolute; + + my $cpanfile = $self->locate_cpanfile($cpanfile_path || $ENV{PERL_CARTON_CPANFILE}); + if ($cpanfile && $cpanfile->is_file) { + $self->cpanfile( Carton::CPANfile->new(path => $cpanfile) ); + } else { + Carton::Error::CPANfileNotFound->throw(error => "Can't locate cpanfile: (@{[ $cpanfile_path || 'cpanfile' ]})"); + } + + $self->install_path( Path::Tiny->new($install_path)->absolute ) if $install_path; + + $self; + } + + sub locate_cpanfile { + my($self, $path) = @_; + + if ($path) { + return Path::Tiny->new($path)->absolute; + } + + my $current = Path::Tiny->cwd; + my $previous = ''; + + until ($current eq '/' or $current eq $previous) { + # TODO support PERL_CARTON_CPANFILE + my $try = $current->child('cpanfile'); + if ($try->is_file) { + return $try->absolute; + } + + ($previous, $current) = ($current, $current->parent); + } + + return; + } + + 1; + +CARTON_ENVIRONMENT + +$fatpacked{"Carton/Error.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON_ERROR'; + package Carton::Error; + use strict; + use overload '""' => sub { $_[0]->error }; + use Carp; + + sub throw { + my($class, @args) = @_; + die $class->new(@args); + } + + sub rethrow { + die $_[0]; + } + + sub new { + my($class, %args) = @_; + bless \%args, $class; + } + + sub error { + $_[0]->{error} || ref $_[0]; + } + + package Carton::Error::CommandNotFound; + use parent 'Carton::Error'; + + package Carton::Error::CommandExit; + use parent 'Carton::Error'; + sub code { $_[0]->{code} } + + package Carton::Error::CPANfileNotFound; + use parent 'Carton::Error'; + + package Carton::Error::SnapshotParseError; + use parent 'Carton::Error'; + sub path { $_[0]->{path} } + + package Carton::Error::SnapshotNotFound; + use parent 'Carton::Error'; + sub path { $_[0]->{path} } + + 1; +CARTON_ERROR + +$fatpacked{"Carton/Index.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON_INDEX'; + package Carton::Index; + use strict; + use Class::Tiny { + _packages => sub { +{} }, + generator => sub { require Carton; "Carton $Carton::VERSION" }, + }; + + sub add_package { + my($self, $package) = @_; + $self->_packages->{$package->name} = $package; # XXX ||= + } + + sub count { + my $self = shift; + scalar keys %{$self->_packages}; + } + + sub packages { + my $self = shift; + sort { lc $a->name cmp lc $b->name } values %{$self->_packages}; + } + + sub write { + my($self, $fh) = @_; + + print $fh <generator ]} + Line-Count: @{[ $self->count ]} + Last-Updated: @{[ scalar localtime ]} + + EOF + for my $p ($self->packages) { + print $fh $self->_format_line($p->name, $p->version || 'undef', $p->pathname); + } + } + + sub _format_line { + my($self, @row) = @_; + + # from PAUSE::mldistwatch::rewrite02 + my $one = 30; + my $two = 8; + + if (length $row[0] > $one) { + $one += 8 - length $row[1]; + $two = length $row[1]; + } + + sprintf "%-${one}s %${two}s %s\n", @row; + } + + sub pad { + my($str, $len, $left) = @_; + + my $howmany = $len - length($str); + return $str if $howmany <= 0; + + my $pad = " " x $howmany; + return $left ? "$pad$str" : "$str$pad"; + } + + + 1; +CARTON_INDEX + +$fatpacked{"Carton/Mirror.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON_MIRROR'; + package Carton::Mirror; + use strict; + use Class::Tiny qw( url ); + + our $DefaultMirror = 'http://cpan.metacpan.org/'; + + sub BUILDARGS { + my($class, $url) = @_; + return { url => $url }; + } + + sub default { + my $class = shift; + $class->new($DefaultMirror); + } + + sub is_default { + my $self = shift; + $self->url eq $DefaultMirror; + } + + 1; + +CARTON_MIRROR + +$fatpacked{"Carton/Package.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON_PACKAGE'; + package Carton::Package; + use strict; + use Class::Tiny qw( name version pathname ); + + sub BUILDARGS { + my($class, @args) = @_; + return { name => $args[0], version => $args[1], pathname => $args[2] }; + } + + 1; + + +CARTON_PACKAGE + +$fatpacked{"Carton/Packer.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON_PACKER'; + package Carton::Packer; + use Class::Tiny; + use warnings NONFATAL => 'all'; + use App::FatPacker; + use File::pushd (); + use Path::Tiny (); + use CPAN::Meta (); + use File::Find (); + + sub fatpack_carton { + my($self, $dir) = @_; + + my $temp = Path::Tiny->tempdir; + my $pushd = File::pushd::pushd $temp; + + my $file = $temp->child('carton.pre.pl'); + + $file->spew(<<'EOF'); + #!/usr/bin/env perl + use strict; + use 5.008001; + use Carton::CLI; + $Carton::Fatpacked = 1; + exit Carton::CLI->new->run(@ARGV); + EOF + + my $fatpacked = $self->do_fatpack($file); + + my $executable = $dir->child('carton'); + warn "Bundling $executable\n"; + + $dir->mkpath; + $executable->spew($fatpacked); + chmod 0755, $executable; + } + + sub do_fatpack { + my($self, $file) = @_; + + my $packer = App::FatPacker->new; + + my @modules = split /\r?\n/, $packer->trace(args => [$file], use => $self->required_modules); + my @packlists = $packer->packlists_containing(\@modules); + $packer->packlists_to_tree(Path::Tiny->new('fatlib')->absolute, \@packlists); + + my $fatpacked = do { + local $SIG{__WARN__} = sub {}; + $packer->fatpack_file($file); + }; + + # HACK: File::Spec bundled into arch in < 5.16, but is loadable as pure-perl + use Config; + $fatpacked =~ s/\$fatpacked{"$Config{archname}\/(Cwd|File)/\$fatpacked{"$1/g; + + $fatpacked; + } + + sub required_modules { + my($self, $packer) = @_; + + my $meta = $self->installed_meta('Carton') + or die "Couldn't find install metadata for Carton"; + + my %excludes = ( + perl => 1, + 'ExtUtils::MakeMaker' => 1, + 'Module::Build' => 1, + ); + + my @requirements = grep !$excludes{$_}, + $meta->effective_prereqs->requirements_for('runtime', 'requires')->required_modules; + + return \@requirements; + } + + sub installed_meta { + my($self, $dist) = @_; + + my @meta; + my $finder = sub { + if (m!\b$dist-.*[\\/]MYMETA.json!) { + my $meta = CPAN::Meta->load_file($_); + push @meta, $meta if $meta->name eq $dist; + } + }; + + my @meta_dirs = grep -d, map "$_/.meta", @INC; + File::Find::find({ wanted => $finder, no_chdir => 1 }, @meta_dirs) + if @meta_dirs; + + # return the latest version + @meta = sort { version->new($b->version) cmp version->new($a->version) } @meta; + + return $meta[0]; + } + + 1; +CARTON_PACKER + +$fatpacked{"Carton/Snapshot.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON_SNAPSHOT'; + package Carton::Snapshot; + use strict; + use Config; + use Carton::Dist; + use Carton::Dist::Core; + use Carton::Error; + use Carton::Package; + use Carton::Index; + use Carton::Util; + use Carton::Snapshot::Emitter; + use Carton::Snapshot::Parser; + use CPAN::Meta; + use CPAN::Meta::Requirements; + use File::Find (); + use Try::Tiny; + use Path::Tiny (); + use Module::CoreList; + + use constant CARTON_SNAPSHOT_VERSION => '1.0'; + + use subs 'path'; + use Class::Tiny { + path => undef, + version => sub { CARTON_SNAPSHOT_VERSION }, + loaded => undef, + _distributions => sub { +[] }, + }; + + sub BUILD { + my $self = shift; + $self->path( $self->{path} ); + } + + sub path { + my $self = shift; + if (@_) { + $self->{path} = Path::Tiny->new($_[0]); + } else { + $self->{path}; + } + } + + sub load_if_exists { + my $self = shift; + $self->load if $self->path->is_file; + } + + sub load { + my $self = shift; + + return 1 if $self->loaded; + + if ($self->path->is_file) { + my $parser = Carton::Snapshot::Parser->new; + $parser->parse($self->path->slurp_utf8, $self); + $self->loaded(1); + + return 1; + } else { + Carton::Error::SnapshotNotFound->throw( + error => "Can't find cpanfile.snapshot: Run `carton install` to build the snapshot file.", + path => $self->path, + ); + } + } + + sub save { + my $self = shift; + $self->path->spew_utf8( Carton::Snapshot::Emitter->new->emit($self) ); + } + + sub find { + my($self, $module) = @_; + (grep $_->provides_module($module), $self->distributions)[0]; + } + + sub find_or_core { + my($self, $module) = @_; + $self->find($module) || $self->find_in_core($module); + } + + sub find_in_core { + my($self, $module) = @_; + + if (exists $Module::CoreList::version{$]}{$module}) { + my $version = $Module::CoreList::version{$]}{$module}; # maybe undef + return Carton::Dist::Core->new(name => $module, module_version => $version); + } + + return; + } + + sub index { + my $self = shift; + + my $index = Carton::Index->new; + for my $package ($self->packages) { + $index->add_package($package); + } + + return $index; + } + + sub distributions { + @{$_[0]->_distributions}; + } + + sub add_distribution { + my($self, $dist) = @_; + push @{$self->_distributions}, $dist; + } + + sub packages { + my $self = shift; + + my @packages; + for my $dist ($self->distributions) { + while (my($package, $provides) = each %{$dist->provides}) { + # TODO what if duplicates? + push @packages, Carton::Package->new($package, $provides->{version}, $dist->pathname); + } + } + + return @packages; + } + + sub write_index { + my($self, $file) = @_; + + open my $fh, ">", $file or die $!; + $self->index->write($fh); + } + + sub find_installs { + my($self, $path, $reqs) = @_; + + my $libdir = "$path/lib/perl5/$Config{archname}/.meta"; + return {} unless -e $libdir; + + my @installs; + my $wanted = sub { + if ($_ eq 'install.json') { + push @installs, [ $File::Find::name, "$File::Find::dir/MYMETA.json" ]; + } + }; + File::Find::find($wanted, $libdir); + + my %installs; + + my $accepts = sub { + my $module = shift; + + return 0 unless $reqs->accepts_module($module->{name}, $module->{provides}{$module->{name}}{version}); + + if (my $exist = $installs{$module->{name}}) { + my $old_ver = version::->new($exist->{provides}{$module->{name}}{version}); + my $new_ver = version::->new($module->{provides}{$module->{name}}{version}); + return $new_ver >= $old_ver; + } else { + return 1; + } + }; + + for my $file (@installs) { + my $module = Carton::Util::load_json($file->[0]); + my $prereqs = -f $file->[1] ? CPAN::Meta->load_file($file->[1])->effective_prereqs : CPAN::Meta::Prereqs->new; + + my $reqs = CPAN::Meta::Requirements->new; + $reqs->add_requirements($prereqs->requirements_for($_, 'requires')) + for qw( configure build runtime ); + + if ($accepts->($module)) { + $installs{$module->{name}} = Carton::Dist->new( + name => $module->{dist}, + pathname => $module->{pathname}, + provides => $module->{provides}, + version => $module->{version}, + requirements => $reqs, + ); + } + } + + my @new_dists; + for my $module (sort keys %installs) { + push @new_dists, $installs{$module}; + } + + $self->_distributions(\@new_dists); + } + + 1; +CARTON_SNAPSHOT + +$fatpacked{"Carton/Snapshot/Emitter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON_SNAPSHOT_EMITTER'; + package Carton::Snapshot::Emitter; + use Class::Tiny; + use warnings NONFATAL => 'all'; + + sub emit { + my($self, $snapshot) = @_; + + my $data = ''; + $data .= "# carton snapshot format: version @{[$snapshot->version]}\n"; + $data .= "DISTRIBUTIONS\n"; + + for my $dist (sort { $a->name cmp $b->name } $snapshot->distributions) { + $data .= " @{[$dist->name]}\n"; + $data .= " pathname: @{[$dist->pathname]}\n"; + + $data .= " provides:\n"; + for my $package (sort keys %{$dist->provides}) { + $data .= " $package @{[$dist->provides->{$package}{version} || 'undef' ]}\n"; + } + + $data .= " requirements:\n"; + for my $module (sort $dist->required_modules) { + $data .= " $module @{[ $dist->requirements_for_module($module) || '0' ]}\n"; + } + } + + $data; + } + + 1; +CARTON_SNAPSHOT_EMITTER + +$fatpacked{"Carton/Snapshot/Parser.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON_SNAPSHOT_PARSER'; + package Carton::Snapshot::Parser; + use Class::Tiny; + use warnings NONFATAL => 'all'; + use Carton::Dist; + use Carton::Error; + + my $machine = { + init => [ + { + re => qr/^\# carton snapshot format: version (1\.0)/, + code => sub { + my($stash, $snapshot, $ver) = @_; + $snapshot->version($ver); + }, + goto => 'section', + }, + # TODO support pasing error and version mismatch etc. + ], + section => [ + { + re => qr/^DISTRIBUTIONS$/, + goto => 'dists', + }, + { + re => qr/^__EOF__$/, + done => 1, + }, + ], + dists => [ + { + re => qr/^ (\S+)$/, + code => sub { $_[0]->{dist} = Carton::Dist->new(name => $1) }, + goto => 'distmeta', + }, + { + re => qr/^\S/, + goto => 'section', + redo => 1, + }, + ], + distmeta => [ + { + re => qr/^ pathname: (.*)$/, + code => sub { $_[0]->{dist}->pathname($1) }, + }, + { + re => qr/^\s{4}provides:$/, + code => sub { $_[0]->{property} = 'provides' }, + goto => 'properties', + }, + { + re => qr/^\s{4}requirements:$/, + code => sub { + $_[0]->{property} = 'requirements'; + }, + goto => 'properties', + }, + { + re => qr/^\s{0,2}\S/, + code => sub { + my($stash, $snapshot) = @_; + $snapshot->add_distribution($stash->{dist}); + %$stash = (); # clear + }, + goto => 'dists', + redo => 1, + }, + ], + properties => [ + { + re => qr/^\s{6}([0-9A-Za-z_:]+) ([v0-9\._,=\!<>\s]+|undef)/, + code => sub { + my($stash, $snapshot, $module, $version) = @_; + + if ($stash->{property} eq 'provides') { + $stash->{dist}->provides->{$module} = { version => $version }; + } else { + $stash->{dist}->add_string_requirement($module, $version); + } + }, + }, + { + re => qr/^\s{0,4}\S/, + goto => 'distmeta', + redo => 1, + }, + ], + }; + + sub parse { + my($self, $data, $snapshot) = @_; + + my @lines = split /\r?\n/, $data; + + my $state = $machine->{init}; + my $stash = {}; + + LINE: + for my $line (@lines, '__EOF__') { + last LINE unless @$state; + + STATE: { + for my $trans (@{$state}) { + if (my @match = $line =~ $trans->{re}) { + if (my $code = $trans->{code}) { + $code->($stash, $snapshot, @match); + } + if (my $goto = $trans->{goto}) { + $state = $machine->{$goto}; + if ($trans->{redo}) { + redo STATE; + } else { + next LINE; + } + } + + last STATE; + } + } + + Carton::Error::SnapshotParseError->throw(error => "Could not parse snapshot file."); + } + } + } + + 1; +CARTON_SNAPSHOT_PARSER + +$fatpacked{"Carton/Tree.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON_TREE'; + package Carton::Tree; + use strict; + use Carton::Dependency; + + use Class::Tiny qw( cpanfile snapshot ); + + use constant STOP => -1; + + sub walk_down { + my($self, $cb) = @_; + + my $dumper; $dumper = sub { + my($dependency, $reqs, $level, $parent) = @_; + + my $ret = $cb->($dependency, $reqs, $level); + return if $ret && $ret == STOP; + + local $parent->{$dependency->distname} = 1 if $dependency; + + for my $module (sort $reqs->required_modules) { + my $dependency = $self->dependency_for($module, $reqs); + if ($dependency->dist) { + next if $parent->{$dependency->distname}; + $dumper->($dependency, $dependency->requirements, $level + 1, $parent); + } else { + # no dist found in lock + } + } + }; + + $dumper->(undef, $self->cpanfile->requirements, 0, {}); + undef $dumper; + } + + sub dependency_for { + my($self, $module, $reqs) = @_; + + my $requirement = $reqs->requirements_for_module($module); + + my $dep = Carton::Dependency->new; + $dep->module($module); + $dep->requirement($requirement); + + if (my $dist = $self->snapshot->find_or_core($module)) { + $dep->dist($dist); + } + + return $dep; + } + + sub merged_requirements { + my $self = shift; + + my $merged_reqs = CPAN::Meta::Requirements->new; + + my %seen; + $self->walk_down(sub { + my($dependency, $reqs, $level) = @_; + return Carton::Tree::STOP if $dependency && $seen{$dependency->distname}++; + $merged_reqs->add_requirements($reqs); + }); + + $merged_reqs->clear_requirement('perl'); + $merged_reqs->finalize; + + $merged_reqs; + } + + 1; +CARTON_TREE + +$fatpacked{"Carton/Util.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON_UTIL'; + package Carton::Util; + use strict; + use warnings; + + sub load_json { + my $file = shift; + + open my $fh, "<", $file or die "$file: $!"; + from_json(join '', <$fh>); + } + + sub dump_json { + my($data, $file) = @_; + + open my $fh, ">", $file or die "$file: $!"; + binmode $fh; + print $fh to_json($data); + } + + sub from_json { + require JSON; + JSON::decode_json(@_); + } + + sub to_json { + my($data) = @_; + require JSON; + JSON->new->utf8->pretty->canonical->encode($data); + } + + 1; +CARTON_UTIL + +$fatpacked{"Class/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CLASS_TINY'; + use 5.006; + use strict; + no strict 'refs'; + use warnings; + + package Class::Tiny; + # ABSTRACT: Minimalist class construction + + our $VERSION = '1.001'; + + use Carp (); + + # load as .pm to hide from min version scanners + require( $] >= 5.010 ? "mro.pm" : "MRO/Compat.pm" ); ## no critic: + + my %CLASS_ATTRIBUTES; + + sub import { + my $class = shift; + my $pkg = caller; + $class->prepare_class($pkg); + $class->create_attributes( $pkg, @_ ) if @_; + } + + sub prepare_class { + my ( $class, $pkg ) = @_; + @{"${pkg}::ISA"} = "Class::Tiny::Object" unless @{"${pkg}::ISA"}; + } + + # adapted from Object::Tiny and Object::Tiny::RW + sub create_attributes { + my ( $class, $pkg, @spec ) = @_; + my %defaults = map { ref $_ eq 'HASH' ? %$_ : ( $_ => undef ) } @spec; + my @attr = grep { + defined and !ref and /^[^\W\d]\w*$/s + or Carp::croak "Invalid accessor name '$_'" + } keys %defaults; + $CLASS_ATTRIBUTES{$pkg}{$_} = $defaults{$_} for @attr; + _gen_accessor( $pkg, $_ ) for grep { !*{"$pkg\::$_"}{CODE} } @attr; + Carp::croak("Failed to generate attributes for $pkg: $@\n") if $@; + } + + sub _gen_accessor { + my ( $pkg, $name ) = @_; + my $outer_default = $CLASS_ATTRIBUTES{$pkg}{$name}; + + my $sub = "sub $name { if (\@_ == 1) {"; + if ( defined $outer_default && ref $outer_default eq 'CODE' ) { + $sub .= "if ( !exists \$_[0]{$name} ) { \$_[0]{$name} = \$default->(\$_[0]) }"; + } + elsif ( defined $outer_default ) { + $sub .= "if ( !exists \$_[0]{$name} ) { \$_[0]{$name} = \$default }"; + } + $sub .= "return \$_[0]{$name} } else { return \$_[0]{$name}=\$_[1] } }"; + + # default = outer_default avoids "won't stay shared" bug + eval "package $pkg; my \$default=\$outer_default; $sub"; ## no critic + Carp::croak("Failed to generate attributes for $pkg: $@\n") if $@; + } + + sub get_all_attributes_for { + my ( $class, $pkg ) = @_; + my %attr = + map { $_ => undef } + map { keys %{ $CLASS_ATTRIBUTES{$_} || {} } } @{ mro::get_linear_isa($pkg) }; + return keys %attr; + } + + sub get_all_attribute_defaults_for { + my ( $class, $pkg ) = @_; + my $defaults = {}; + for my $p ( reverse @{ mro::get_linear_isa($pkg) } ) { + while ( my ( $k, $v ) = each %{ $CLASS_ATTRIBUTES{$p} || {} } ) { + $defaults->{$k} = $v; + } + } + return $defaults; + } + + package Class::Tiny::Object; + # ABSTRACT: Base class for classes built with Class::Tiny + + our $VERSION = '1.001'; + + my ( %HAS_BUILDARGS, %BUILD_CACHE, %DEMOLISH_CACHE, %ATTR_CACHE ); + + my $_PRECACHE = sub { + no warnings 'once'; # needed to avoid downstream warnings + my ($class) = @_; + my $linear_isa = + @{"$class\::ISA"} == 1 && ${"$class\::ISA"}[0] eq "Class::Tiny::Object" + ? [$class] + : mro::get_linear_isa($class); + $DEMOLISH_CACHE{$class} = [ + map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () } + map { "$_\::DEMOLISH" } @$linear_isa + ]; + $BUILD_CACHE{$class} = [ + map { ( *{$_}{CODE} ) ? ( *{$_}{CODE} ) : () } + map { "$_\::BUILD" } reverse @$linear_isa + ]; + $HAS_BUILDARGS{$class} = $class->can("BUILDARGS"); + return $ATTR_CACHE{$class} = + { map { $_ => 1 } Class::Tiny->get_all_attributes_for($class) }; + }; + + sub new { + my $class = shift; + my $valid_attrs = $ATTR_CACHE{$class} || $_PRECACHE->($class); + + # handle hash ref or key/value arguments + my $args; + if ( $HAS_BUILDARGS{$class} ) { + $args = $class->BUILDARGS(@_); + } + else { + if ( @_ == 1 && ref $_[0] ) { + my %copy = eval { %{ $_[0] } }; # try shallow copy + Carp::croak("Argument to $class->new() could not be dereferenced as a hash") if $@; + $args = \%copy; + } + elsif ( @_ % 2 == 0 ) { + $args = {@_}; + } + else { + Carp::croak("$class->new() got an odd number of elements"); + } + } + + # create object and invoke BUILD (unless we were given __no_BUILD__) + my $self = + bless { map { $_ => $args->{$_} } grep { exists $valid_attrs->{$_} } keys %$args }, + $class; + $self->BUILDALL($args) if !delete $args->{__no_BUILD__} && @{ $BUILD_CACHE{$class} }; + + return $self; + } + + sub BUILDALL { $_->(@_) for @{ $BUILD_CACHE{ ref $_[0] } } } + + # Adapted from Moo and its dependencies + require Devel::GlobalDestruction unless defined ${^GLOBAL_PHASE}; + + sub DESTROY { + my $self = shift; + my $class = ref $self; + my $in_global_destruction = + defined ${^GLOBAL_PHASE} + ? ${^GLOBAL_PHASE} eq 'DESTRUCT' + : Devel::GlobalDestruction::in_global_destruction(); + for my $demolisher ( @{ $DEMOLISH_CACHE{$class} } ) { + my $e = do { + local ( $?, $@ ); + eval { $demolisher->( $self, $in_global_destruction ) }; + $@; + }; + no warnings 'misc'; # avoid (in cleanup) warnings + die $e if $e; # rethrow + } + } + + 1; + + + # vim: ts=4 sts=4 sw=4 et: + + __END__ + + =pod + + =encoding UTF-8 + + =head1 NAME + + Class::Tiny - Minimalist class construction + + =head1 VERSION + + version 1.001 + + =head1 SYNOPSIS + + In F: + + package Person; + + use Class::Tiny qw( name ); + + 1; + + In F: + + package Employee; + use parent 'Person'; + + use Class::Tiny qw( ssn ), { + timestamp => sub { time } # attribute with default + }; + + 1; + + In F: + + use Employee; + + my $obj = Employee->new( name => "Larry", ssn => "111-22-3333" ); + + # unknown attributes are ignored + my $obj = Employee->new( name => "Larry", OS => "Linux" ); + # $obj->{OS} does not exist + + =head1 DESCRIPTION + + This module offers a minimalist class construction kit in around 120 lines of + code. Here is a list of features: + + =over 4 + + =item * + + defines attributes via import arguments + + =item * + + generates read-write accessors + + =item * + + supports lazy attribute defaults + + =item * + + supports custom accessors + + =item * + + superclass provides a standard C constructor + + =item * + + C takes a hash reference or list of key/value pairs + + =item * + + C supports providing C to customize constructor options + + =item * + + C calls C for each class from parent to child + + =item * + + superclass provides a C method + + =item * + + C calls C for each class from child to parent + + =back + + Multiple-inheritance is possible, with superclass order determined via + L. + + It uses no non-core modules for any recent Perl. On Perls older than v5.10 it + requires L. On Perls older than v5.14, it requires + L. + + =head1 USAGE + + =head2 Defining attributes + + Define attributes as a list of import arguments: + + package Foo::Bar; + + use Class::Tiny qw( + name + id + height + weight + ); + + For each attribute, a read-write accessor is created unless a subroutine of that + name already exists: + + $obj->name; # getter + $obj->name( "John Doe" ); # setter + + Attribute names must be valid subroutine identifiers or an exception will + be thrown. + + You can specify lazy defaults by defining attributes with a hash reference. + Keys define attribute names and values are constants or code references that + will be evaluated when the attribute is first accessed if no value has been + set. The object is passed as an argument to a code reference. + + package Foo::WithDefaults; + + use Class::Tiny qw/name id/, { + title => 'Peon', + skills => sub { [] }, + hire_date => sub { $_[0]->_build_hire_date }, + }; + + When subclassing, if multiple accessors of the same name exist in different + classes, any default (or lack of default) is determined by standard + method resolution order. + + To make your own custom accessors, just pre-declare the method name before + loading Class::Tiny: + + package Foo::Bar; + + use subs 'id'; + + use Class::Tiny qw( name id ); + + sub id { ... } + + Even if you pre-declare a method name, you must include it in the attribute + list for Class::Tiny to register it as a valid attribute. + + If you set a default for a custom accessor, your accessor will need to retrieve + the default and do something with it: + + package Foo::Bar; + + use subs 'id'; + + use Class::Tiny qw( name ), { id => sub { int(rand(2*31)) } }; + + sub id { + my $self = shift; + if (@_) { + return $self->{id} = shift; + } + elsif ( exists $self->{id} ) { + return $self->{id}; + } + else { + my $defaults = + Class::Tiny->get_all_attribute_defaults_for( ref $self ); + return $self->{id} = $defaults->{id}->(); + } + } + + =head2 Class::Tiny::Object is your base class + + If your class B already inherit from some class, then + Class::Tiny::Object will be added to your C<@ISA> to provide C and + C. + + If your class B inherit from something, then no additional inheritance is + set up. If the parent subclasses Class::Tiny::Object, then all is well. If + not, then you'll get accessors set up but no constructor or destructor. Don't + do that unless you really have a special need for it. + + Define subclasses as normal. It's best to define them with L, L + or L before defining attributes with Class::Tiny so the C<@ISA> + array is already populated at compile-time: + + package Foo::Bar::More; + + use parent 'Foo::Bar'; + + use Class::Tiny qw( shoe_size ); + + =head2 Object construction + + If your class inherits from Class::Tiny::Object (as it should if you followed + the advice above), it provides the C constructor for you. + + Objects can be created with attributes given as a hash reference or as a list + of key/value pairs: + + $obj = Foo::Bar->new( name => "David" ); + + $obj = Foo::Bar->new( { name => "David" } ); + + If a reference is passed as a single argument, it must be able to be + dereferenced as a hash or an exception is thrown. + + Unknown attributes in the constructor arguments will be ignored. Prior to + version 1.000, unknown attributes were an error, but this made it harder for + people to cleanly subclass Class::Tiny classes so this feature was removed. + + You can define a C method to change how arguments to new are + handled. It will receive the constructor arguments as they were provided and + must return a hash reference of key/value pairs (or else throw an + exception). + + sub BUILDARGS { + my $class = shift; + my $name = shift || "John Doe"; + return { name => $name }; + }; + + Foo::Bar->new( "David" ); + Foo::Bar->new(); # "John Doe" + + Unknown attributes returned from C will be ignored. + + =head2 BUILD + + If your class or any superclass defines a C method, it will be called + by the constructor from the furthest parent class down to the child class after + the object has been created. + + It is passed the constructor arguments as a hash reference. The return value + is ignored. Use C for validation, checking required attributes or + setting default values that depend on other attributes. + + sub BUILD { + my ($self, $args) = @_; + + for my $req ( qw/name age/ ) { + croak "$req attribute required" unless defined $self->$req; + } + + croak "Age must be non-negative" if $self->age < 0; + + $self->msg( "Hello " . $self->name ); + } + + The argument reference is a copy, so deleting elements won't affect data in the + original (but changes will be passed to other BUILD methods in C<@ISA>). + + =head2 DEMOLISH + + Class::Tiny provides a C method. If your class or any superclass + defines a C method, they will be called from the child class to the + furthest parent class during object destruction. It is provided a single + boolean argument indicating whether Perl is in global destruction. Return + values and errors are ignored. + + sub DEMOLISH { + my ($self, $global_destruct) = @_; + $self->cleanup(); + } + + =head2 Introspection and internals + + You can retrieve an unsorted list of valid attributes known to Class::Tiny + for a class and its superclasses with the C class + method. + + my @attrs = Class::Tiny->get_all_attributes_for("Employee"); + # returns qw/name ssn timestamp/ + + Likewise, a hash reference of all valid attributes and default values (or code + references) may be retrieved with the C class + method. Any attributes without a default will be C. + + my $def = Class::Tiny->get_all_attribute_defaults_for("Employee"); + # returns { + # name => undef, + # ssn => undef + # timestamp => $coderef + # } + + The C method uses two class methods, C and + C to set up the C<@ISA> array and attributes. Anyone + attempting to extend Class::Tiny itself should use these instead of mocking up + a call to C. + + When the first object is created, linearized C<@ISA>, the valid attribute list + and various subroutine references are cached for speed. Ensure that all + inheritance and methods are in place before creating objects. (You don't want + to be changing that once you create objects anyway, right?) + + =for Pod::Coverage new get_all_attributes_for get_all_attribute_defaults_for + prepare_class create_attributes + + =head1 RATIONALE + + =head2 Why this instead of Object::Tiny or Class::Accessor or something else? + + I wanted something so simple that it could potentially be used by core Perl + modules I help maintain (or hope to write), most of which either use + L or roll-their-own OO framework each time. + + L and L were close to what I wanted, but + lacking some features I deemed necessary, and their maintainers have an even + more strict philosophy against feature creep than I have. + + I also considered L, which has been around a long time and is + heavily used, but it, too, lacked features I wanted and did things in ways I + considered poor design. + + I looked for something else on CPAN, but after checking a dozen class creators + I realized I could implement exactly what I wanted faster than I could search + CPAN for something merely sufficient. + + In general, compared to most things on CPAN (other than Object::Tiny), + Class::Tiny is smaller in implementation and simpler in API. + + Specifically, here is how Class::Tiny ("C::T") compares to Object::Tiny + ("O::T") and Class::Accessor ("C::A"): + + FEATURE C::T O::T C::A + -------------------------------------------------------------- + attributes defined via import yes yes no + read/write accessors yes no yes + lazy attribute defaults yes no no + provides new yes yes yes + provides DESTROY yes no no + new takes either hashref or list yes no (list) no (hash) + Moo(se)-like BUILD/DEMOLISH yes no no + Moo(se)-like BUILDARGS yes no no + no extraneous methods via @ISA yes yes no + + =head2 Why this instead of Moose or Moo? + + L and L are both excellent OO frameworks. Moose offers a powerful + meta-object protocol (MOP), but is slow to start up and has about 30 non-core + dependencies including XS modules. Moo is faster to start up and has about 10 + pure Perl dependencies but provides no true MOP, relying instead on its ability + to transparently upgrade Moo to Moose when Moose's full feature set is + required. + + By contrast, Class::Tiny has no MOP and has B non-core dependencies for + Perls in the L. It has far less code, less + complexity and no learning curve. If you don't need or can't afford what Moo or + Moose offer, this is intended to be a reasonable fallback. + + That said, Class::Tiny offers Moose-like conventions for things like C + and C for some minimal interoperability and an easier upgrade path. + + =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan + + =head1 SUPPORT + + =head2 Bugs / Feature Requests + + Please report any bugs or feature requests through the issue tracker + at L. + You will be notified automatically of any progress on your issue. + + =head2 Source Code + + This is open source software. The code repository is available for + public review and contribution under the terms of the license. + + L + + git clone https://github.com/dagolden/Class-Tiny.git + + =head1 AUTHOR + + David Golden + + =head1 CONTRIBUTORS + + =for stopwords Dagfinn Ilmari Mannsåker Gelu Lupas Karen Etheridge Matt S Trout Olivier Mengué Toby Inkster + + =over 4 + + =item * + + Dagfinn Ilmari Mannsåker + + =item * + + Gelu Lupas + + =item * + + Karen Etheridge + + =item * + + Matt S Trout + + =item * + + Olivier Mengué + + =item * + + Toby Inkster + + =back + + =head1 COPYRIGHT AND LICENSE + + This software is Copyright (c) 2013 by David Golden. + + This is free software, licensed under: + + The Apache License, Version 2.0, January 2004 + + =cut +CLASS_TINY + +$fatpacked{"Devel/GlobalDestruction.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'DEVEL_GLOBALDESTRUCTION'; + package Devel::GlobalDestruction; + + use strict; + use warnings; + + our $VERSION = '0.13'; + + use Sub::Exporter::Progressive -setup => { + exports => [ qw(in_global_destruction) ], + groups => { default => [ -all ] }, + }; + + # we run 5.14+ - everything is in core + # + if (defined ${^GLOBAL_PHASE}) { + eval 'sub in_global_destruction () { ${^GLOBAL_PHASE} eq q[DESTRUCT] }; 1' + or die $@; + } + # try to load the xs version if it was compiled + # + elsif (eval { + require Devel::GlobalDestruction::XS; + no warnings 'once'; + *in_global_destruction = \&Devel::GlobalDestruction::XS::in_global_destruction; + 1; + }) { + # the eval already installed everything, nothing to do + } + else { + # internally, PL_main_cv is set to Nullcv immediately before entering + # global destruction and we can use B to detect that. B::main_cv will + # only ever be a B::CV or a B::SPECIAL that is a reference to 0 + require B; + eval 'sub in_global_destruction () { ${B::main_cv()} == 0 }; 1' + or die $@; + } + + 1; # keep require happy + + + __END__ + + =head1 NAME + + Devel::GlobalDestruction - Provides function returning the equivalent of + C<${^GLOBAL_PHASE} eq 'DESTRUCT'> for older perls. + + =head1 SYNOPSIS + + package Foo; + use Devel::GlobalDestruction; + + use namespace::clean; # to avoid having an "in_global_destruction" method + + sub DESTROY { + return if in_global_destruction; + + do_something_a_little_tricky(); + } + + =head1 DESCRIPTION + + Perl's global destruction is a little tricky to deal with WRT finalizers + because it's not ordered and objects can sometimes disappear. + + Writing defensive destructors is hard and annoying, and usually if global + destruction is happening you only need the destructors that free up non + process local resources to actually execute. + + For these constructors you can avoid the mess by simply bailing out if global + destruction is in effect. + + =head1 EXPORTS + + This module uses L so the exports may be renamed, + aliased, etc. if L is present. + + =over 4 + + =item in_global_destruction + + Returns true if the interpreter is in global destruction. In perl 5.14+, this + returns C<${^GLOBAL_PHASE} eq 'DESTRUCT'>, and on earlier perls, detects it using + the value of C or C. + + =back + + =head1 AUTHORS + + Yuval Kogman Enothingmuch@woobling.orgE + + Florian Ragwitz Erafl@debian.orgE + + Jesse Luehrs Edoy@tozt.netE + + Peter Rabbitson Eribasushi@cpan.orgE + + Arthur Axel 'fREW' Schmidt Efrioux@gmail.comE + + Elizabeth Mattijsen Eliz@dijkmat.nlE + + Greham Knop Ehaarg@haarg.orgE + + =head1 COPYRIGHT + + Copyright (c) 2008 Yuval Kogman. All rights reserved + This program is free software; you can redistribute + it and/or modify it under the same terms as Perl itself. + + =cut +DEVEL_GLOBALDESTRUCTION + +$fatpacked{"ExtUtils/Command.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_COMMAND'; + package ExtUtils::Command; + + use 5.00503; + use strict; + require Exporter; + use vars qw(@ISA @EXPORT @EXPORT_OK $VERSION); + @ISA = qw(Exporter); + @EXPORT = qw(cp rm_f rm_rf mv cat eqtime mkpath touch test_f test_d chmod + dos2unix); + $VERSION = '7.06'; + $VERSION = eval $VERSION; + + my $Is_VMS = $^O eq 'VMS'; + my $Is_VMS_mode = $Is_VMS; + my $Is_VMS_noefs = $Is_VMS; + my $Is_Win32 = $^O eq 'MSWin32'; + + if( $Is_VMS ) { + my $vms_unix_rpt; + my $vms_efs; + my $vms_case; + + if (eval { local $SIG{__DIE__}; require VMS::Feature; }) { + $vms_unix_rpt = VMS::Feature::current("filename_unix_report"); + $vms_efs = VMS::Feature::current("efs_charset"); + $vms_case = VMS::Feature::current("efs_case_preserve"); + } else { + my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; + my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || ''; + my $efs_case = $ENV{'DECC$EFS_CASE_PRESERVE'} || ''; + $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i; + $vms_efs = $efs_charset =~ /^[ET1]/i; + $vms_case = $efs_case =~ /^[ET1]/i; + } + $Is_VMS_mode = 0 if $vms_unix_rpt; + $Is_VMS_noefs = 0 if ($vms_efs); + } + + + =head1 NAME + + ExtUtils::Command - utilities to replace common UNIX commands in Makefiles etc. + + =head1 SYNOPSIS + + perl -MExtUtils::Command -e cat files... > destination + perl -MExtUtils::Command -e mv source... destination + perl -MExtUtils::Command -e cp source... destination + perl -MExtUtils::Command -e touch files... + perl -MExtUtils::Command -e rm_f files... + perl -MExtUtils::Command -e rm_rf directories... + perl -MExtUtils::Command -e mkpath directories... + perl -MExtUtils::Command -e eqtime source destination + perl -MExtUtils::Command -e test_f file + perl -MExtUtils::Command -e test_d directory + perl -MExtUtils::Command -e chmod mode files... + ... + + =head1 DESCRIPTION + + The module is used to replace common UNIX commands. In all cases the + functions work from @ARGV rather than taking arguments. This makes + them easier to deal with in Makefiles. Call them like this: + + perl -MExtUtils::Command -e some_command some files to work on + + and I like this: + + perl -MExtUtils::Command -e 'some_command qw(some files to work on)' + + For that use L. + + Filenames with * and ? will be glob expanded. + + + =head2 FUNCTIONS + + =over 4 + + =cut + + # VMS uses % instead of ? to mean "one character" + my $wild_regex = $Is_VMS ? '*%' : '*?'; + sub expand_wildcards + { + @ARGV = map(/[$wild_regex]/o ? glob($_) : $_,@ARGV); + } + + + =item cat + + cat file ... + + Concatenates all files mentioned on command line to STDOUT. + + =cut + + sub cat () + { + expand_wildcards(); + print while (<>); + } + + =item eqtime + + eqtime source destination + + Sets modified time of destination to that of source. + + =cut + + sub eqtime + { + my ($src,$dst) = @ARGV; + local @ARGV = ($dst); touch(); # in case $dst doesn't exist + utime((stat($src))[8,9],$dst); + } + + =item rm_rf + + rm_rf files or directories ... + + Removes files and directories - recursively (even if readonly) + + =cut + + sub rm_rf + { + expand_wildcards(); + require File::Path; + File::Path::rmtree([grep -e $_,@ARGV],0,0); + } + + =item rm_f + + rm_f file ... + + Removes files (even if readonly) + + =cut + + sub rm_f { + expand_wildcards(); + + foreach my $file (@ARGV) { + next unless -f $file; + + next if _unlink($file); + + chmod(0777, $file); + + next if _unlink($file); + + require Carp; + Carp::carp("Cannot delete $file: $!"); + } + } + + sub _unlink { + my $files_unlinked = 0; + foreach my $file (@_) { + my $delete_count = 0; + $delete_count++ while unlink $file; + $files_unlinked++ if $delete_count; + } + return $files_unlinked; + } + + + =item touch + + touch file ... + + Makes files exist, with current timestamp + + =cut + + sub touch { + my $t = time; + expand_wildcards(); + foreach my $file (@ARGV) { + open(FILE,">>$file") || die "Cannot write $file:$!"; + close(FILE); + utime($t,$t,$file); + } + } + + =item mv + + mv source_file destination_file + mv source_file source_file destination_dir + + Moves source to destination. Multiple sources are allowed if + destination is an existing directory. + + Returns true if all moves succeeded, false otherwise. + + =cut + + sub mv { + expand_wildcards(); + my @src = @ARGV; + my $dst = pop @src; + + if (@src > 1 && ! -d $dst) { + require Carp; + Carp::croak("Too many arguments"); + } + + require File::Copy; + my $nok = 0; + foreach my $src (@src) { + $nok ||= !File::Copy::move($src,$dst); + } + return !$nok; + } + + =item cp + + cp source_file destination_file + cp source_file source_file destination_dir + + Copies sources to the destination. Multiple sources are allowed if + destination is an existing directory. + + Returns true if all copies succeeded, false otherwise. + + =cut + + sub cp { + expand_wildcards(); + my @src = @ARGV; + my $dst = pop @src; + + if (@src > 1 && ! -d $dst) { + require Carp; + Carp::croak("Too many arguments"); + } + + require File::Copy; + my $nok = 0; + foreach my $src (@src) { + $nok ||= !File::Copy::copy($src,$dst); + + # Win32 does not update the mod time of a copied file, just the + # created time which make does not look at. + utime(time, time, $dst) if $Is_Win32; + } + return $nok; + } + + =item chmod + + chmod mode files ... + + Sets UNIX like permissions 'mode' on all the files. e.g. 0666 + + =cut + + sub chmod { + local @ARGV = @ARGV; + my $mode = shift(@ARGV); + expand_wildcards(); + + if( $Is_VMS_mode && $Is_VMS_noefs) { + require File::Spec; + foreach my $idx (0..$#ARGV) { + my $path = $ARGV[$idx]; + next unless -d $path; + + # chmod 0777, [.foo.bar] doesn't work on VMS, you have to do + # chmod 0777, [.foo]bar.dir + my @dirs = File::Spec->splitdir( $path ); + $dirs[-1] .= '.dir'; + $path = File::Spec->catfile(@dirs); + + $ARGV[$idx] = $path; + } + } + + chmod(oct $mode,@ARGV) || die "Cannot chmod ".join(' ',$mode,@ARGV).":$!"; + } + + =item mkpath + + mkpath directory ... + + Creates directories, including any parent directories. + + =cut + + sub mkpath + { + expand_wildcards(); + require File::Path; + File::Path::mkpath([@ARGV],0,0777); + } + + =item test_f + + test_f file + + Tests if a file exists. I with 0 if it does, 1 if it does not (ie. + shell's idea of true and false). + + =cut + + sub test_f + { + exit(-f $ARGV[0] ? 0 : 1); + } + + =item test_d + + test_d directory + + Tests if a directory exists. I with 0 if it does, 1 if it does + not (ie. shell's idea of true and false). + + =cut + + sub test_d + { + exit(-d $ARGV[0] ? 0 : 1); + } + + =item dos2unix + + dos2unix files or dirs ... + + Converts DOS and OS/2 linefeeds to Unix style recursively. + + =cut + + sub dos2unix { + require File::Find; + File::Find::find(sub { + return if -d; + return unless -w _; + return unless -r _; + return if -B _; + + local $\; + + my $orig = $_; + my $temp = '.dos2unix_tmp'; + open ORIG, $_ or do { warn "dos2unix can't open $_: $!"; return }; + open TEMP, ">$temp" or + do { warn "dos2unix can't create .dos2unix_tmp: $!"; return }; + while (my $line = ) { + $line =~ s/\015\012/\012/g; + print TEMP $line; + } + close ORIG; + close TEMP; + rename $temp, $orig; + + }, @ARGV); + } + + =back + + =head1 SEE ALSO + + Shell::Command which is these same functions but take arguments normally. + + + =head1 AUTHOR + + Nick Ing-Simmons C + + Maintained by Michael G Schwern C within the + ExtUtils-MakeMaker package and, as a separate CPAN package, by + Randy Kobes C. + + =cut + +EXTUTILS_COMMAND + +$fatpacked{"ExtUtils/Command/MM.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_COMMAND_MM'; + package ExtUtils::Command::MM; + + require 5.006; + + use strict; + use warnings; + + require Exporter; + our @ISA = qw(Exporter); + + our @EXPORT = qw(test_harness pod2man perllocal_install uninstall + warn_if_old_packlist test_s cp_nonempty); + our $VERSION = '7.06'; + $VERSION = eval $VERSION; + + my $Is_VMS = $^O eq 'VMS'; + + eval { require Time::HiRes; die unless Time::HiRes->can("stat"); }; + *mtime = $@ ? + sub { [ stat($_[0])]->[9] } : + sub { [Time::HiRes::stat($_[0])]->[9] } ; + + =head1 NAME + + ExtUtils::Command::MM - Commands for the MM's to use in Makefiles + + =head1 SYNOPSIS + + perl "-MExtUtils::Command::MM" -e "function" "--" arguments... + + + =head1 DESCRIPTION + + B The interface is not stable. + + ExtUtils::Command::MM encapsulates code which would otherwise have to + be done with large "one" liners. + + Any $(FOO) used in the examples are make variables, not Perl. + + =over 4 + + =item B + + test_harness($verbose, @test_libs); + + Runs the tests on @ARGV via Test::Harness passing through the $verbose + flag. Any @test_libs will be unshifted onto the test's @INC. + + @test_libs are run in alphabetical order. + + =cut + + sub test_harness { + require Test::Harness; + require File::Spec; + + $Test::Harness::verbose = shift; + + # Because Windows doesn't do this for us and listing all the *.t files + # out on the command line can blow over its exec limit. + require ExtUtils::Command; + my @argv = ExtUtils::Command::expand_wildcards(@ARGV); + + local @INC = @INC; + unshift @INC, map { File::Spec->rel2abs($_) } @_; + Test::Harness::runtests(sort { lc $a cmp lc $b } @argv); + } + + + + =item B + + pod2man( '--option=value', + $podfile1 => $manpage1, + $podfile2 => $manpage2, + ... + ); + + # or args on @ARGV + + pod2man() is a function performing most of the duties of the pod2man + program. Its arguments are exactly the same as pod2man as of 5.8.0 + with the addition of: + + --perm_rw octal permission to set the resulting manpage to + + And the removal of: + + --verbose/-v + --help/-h + + If no arguments are given to pod2man it will read from @ARGV. + + If Pod::Man is unavailable, this function will warn and return undef. + + =cut + + sub pod2man { + local @ARGV = @_ ? @_ : @ARGV; + + { + local $@; + if( !eval { require Pod::Man } ) { + warn "Pod::Man is not available: $@". + "Man pages will not be generated during this install.\n"; + return 0; + } + } + require Getopt::Long; + + # We will cheat and just use Getopt::Long. We fool it by putting + # our arguments into @ARGV. Should be safe. + my %options = (); + Getopt::Long::config ('bundling_override'); + Getopt::Long::GetOptions (\%options, + 'section|s=s', 'release|r=s', 'center|c=s', + 'date|d=s', 'fixed=s', 'fixedbold=s', 'fixeditalic=s', + 'fixedbolditalic=s', 'official|o', 'quotes|q=s', 'lax|l', + 'name|n=s', 'perm_rw=i', 'utf8|u' + ); + delete $options{utf8} unless $Pod::Man::VERSION >= 2.17; + + # If there's no files, don't bother going further. + return 0 unless @ARGV; + + # Official sets --center, but don't override things explicitly set. + if ($options{official} && !defined $options{center}) { + $options{center} = q[Perl Programmer's Reference Guide]; + } + + # This isn't a valid Pod::Man option and is only accepted for backwards + # compatibility. + delete $options{lax}; + my $count = scalar @ARGV / 2; + my $plural = $count == 1 ? 'document' : 'documents'; + print "Manifying $count pod $plural\n"; + + do {{ # so 'next' works + my ($pod, $man) = splice(@ARGV, 0, 2); + + next if ((-e $man) && + (mtime($man) > mtime($pod)) && + (mtime($man) > mtime("Makefile"))); + + my $parser = Pod::Man->new(%options); + $parser->parse_from_file($pod, $man) + or do { warn("Could not install $man\n"); next }; + + if (exists $options{perm_rw}) { + chmod(oct($options{perm_rw}), $man) + or do { warn("chmod $options{perm_rw} $man: $!\n"); next }; + } + }} while @ARGV; + + return 1; + } + + + =item B + + perl "-MExtUtils::Command::MM" -e warn_if_old_packlist + + Displays a warning that an old packlist file was found. Reads the + filename from @ARGV. + + =cut + + sub warn_if_old_packlist { + my $packlist = $ARGV[0]; + + return unless -f $packlist; + print <<"PACKLIST_WARNING"; + WARNING: I have found an old package in + $packlist. + Please make sure the two installations are not conflicting + PACKLIST_WARNING + + } + + + =item B + + perl "-MExtUtils::Command::MM" -e perllocal_install + ... + + # VMS only, key|value pairs come on STDIN + perl "-MExtUtils::Command::MM" -e perllocal_install + < | ... + + Prints a fragment of POD suitable for appending to perllocal.pod. + Arguments are read from @ARGV. + + 'type' is the type of what you're installing. Usually 'Module'. + + 'module name' is simply the name of your module. (Foo::Bar) + + Key/value pairs are extra information about the module. Fields include: + + installed into which directory your module was out into + LINKTYPE dynamic or static linking + VERSION module version number + EXE_FILES any executables installed in a space seperated + list + + =cut + + sub perllocal_install { + my($type, $name) = splice(@ARGV, 0, 2); + + # VMS feeds args as a piped file on STDIN since it usually can't + # fit all the args on a single command line. + my @mod_info = $Is_VMS ? split /\|/, + : @ARGV; + + my $pod; + $pod = sprintf <<'POD', scalar(localtime), $type, $name; + =head2 %s: C<%s> L<%3$s|%3$s> + + =over 4 + + POD + + do { + my($key, $val) = splice(@mod_info, 0, 2); + + $pod .= < + + POD + + } while(@mod_info); + + $pod .= "=back\n\n"; + $pod =~ s/^ //mg; + print $pod; + + return 1; + } + + =item B + + perl "-MExtUtils::Command::MM" -e uninstall + + A wrapper around ExtUtils::Install::uninstall(). Warns that + uninstallation is deprecated and doesn't actually perform the + uninstallation. + + =cut + + sub uninstall { + my($packlist) = shift @ARGV; + + require ExtUtils::Install; + + print <<'WARNING'; + + Uninstall is unsafe and deprecated, the uninstallation was not performed. + We will show what would have been done. + + WARNING + + ExtUtils::Install::uninstall($packlist, 1, 1); + + print <<'WARNING'; + + Uninstall is unsafe and deprecated, the uninstallation was not performed. + Please check the list above carefully, there may be errors. + Remove the appropriate files manually. + Sorry for the inconvenience. + + WARNING + + } + + =item B + + perl "-MExtUtils::Command::MM" -e test_s + + Tests if a file exists and is not empty (size > 0). + I with 0 if it does, 1 if it does not. + + =cut + + sub test_s { + exit(-s $ARGV[0] ? 0 : 1); + } + + =item B + + perl "-MExtUtils::Command::MM" -e cp_nonempty + + Tests if the source file exists and is not empty (size > 0). If it is not empty + it copies it to the given destination with the given permissions. + + =back + + =cut + + sub cp_nonempty { + my @args = @ARGV; + return 0 unless -s $args[0]; + require ExtUtils::Command; + { + local @ARGV = @args[0,1]; + ExtUtils::Command::cp(@ARGV); + } + { + local @ARGV = @args[2,1]; + ExtUtils::Command::chmod(@ARGV); + } + } + + + 1; +EXTUTILS_COMMAND_MM + +$fatpacked{"ExtUtils/Liblist.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_LIBLIST'; + package ExtUtils::Liblist; + + use strict; + + our $VERSION = '7.06'; + $VERSION = eval $VERSION; + + use File::Spec; + require ExtUtils::Liblist::Kid; + our @ISA = qw(ExtUtils::Liblist::Kid File::Spec); + + # Backwards compatibility with old interface. + sub ext { + goto &ExtUtils::Liblist::Kid::ext; + } + + sub lsdir { + shift; + my $rex = qr/$_[1]/; + opendir my $dir_fh, $_[0]; + my @out = grep /$rex/, readdir $dir_fh; + closedir $dir_fh; + return @out; + } + + __END__ + + =head1 NAME + + ExtUtils::Liblist - determine libraries to use and how to use them + + =head1 SYNOPSIS + + require ExtUtils::Liblist; + + $MM->ext($potential_libs, $verbose, $need_names); + + # Usually you can get away with: + ExtUtils::Liblist->ext($potential_libs, $verbose, $need_names) + + =head1 DESCRIPTION + + This utility takes a list of libraries in the form C<-llib1 -llib2 + -llib3> and returns lines suitable for inclusion in an extension + Makefile. Extra library paths may be included with the form + C<-L/another/path> this will affect the searches for all subsequent + libraries. + + It returns an array of four or five scalar values: EXTRALIBS, + BSLOADLIBS, LDLOADLIBS, LD_RUN_PATH, and, optionally, a reference to + the array of the filenames of actual libraries. Some of these don't + mean anything unless on Unix. See the details about those platform + specifics below. The list of the filenames is returned only if + $need_names argument is true. + + Dependent libraries can be linked in one of three ways: + + =over 2 + + =item * For static extensions + + by the ld command when the perl binary is linked with the extension + library. See EXTRALIBS below. + + =item * For dynamic extensions at build/link time + + by the ld command when the shared object is built/linked. See + LDLOADLIBS below. + + =item * For dynamic extensions at load time + + by the DynaLoader when the shared object is loaded. See BSLOADLIBS + below. + + =back + + =head2 EXTRALIBS + + List of libraries that need to be linked with when linking a perl + binary which includes this extension. Only those libraries that + actually exist are included. These are written to a file and used + when linking perl. + + =head2 LDLOADLIBS and LD_RUN_PATH + + List of those libraries which can or must be linked into the shared + library when created using ld. These may be static or dynamic + libraries. LD_RUN_PATH is a colon separated list of the directories + in LDLOADLIBS. It is passed as an environment variable to the process + that links the shared library. + + =head2 BSLOADLIBS + + List of those libraries that are needed but can be linked in + dynamically at run time on this platform. SunOS/Solaris does not need + this because ld records the information (from LDLOADLIBS) into the + object file. This list is used to create a .bs (bootstrap) file. + + =head1 PORTABILITY + + This module deals with a lot of system dependencies and has quite a + few architecture specific Cs in the code. + + =head2 VMS implementation + + The version of ext() which is executed under VMS differs from the + Unix-OS/2 version in several respects: + + =over 2 + + =item * + + Input library and path specifications are accepted with or without the + C<-l> and C<-L> prefixes used by Unix linkers. If neither prefix is + present, a token is considered a directory to search if it is in fact + a directory, and a library to search for otherwise. Authors who wish + their extensions to be portable to Unix or OS/2 should use the Unix + prefixes, since the Unix-OS/2 version of ext() requires them. + + =item * + + Wherever possible, shareable images are preferred to object libraries, + and object libraries to plain object files. In accordance with VMS + naming conventions, ext() looks for files named Ishr and Irtl; + it also looks for Ilib and libI to accommodate Unix conventions + used in some ported software. + + =item * + + For each library that is found, an appropriate directive for a linker options + file is generated. The return values are space-separated strings of + these directives, rather than elements used on the linker command line. + + =item * + + LDLOADLIBS contains both the libraries found based on C<$potential_libs> and + the CRTLs, if any, specified in Config.pm. EXTRALIBS contains just those + libraries found based on C<$potential_libs>. BSLOADLIBS and LD_RUN_PATH + are always empty. + + =back + + In addition, an attempt is made to recognize several common Unix library + names, and filter them out or convert them to their VMS equivalents, as + appropriate. + + In general, the VMS version of ext() should properly handle input from + extensions originally designed for a Unix or VMS environment. If you + encounter problems, or discover cases where the search could be improved, + please let us know. + + =head2 Win32 implementation + + The version of ext() which is executed under Win32 differs from the + Unix-OS/2 version in several respects: + + =over 2 + + =item * + + If C<$potential_libs> is empty, the return value will be empty. + Otherwise, the libraries specified by C<$Config{perllibs}> (see Config.pm) + will be appended to the list of C<$potential_libs>. The libraries + will be searched for in the directories specified in C<$potential_libs>, + C<$Config{libpth}>, and in C<$Config{installarchlib}/CORE>. + For each library that is found, a space-separated list of fully qualified + library pathnames is generated. + + =item * + + Input library and path specifications are accepted with or without the + C<-l> and C<-L> prefixes used by Unix linkers. + + An entry of the form C<-La:\foo> specifies the C directory to look + for the libraries that follow. + + An entry of the form C<-lfoo> specifies the library C, which may be + spelled differently depending on what kind of compiler you are using. If + you are using GCC, it gets translated to C, but for other win32 + compilers, it becomes C. If no files are found by those translated + names, one more attempt is made to find them using either C or + C, depending on whether GCC or some other win32 compiler is + being used, respectively. + + If neither the C<-L> or C<-l> prefix is present in an entry, the entry is + considered a directory to search if it is in fact a directory, and a + library to search for otherwise. The C<$Config{lib_ext}> suffix will + be appended to any entries that are not directories and don't already have + the suffix. + + Note that the C<-L> and C<-l> prefixes are B, but authors + who wish their extensions to be portable to Unix or OS/2 should use the + prefixes, since the Unix-OS/2 version of ext() requires them. + + =item * + + Entries cannot be plain object files, as many Win32 compilers will + not handle object files in the place of libraries. + + =item * + + Entries in C<$potential_libs> beginning with a colon and followed by + alphanumeric characters are treated as flags. Unknown flags will be ignored. + + An entry that matches C disables the appending of default + libraries found in C<$Config{perllibs}> (this should be only needed very rarely). + + An entry that matches C disables all searching for + the libraries specified after it. Translation of C<-Lfoo> and + C<-lfoo> still happens as appropriate (depending on compiler being used, + as reflected by C<$Config{cc}>), but the entries are not verified to be + valid files or directories. + + An entry that matches C reenables searching for + the libraries specified after it. You can put it at the end to + enable searching for default libraries specified by C<$Config{perllibs}>. + + =item * + + The libraries specified may be a mixture of static libraries and + import libraries (to link with DLLs). Since both kinds are used + pretty transparently on the Win32 platform, we do not attempt to + distinguish between them. + + =item * + + LDLOADLIBS and EXTRALIBS are always identical under Win32, and BSLOADLIBS + and LD_RUN_PATH are always empty (this may change in future). + + =item * + + You must make sure that any paths and path components are properly + surrounded with double-quotes if they contain spaces. For example, + C<$potential_libs> could be (literally): + + "-Lc:\Program Files\vc\lib" msvcrt.lib "la test\foo bar.lib" + + Note how the first and last entries are protected by quotes in order + to protect the spaces. + + =item * + + Since this module is most often used only indirectly from extension + C files, here is an example C entry to add + a library to the build process for an extension: + + LIBS => ['-lgl'] + + When using GCC, that entry specifies that MakeMaker should first look + for C (followed by C) in all the locations specified by + C<$Config{libpth}>. + + When using a compiler other than GCC, the above entry will search for + C (followed by C). + + If the library happens to be in a location not in C<$Config{libpth}>, + you need: + + LIBS => ['-Lc:\gllibs -lgl'] + + Here is a less often used example: + + LIBS => ['-lgl', ':nosearch -Ld:\mesalibs -lmesa -luser32'] + + This specifies a search for library C as before. If that search + fails to find the library, it looks at the next item in the list. The + C<:nosearch> flag will prevent searching for the libraries that follow, + so it simply returns the value as C<-Ld:\mesalibs -lmesa -luser32>, + since GCC can use that value as is with its linker. + + When using the Visual C compiler, the second item is returned as + C<-libpath:d:\mesalibs mesa.lib user32.lib>. + + When using the Borland compiler, the second item is returned as + C<-Ld:\mesalibs mesa.lib user32.lib>, and MakeMaker takes care of + moving the C<-Ld:\mesalibs> to the correct place in the linker + command line. + + =back + + + =head1 SEE ALSO + + L + + =cut + +EXTUTILS_LIBLIST + +$fatpacked{"ExtUtils/Liblist/Kid.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_LIBLIST_KID'; + package ExtUtils::Liblist::Kid; + + # XXX Splitting this out into its own .pm is a temporary solution. + + # This kid package is to be used by MakeMaker. It will not work if + # $self is not a Makemaker. + + use 5.006; + + # Broken out of MakeMaker from version 4.11 + + use strict; + use warnings; + our $VERSION = '7.06'; + $VERSION = eval $VERSION; + + use ExtUtils::MakeMaker::Config; + use Cwd 'cwd'; + use File::Basename; + use File::Spec; + + sub ext { + if ( $^O eq 'VMS' ) { return &_vms_ext; } + elsif ( $^O eq 'MSWin32' ) { return &_win32_ext; } + else { return &_unix_os2_ext; } + } + + sub _unix_os2_ext { + my ( $self, $potential_libs, $verbose, $give_libs ) = @_; + $verbose ||= 0; + + if ( $^O =~ /os2|android/ and $Config{perllibs} ) { + + # Dynamic libraries are not transitive, so we may need including + # the libraries linked against perl.dll/libperl.so again. + + $potential_libs .= " " if $potential_libs; + $potential_libs .= $Config{perllibs}; + } + return ( "", "", "", "", ( $give_libs ? [] : () ) ) unless $potential_libs; + warn "Potential libraries are '$potential_libs':\n" if $verbose; + + my ( $so ) = $Config{so}; + my ( $libs ) = defined $Config{perllibs} ? $Config{perllibs} : $Config{libs}; + my $Config_libext = $Config{lib_ext} || ".a"; + my $Config_dlext = $Config{dlext}; + + # compute $extralibs, $bsloadlibs and $ldloadlibs from + # $potential_libs + # this is a rewrite of Andy Dougherty's extliblist in perl + + my ( @searchpath ); # from "-L/path" entries in $potential_libs + my ( @libpath ) = split " ", $Config{'libpth'} || ''; + my ( @ldloadlibs, @bsloadlibs, @extralibs, @ld_run_path, %ld_run_path_seen ); + my ( @libs, %libs_seen ); + my ( $fullname, @fullname ); + my ( $pwd ) = cwd(); # from Cwd.pm + my ( $found ) = 0; + + foreach my $thislib ( split ' ', $potential_libs ) { + my ( $custom_name ) = ''; + + # Handle possible linker path arguments. + if ( $thislib =~ s/^(-[LR]|-Wl,-R|-Wl,-rpath,)// ) { # save path flag type + my ( $ptype ) = $1; + unless ( -d $thislib ) { + warn "$ptype$thislib ignored, directory does not exist\n" + if $verbose; + next; + } + my ( $rtype ) = $ptype; + if ( ( $ptype eq '-R' ) or ( $ptype =~ m!^-Wl,-[Rr]! ) ) { + if ( $Config{'lddlflags'} =~ /-Wl,-[Rr]/ ) { + $rtype = '-Wl,-R'; + } + elsif ( $Config{'lddlflags'} =~ /-R/ ) { + $rtype = '-R'; + } + } + unless ( File::Spec->file_name_is_absolute( $thislib ) ) { + warn "Warning: $ptype$thislib changed to $ptype$pwd/$thislib\n"; + $thislib = $self->catdir( $pwd, $thislib ); + } + push( @searchpath, $thislib ); + push( @extralibs, "$ptype$thislib" ); + push( @ldloadlibs, "$rtype$thislib" ); + next; + } + + if ( $thislib =~ m!^-Wl,! ) { + push( @extralibs, $thislib ); + push( @ldloadlibs, $thislib ); + next; + } + + # Handle possible library arguments. + if ( $thislib =~ s/^-l(:)?// ) { + # Handle -l:foo.so, which means that the library will + # actually be called foo.so, not libfoo.so. This + # is used in Android by ExtUtils::Depends to allow one XS + # module to link to another. + $custom_name = $1 || ''; + } + else { + warn "Unrecognized argument in LIBS ignored: '$thislib'\n"; + next; + } + + my ( $found_lib ) = 0; + foreach my $thispth ( @searchpath, @libpath ) { + + # Try to find the full name of the library. We need this to + # determine whether it's a dynamically-loadable library or not. + # This tends to be subject to various os-specific quirks. + # For gcc-2.6.2 on linux (March 1995), DLD can not load + # .sa libraries, with the exception of libm.sa, so we + # deliberately skip them. + if ((@fullname = + $self->lsdir($thispth, "^\Qlib$thislib.$so.\E[0-9]+")) || + (@fullname = + $self->lsdir($thispth, "^\Qlib$thislib.\E[0-9]+\Q\.$so"))) { + # Take care that libfoo.so.10 wins against libfoo.so.9. + # Compare two libraries to find the most recent version + # number. E.g. if you have libfoo.so.9.0.7 and + # libfoo.so.10.1, first convert all digits into two + # decimal places. Then we'll add ".00" to the shorter + # strings so that we're comparing strings of equal length + # Thus we'll compare libfoo.so.09.07.00 with + # libfoo.so.10.01.00. Some libraries might have letters + # in the version. We don't know what they mean, but will + # try to skip them gracefully -- we'll set any letter to + # '0'. Finally, sort in reverse so we can take the + # first element. + + #TODO: iterate through the directory instead of sorting + + $fullname = "$thispth/" . ( + sort { + my ( $ma ) = $a; + my ( $mb ) = $b; + $ma =~ tr/A-Za-z/0/s; + $ma =~ s/\b(\d)\b/0$1/g; + $mb =~ tr/A-Za-z/0/s; + $mb =~ s/\b(\d)\b/0$1/g; + while ( length( $ma ) < length( $mb ) ) { $ma .= ".00"; } + while ( length( $mb ) < length( $ma ) ) { $mb .= ".00"; } + + # Comparison deliberately backwards + $mb cmp $ma; + } @fullname + )[0]; + } + elsif ( -f ( $fullname = "$thispth/lib$thislib.$so" ) + && ( ( $Config{'dlsrc'} ne "dl_dld.xs" ) || ( $thislib eq "m" ) ) ) + { + } + elsif (-f ( $fullname = "$thispth/lib${thislib}_s$Config_libext" ) + && ( $Config{'archname'} !~ /RM\d\d\d-svr4/ ) + && ( $thislib .= "_s" ) ) + { # we must explicitly use _s version + } + elsif ( -f ( $fullname = "$thispth/lib$thislib$Config_libext" ) ) { + } + elsif ( defined( $Config_dlext ) + && -f ( $fullname = "$thispth/lib$thislib.$Config_dlext" ) ) + { + } + elsif ( -f ( $fullname = "$thispth/$thislib$Config_libext" ) ) { + } + elsif ( -f ( $fullname = "$thispth/lib$thislib.dll$Config_libext" ) ) { + } + elsif ( $^O eq 'cygwin' && -f ( $fullname = "$thispth/$thislib.dll" ) ) { + } + elsif ( -f ( $fullname = "$thispth/Slib$thislib$Config_libext" ) ) { + } + elsif ($^O eq 'dgux' + && -l ( $fullname = "$thispth/lib$thislib$Config_libext" ) + && readlink( $fullname ) =~ /^elink:/s ) + { + + # Some of DG's libraries look like misconnected symbolic + # links, but development tools can follow them. (They + # look like this: + # + # libm.a -> elink:${SDE_PATH:-/usr}/sde/\ + # ${TARGET_BINARY_INTERFACE:-m88kdgux}/usr/lib/libm.a + # + # , the compilation tools expand the environment variables.) + } + elsif ( $custom_name && -f ( $fullname = "$thispth/$thislib" ) ) { + } + else { + warn "$thislib not found in $thispth\n" if $verbose; + next; + } + warn "'-l$thislib' found at $fullname\n" if $verbose; + push @libs, $fullname unless $libs_seen{$fullname}++; + $found++; + $found_lib++; + + # Now update library lists + + # what do we know about this library... + my $is_dyna = ( $fullname !~ /\Q$Config_libext\E\z/ ); + my $in_perl = ( $libs =~ /\B-l:?\Q${thislib}\E\b/s ); + + # include the path to the lib once in the dynamic linker path + # but only if it is a dynamic lib and not in Perl itself + my ( $fullnamedir ) = dirname( $fullname ); + push @ld_run_path, $fullnamedir + if $is_dyna + && !$in_perl + && !$ld_run_path_seen{$fullnamedir}++; + + # Do not add it into the list if it is already linked in + # with the main perl executable. + # We have to special-case the NeXT, because math and ndbm + # are both in libsys_s + unless ( + $in_perl + || ( $Config{'osname'} eq 'next' + && ( $thislib eq 'm' || $thislib eq 'ndbm' ) ) + ) + { + push( @extralibs, "-l$custom_name$thislib" ); + } + + # We might be able to load this archive file dynamically + if ( ( $Config{'dlsrc'} =~ /dl_next/ && $Config{'osvers'} lt '4_0' ) + || ( $Config{'dlsrc'} =~ /dl_dld/ ) ) + { + + # We push -l$thislib instead of $fullname because + # it avoids hardwiring a fixed path into the .bs file. + # Mkbootstrap will automatically add dl_findfile() to + # the .bs file if it sees a name in the -l format. + # USE THIS, when dl_findfile() is fixed: + # push(@bsloadlibs, "-l$thislib"); + # OLD USE WAS while checking results against old_extliblist + push( @bsloadlibs, "$fullname" ); + } + else { + if ( $is_dyna ) { + + # For SunOS4, do not add in this shared library if + # it is already linked in the main perl executable + push( @ldloadlibs, "-l$custom_name$thislib" ) + unless ( $in_perl and $^O eq 'sunos' ); + } + else { + push( @ldloadlibs, "-l$custom_name$thislib" ); + } + } + last; # found one here so don't bother looking further + } + warn "Warning (mostly harmless): " . "No library found for -l$thislib\n" + unless $found_lib > 0; + } + + unless ( $found ) { + return ( '', '', '', '', ( $give_libs ? \@libs : () ) ); + } + else { + return ( "@extralibs", "@bsloadlibs", "@ldloadlibs", join( ":", @ld_run_path ), ( $give_libs ? \@libs : () ) ); + } + } + + sub _win32_ext { + + require Text::ParseWords; + + my ( $self, $potential_libs, $verbose, $give_libs ) = @_; + $verbose ||= 0; + + # If user did not supply a list, we punt. + # (caller should probably use the list in $Config{libs}) + return ( "", "", "", "", ( $give_libs ? [] : () ) ) unless $potential_libs; + + # TODO: make this use MM_Win32.pm's compiler detection + my %libs_seen; + my @extralibs; + my $cc = $Config{cc} || ''; + my $VC = $cc =~ /\bcl\b/i; + my $GC = $cc =~ /\bgcc\b/i; + + my $libext = _win32_lib_extensions(); + my @searchpath = ( '' ); # from "-L/path" entries in $potential_libs + my @libpath = _win32_default_search_paths( $VC, $GC ); + my $pwd = cwd(); # from Cwd.pm + my $search = 1; + + # compute @extralibs from $potential_libs + my @lib_search_list = _win32_make_lib_search_list( $potential_libs, $verbose ); + for ( @lib_search_list ) { + + my $thislib = $_; + + # see if entry is a flag + if ( /^:\w+$/ ) { + $search = 0 if lc eq ':nosearch'; + $search = 1 if lc eq ':search'; + _debug( "Ignoring unknown flag '$thislib'\n", $verbose ) if !/^:(no)?(search|default)$/i; + next; + } + + # if searching is disabled, do compiler-specific translations + unless ( $search ) { + s/^-l(.+)$/$1.lib/ unless $GC; + s/^-L/-libpath:/ if $VC; + push( @extralibs, $_ ); + next; + } + + # handle possible linker path arguments + if ( s/^-L// and not -d ) { + _debug( "$thislib ignored, directory does not exist\n", $verbose ); + next; + } + elsif ( -d ) { + unless ( File::Spec->file_name_is_absolute( $_ ) ) { + warn "Warning: '$thislib' changed to '-L$pwd/$_'\n"; + $_ = $self->catdir( $pwd, $_ ); + } + push( @searchpath, $_ ); + next; + } + + my @paths = ( @searchpath, @libpath ); + my ( $fullname, $path ) = _win32_search_file( $thislib, $libext, \@paths, $verbose, $GC ); + + if ( !$fullname ) { + warn "Warning (mostly harmless): No library found for $thislib\n"; + next; + } + + _debug( "'$thislib' found as '$fullname'\n", $verbose ); + push( @extralibs, $fullname ); + $libs_seen{$fullname} = 1 if $path; # why is this a special case? + } + + my @libs = keys %libs_seen; + + return ( '', '', '', '', ( $give_libs ? \@libs : () ) ) unless @extralibs; + + # make sure paths with spaces are properly quoted + @extralibs = map { qq["$_"] } @extralibs; + @libs = map { qq["$_"] } @libs; + + my $lib = join( ' ', @extralibs ); + + # normalize back to backward slashes (to help braindead tools) + # XXX this may break equally braindead GNU tools that don't understand + # backslashes, either. Seems like one can't win here. Cursed be CP/M. + $lib =~ s,/,\\,g; + + _debug( "Result: $lib\n", $verbose ); + wantarray ? ( $lib, '', $lib, '', ( $give_libs ? \@libs : () ) ) : $lib; + } + + sub _win32_make_lib_search_list { + my ( $potential_libs, $verbose ) = @_; + + # If Config.pm defines a set of default libs, we always + # tack them on to the user-supplied list, unless the user + # specified :nodefault + my $libs = $Config{'perllibs'}; + $potential_libs = join( ' ', $potential_libs, $libs ) if $libs and $potential_libs !~ /:nodefault/i; + _debug( "Potential libraries are '$potential_libs':\n", $verbose ); + + $potential_libs =~ s,\\,/,g; # normalize to forward slashes + + my @list = Text::ParseWords::quotewords( '\s+', 0, $potential_libs ); + + return @list; + } + + sub _win32_default_search_paths { + my ( $VC, $GC ) = @_; + + my $libpth = $Config{'libpth'} || ''; + $libpth =~ s,\\,/,g; # normalize to forward slashes + + my @libpath = Text::ParseWords::quotewords( '\s+', 0, $libpth ); + push @libpath, "$Config{installarchlib}/CORE"; # add "$Config{installarchlib}/CORE" to default search path + + push @libpath, split /;/, $ENV{LIB} if $VC and $ENV{LIB}; + push @libpath, split /;/, $ENV{LIBRARY_PATH} if $GC and $ENV{LIBRARY_PATH}; + + return @libpath; + } + + sub _win32_search_file { + my ( $thislib, $libext, $paths, $verbose, $GC ) = @_; + + my @file_list = _win32_build_file_list( $thislib, $GC, $libext ); + + for my $lib_file ( @file_list ) { + for my $path ( @{$paths} ) { + my $fullname = $lib_file; + $fullname = "$path\\$fullname" if $path; + + return ( $fullname, $path ) if -f $fullname; + + _debug( "'$thislib' not found as '$fullname'\n", $verbose ); + } + } + + return; + } + + sub _win32_build_file_list { + my ( $lib, $GC, $extensions ) = @_; + + my @pre_fixed = _win32_build_prefixed_list( $lib, $GC ); + return map _win32_attach_extensions( $_, $extensions ), @pre_fixed; + } + + sub _win32_build_prefixed_list { + my ( $lib, $GC ) = @_; + + return $lib if $lib !~ s/^-l//; + return $lib if $lib =~ /^lib/ and !$GC; + + ( my $no_prefix = $lib ) =~ s/^lib//i; + $lib = "lib$lib" if $no_prefix eq $lib; + + return ( $lib, $no_prefix ) if $GC; + return ( $no_prefix, $lib ); + } + + sub _win32_attach_extensions { + my ( $lib, $extensions ) = @_; + return map _win32_try_attach_extension( $lib, $_ ), @{$extensions}; + } + + sub _win32_try_attach_extension { + my ( $lib, $extension ) = @_; + + return $lib if $lib =~ /\Q$extension\E$/i; + return "$lib$extension"; + } + + sub _win32_lib_extensions { + my @extensions; + push @extensions, $Config{'lib_ext'} if $Config{'lib_ext'}; + push @extensions, '.dll.a' if grep { m!^\.a$! } @extensions; + push @extensions, '.lib' unless grep { m!^\.lib$! } @extensions; + return \@extensions; + } + + sub _debug { + my ( $message, $verbose ) = @_; + return if !$verbose; + warn $message; + return; + } + + sub _vms_ext { + my ( $self, $potential_libs, $verbose, $give_libs ) = @_; + $verbose ||= 0; + + my ( @crtls, $crtlstr ); + @crtls = ( ( $Config{'ldflags'} =~ m-/Debug-i ? $Config{'dbgprefix'} : '' ) . 'PerlShr/Share' ); + push( @crtls, grep { not /\(/ } split /\s+/, $Config{'perllibs'} ); + push( @crtls, grep { not /\(/ } split /\s+/, $Config{'libc'} ); + + # In general, we pass through the basic libraries from %Config unchanged. + # The one exception is that if we're building in the Perl source tree, and + # a library spec could be resolved via a logical name, we go to some trouble + # to insure that the copy in the local tree is used, rather than one to + # which a system-wide logical may point. + if ( $self->{PERL_SRC} ) { + my ( $locspec, $type ); + foreach my $lib ( @crtls ) { + if ( ( $locspec, $type ) = $lib =~ m{^([\w\$-]+)(/\w+)?} and $locspec =~ /perl/i ) { + if ( lc $type eq '/share' ) { $locspec .= $Config{'exe_ext'}; } + elsif ( lc $type eq '/library' ) { $locspec .= $Config{'lib_ext'}; } + else { $locspec .= $Config{'obj_ext'}; } + $locspec = $self->catfile( $self->{PERL_SRC}, $locspec ); + $lib = "$locspec$type" if -e $locspec; + } + } + } + $crtlstr = @crtls ? join( ' ', @crtls ) : ''; + + unless ( $potential_libs ) { + warn "Result:\n\tEXTRALIBS: \n\tLDLOADLIBS: $crtlstr\n" if $verbose; + return ( '', '', $crtlstr, '', ( $give_libs ? [] : () ) ); + } + + my ( %found, @fndlibs, $ldlib ); + my $cwd = cwd(); + my ( $so, $lib_ext, $obj_ext ) = @Config{ 'so', 'lib_ext', 'obj_ext' }; + + # List of common Unix library names and their VMS equivalents + # (VMS equivalent of '' indicates that the library is automatically + # searched by the linker, and should be skipped here.) + my ( @flibs, %libs_seen ); + my %libmap = ( + 'm' => '', + 'f77' => '', + 'F77' => '', + 'V77' => '', + 'c' => '', + 'malloc' => '', + 'crypt' => '', + 'resolv' => '', + 'c_s' => '', + 'socket' => '', + 'X11' => 'DECW$XLIBSHR', + 'Xt' => 'DECW$XTSHR', + 'Xm' => 'DECW$XMLIBSHR', + 'Xmu' => 'DECW$XMULIBSHR' + ); + + warn "Potential libraries are '$potential_libs'\n" if $verbose; + + # First, sort out directories and library names in the input + my ( @dirs, @libs ); + foreach my $lib ( split ' ', $potential_libs ) { + push( @dirs, $1 ), next if $lib =~ /^-L(.*)/; + push( @dirs, $lib ), next if $lib =~ /[:>\]]$/; + push( @dirs, $lib ), next if -d $lib; + push( @libs, $1 ), next if $lib =~ /^-l(.*)/; + push( @libs, $lib ); + } + push( @dirs, split( ' ', $Config{'libpth'} ) ); + + # Now make sure we've got VMS-syntax absolute directory specs + # (We don't, however, check whether someone's hidden a relative + # path in a logical name.) + foreach my $dir ( @dirs ) { + unless ( -d $dir ) { + warn "Skipping nonexistent Directory $dir\n" if $verbose > 1; + $dir = ''; + next; + } + warn "Resolving directory $dir\n" if $verbose; + if ( File::Spec->file_name_is_absolute( $dir ) ) { + $dir = VMS::Filespec::vmspath( $dir ); + } + else { + $dir = $self->catdir( $cwd, $dir ); + } + } + @dirs = grep { length( $_ ) } @dirs; + unshift( @dirs, '' ); # Check each $lib without additions first + + LIB: foreach my $lib ( @libs ) { + if ( exists $libmap{$lib} ) { + next unless length $libmap{$lib}; + $lib = $libmap{$lib}; + } + + my ( @variants, $cand ); + my ( $ctype ) = ''; + + # If we don't have a file type, consider it a possibly abbreviated name and + # check for common variants. We try these first to grab libraries before + # a like-named executable image (e.g. -lperl resolves to perlshr.exe + # before perl.exe). + if ( $lib !~ /\.[^:>\]]*$/ ) { + push( @variants, "${lib}shr", "${lib}rtl", "${lib}lib" ); + push( @variants, "lib$lib" ) if $lib !~ /[:>\]]/; + } + push( @variants, $lib ); + warn "Looking for $lib\n" if $verbose; + foreach my $variant ( @variants ) { + my ( $fullname, $name ); + + foreach my $dir ( @dirs ) { + my ( $type ); + + $name = "$dir$variant"; + warn "\tChecking $name\n" if $verbose > 2; + $fullname = VMS::Filespec::rmsexpand( $name ); + if ( defined $fullname and -f $fullname ) { + + # It's got its own suffix, so we'll have to figure out the type + if ( $fullname =~ /(?:$so|exe)$/i ) { $type = 'SHR'; } + elsif ( $fullname =~ /(?:$lib_ext|olb)$/i ) { $type = 'OLB'; } + elsif ( $fullname =~ /(?:$obj_ext|obj)$/i ) { + warn "Warning (mostly harmless): " . "Plain object file $fullname found in library list\n"; + $type = 'OBJ'; + } + else { + warn "Warning (mostly harmless): " . "Unknown library type for $fullname; assuming shared\n"; + $type = 'SHR'; + } + } + elsif (-f ( $fullname = VMS::Filespec::rmsexpand( $name, $so ) ) + or -f ( $fullname = VMS::Filespec::rmsexpand( $name, '.exe' ) ) ) + { + $type = 'SHR'; + $name = $fullname unless $fullname =~ /exe;?\d*$/i; + } + elsif ( + not length( $ctype ) and # If we've got a lib already, + # don't bother + ( -f ( $fullname = VMS::Filespec::rmsexpand( $name, $lib_ext ) ) or -f ( $fullname = VMS::Filespec::rmsexpand( $name, '.olb' ) ) ) + ) + { + $type = 'OLB'; + $name = $fullname unless $fullname =~ /olb;?\d*$/i; + } + elsif ( + not length( $ctype ) and # If we've got a lib already, + # don't bother + ( -f ( $fullname = VMS::Filespec::rmsexpand( $name, $obj_ext ) ) or -f ( $fullname = VMS::Filespec::rmsexpand( $name, '.obj' ) ) ) + ) + { + warn "Warning (mostly harmless): " . "Plain object file $fullname found in library list\n"; + $type = 'OBJ'; + $name = $fullname unless $fullname =~ /obj;?\d*$/i; + } + if ( defined $type ) { + $ctype = $type; + $cand = $name; + last if $ctype eq 'SHR'; + } + } + if ( $ctype ) { + + push @{ $found{$ctype} }, $cand; + warn "\tFound as $cand (really $fullname), type $ctype\n" + if $verbose > 1; + push @flibs, $name unless $libs_seen{$fullname}++; + next LIB; + } + } + warn "Warning (mostly harmless): " . "No library found for $lib\n"; + } + + push @fndlibs, @{ $found{OBJ} } if exists $found{OBJ}; + push @fndlibs, map { "$_/Library" } @{ $found{OLB} } if exists $found{OLB}; + push @fndlibs, map { "$_/Share" } @{ $found{SHR} } if exists $found{SHR}; + my $lib = join( ' ', @fndlibs ); + + $ldlib = $crtlstr ? "$lib $crtlstr" : $lib; + $ldlib =~ s/^\s+|\s+$//g; + warn "Result:\n\tEXTRALIBS: $lib\n\tLDLOADLIBS: $ldlib\n" if $verbose; + wantarray ? ( $lib, '', $ldlib, '', ( $give_libs ? \@flibs : () ) ) : $lib; + } + + 1; +EXTUTILS_LIBLIST_KID + +$fatpacked{"ExtUtils/MM.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM'; + package ExtUtils::MM; + + use strict; + use ExtUtils::MakeMaker::Config; + + our $VERSION = '7.06'; + $VERSION = eval $VERSION; + + require ExtUtils::Liblist; + require ExtUtils::MakeMaker; + our @ISA = qw(ExtUtils::Liblist ExtUtils::MakeMaker); + + =head1 NAME + + ExtUtils::MM - OS adjusted ExtUtils::MakeMaker subclass + + =head1 SYNOPSIS + + require ExtUtils::MM; + my $mm = MM->new(...); + + =head1 DESCRIPTION + + B + + ExtUtils::MM is a subclass of ExtUtils::MakeMaker which automatically + chooses the appropriate OS specific subclass for you + (ie. ExtUils::MM_Unix, etc...). + + It also provides a convenient alias via the MM class (I didn't want + MakeMaker modules outside of ExtUtils/). + + This class might turn out to be a temporary solution, but MM won't go + away. + + =cut + + { + # Convenient alias. + package MM; + our @ISA = qw(ExtUtils::MM); + sub DESTROY {} + } + + sub _is_win95 { + # miniperl might not have the Win32 functions available and we need + # to run in miniperl. + my $have_win32 = eval { require Win32 }; + return $have_win32 && defined &Win32::IsWin95 ? Win32::IsWin95() + : ! defined $ENV{SYSTEMROOT}; + } + + my %Is = (); + $Is{VMS} = $^O eq 'VMS'; + $Is{OS2} = $^O eq 'os2'; + $Is{MacOS} = $^O eq 'MacOS'; + if( $^O eq 'MSWin32' ) { + _is_win95() ? $Is{Win95} = 1 : $Is{Win32} = 1; + } + $Is{UWIN} = $^O =~ /^uwin(-nt)?$/; + $Is{Cygwin} = $^O eq 'cygwin'; + $Is{NW5} = $Config{osname} eq 'NetWare'; # intentional + $Is{BeOS} = ($^O =~ /beos/i or $^O eq 'haiku'); + $Is{DOS} = $^O eq 'dos'; + if( $Is{NW5} ) { + $^O = 'NetWare'; + delete $Is{Win32}; + } + $Is{VOS} = $^O eq 'vos'; + $Is{QNX} = $^O eq 'qnx'; + $Is{AIX} = $^O eq 'aix'; + $Is{Darwin} = $^O eq 'darwin'; + + $Is{Unix} = !grep { $_ } values %Is; + + map { delete $Is{$_} unless $Is{$_} } keys %Is; + _assert( keys %Is == 1 ); + my($OS) = keys %Is; + + + my $class = "ExtUtils::MM_$OS"; + eval "require $class" unless $INC{"ExtUtils/MM_$OS.pm"}; ## no critic + die $@ if $@; + unshift @ISA, $class; + + + sub _assert { + my $sanity = shift; + die sprintf "Assert failed at %s line %d\n", (caller)[1,2] unless $sanity; + return; + } +EXTUTILS_MM + +$fatpacked{"ExtUtils/MM_AIX.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_AIX'; + package ExtUtils::MM_AIX; + + use strict; + our $VERSION = '7.06'; + $VERSION = eval $VERSION; + + require ExtUtils::MM_Unix; + our @ISA = qw(ExtUtils::MM_Unix); + + =head1 NAME + + ExtUtils::MM_AIX - AIX specific subclass of ExtUtils::MM_Unix + + =head1 SYNOPSIS + + Don't use this module directly. + Use ExtUtils::MM and let it choose. + + =head1 DESCRIPTION + + This is a subclass of ExtUtils::MM_Unix which contains functionality for + AIX. + + Unless otherwise stated it works just like ExtUtils::MM_Unix + + =head2 Overridden methods + + =head3 dlsyms + + Define DL_FUNCS and DL_VARS and write the *.exp files. + + =cut + + sub dlsyms { + my($self,%attribs) = @_; + return '' unless $self->needs_linking; + my @m; + # these will need XSMULTI-fying but maybe that already happens + push @m,"\ndynamic :: $self->{BASEEXT}.exp\n\n" + unless $self->{SKIPHASH}{'dynamic'}; # dynamic and static are subs, so... + push @m,"\nstatic :: $self->{BASEEXT}.exp\n\n" + unless $self->{SKIPHASH}{'static'}; # we avoid a warning if we tick them + join "\n", @m, $self->xs_dlsyms_iterator(\%attribs); + } + + =head3 xs_dlsyms_ext + + On AIX, is C<.exp>. + + =cut + + sub xs_dlsyms_ext { + '.exp'; + } + + =head1 AUTHOR + + Michael G Schwern with code from ExtUtils::MM_Unix + + =head1 SEE ALSO + + L + + =cut + + + 1; +EXTUTILS_MM_AIX + +$fatpacked{"ExtUtils/MM_Any.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_ANY'; + package ExtUtils::MM_Any; + + use strict; + our $VERSION = '7.06'; + $VERSION = eval $VERSION; + + use Carp; + use File::Spec; + use File::Basename; + BEGIN { our @ISA = qw(File::Spec); } + + # We need $Verbose + use ExtUtils::MakeMaker qw($Verbose write_file_via_tmp neatvalue _sprintf562); + + use ExtUtils::MakeMaker::Config; + + + # So we don't have to keep calling the methods over and over again, + # we have these globals to cache the values. Faster and shrtr. + my $Curdir = __PACKAGE__->curdir; + my $Rootdir = __PACKAGE__->rootdir; + my $Updir = __PACKAGE__->updir; + + my $METASPEC_URL = 'https://metacpan.org/pod/CPAN::Meta::Spec'; + my $METASPEC_V = 2; + my $STASHDIR = File::Spec->catdir('blib', '_eumm'); + + =head1 NAME + + ExtUtils::MM_Any - Platform-agnostic MM methods + + =head1 SYNOPSIS + + FOR INTERNAL USE ONLY! + + package ExtUtils::MM_SomeOS; + + # Temporarily, you have to subclass both. Put MM_Any first. + require ExtUtils::MM_Any; + require ExtUtils::MM_Unix; + @ISA = qw(ExtUtils::MM_Any ExtUtils::Unix); + + =head1 DESCRIPTION + + B + + ExtUtils::MM_Any is a superclass for the ExtUtils::MM_* set of + modules. It contains methods which are either inherently + cross-platform or are written in a cross-platform manner. + + Subclass off of ExtUtils::MM_Any I ExtUtils::MM_Unix. This is a + temporary solution. + + B + + + =head1 METHODS + + Any methods marked I must be implemented by subclasses. + + + =head2 Cross-platform helper methods + + These are methods which help writing cross-platform code. + + + + =head3 os_flavor I + + my @os_flavor = $mm->os_flavor; + + @os_flavor is the style of operating system this is, usually + corresponding to the MM_*.pm file we're using. + + The first element of @os_flavor is the major family (ie. Unix, + Windows, VMS, OS/2, etc...) and the rest are sub families. + + Some examples: + + Cygwin98 ('Unix', 'Cygwin', 'Cygwin9x') + Windows ('Win32') + Win98 ('Win32', 'Win9x') + Linux ('Unix', 'Linux') + MacOS X ('Unix', 'Darwin', 'MacOS', 'MacOS X') + OS/2 ('OS/2') + + This is used to write code for styles of operating system. + See os_flavor_is() for use. + + + =head3 os_flavor_is + + my $is_this_flavor = $mm->os_flavor_is($this_flavor); + my $is_this_flavor = $mm->os_flavor_is(@one_of_these_flavors); + + Checks to see if the current operating system is one of the given flavors. + + This is useful for code like: + + if( $mm->os_flavor_is('Unix') ) { + $out = `foo 2>&1`; + } + else { + $out = `foo`; + } + + =cut + + sub os_flavor_is { + my $self = shift; + my %flavors = map { ($_ => 1) } $self->os_flavor; + return (grep { $flavors{$_} } @_) ? 1 : 0; + } + + + =head3 can_load_xs + + my $can_load_xs = $self->can_load_xs; + + Returns true if we have the ability to load XS. + + This is important because miniperl, used to build XS modules in the + core, can not load XS. + + =cut + + sub can_load_xs { + return defined &DynaLoader::boot_DynaLoader ? 1 : 0; + } + + + =head3 can_run + + use ExtUtils::MM; + my $runnable = MM->can_run($Config{make}); + + If called in a scalar context it will return the full path to the binary + you asked for if it was found, or C if it was not. + + If called in a list context, it will return a list of the full paths to instances + of the binary where found in C, or an empty list if it was not found. + + Copied from L, but modified into + a method (and removed C<$INSTANCES> capability). + + =cut + + sub can_run { + my ($self, $command) = @_; + + # a lot of VMS executables have a symbol defined + # check those first + if ( $^O eq 'VMS' ) { + require VMS::DCLsym; + my $syms = VMS::DCLsym->new; + return $command if scalar $syms->getsym( uc $command ); + } + + my @possibles; + + if( File::Spec->file_name_is_absolute($command) ) { + return $self->maybe_command($command); + + } else { + for my $dir ( + File::Spec->path, + File::Spec->curdir + ) { + next if ! $dir || ! -d $dir; + my $abs = File::Spec->catfile($self->os_flavor_is('Win32') ? Win32::GetShortPathName( $dir ) : $dir, $command); + push @possibles, $abs if $abs = $self->maybe_command($abs); + } + } + return @possibles if wantarray; + return shift @possibles; + } + + + =head3 can_redirect_error + + $useredirect = MM->can_redirect_error; + + True if on an OS where qx operator (or backticks) can redirect C + onto C. + + =cut + + sub can_redirect_error { + my $self = shift; + $self->os_flavor_is('Unix') + or ($self->os_flavor_is('Win32') and !$self->os_flavor_is('Win9x')) + or $self->os_flavor_is('OS/2') + } + + + =head3 is_make_type + + my $is_dmake = $self->is_make_type('dmake'); + + Returns true if C<<$self->make>> is the given type; possibilities are: + + gmake GNU make + dmake + nmake + bsdmake BSD pmake-derived + + =cut + + my %maketype2true; + # undocumented - so t/cd.t can still do its thing + sub _clear_maketype_cache { %maketype2true = () } + + sub is_make_type { + my($self, $type) = @_; + return $maketype2true{$type} if defined $maketype2true{$type}; + (undef, undef, my $make_basename) = $self->splitpath($self->make); + return $maketype2true{$type} = 1 + if $make_basename =~ /\b$type\b/i; # executable's filename + return $maketype2true{$type} = 0 + if $make_basename =~ /\b[gdn]make\b/i; # Never fall through for dmake/nmake/gmake + # now have to run with "-v" and guess + my $redirect = $self->can_redirect_error ? '2>&1' : ''; + my $make = $self->make || $self->{MAKE}; + my $minus_v = `"$make" -v $redirect`; + return $maketype2true{$type} = 1 + if $type eq 'gmake' and $minus_v =~ /GNU make/i; + return $maketype2true{$type} = 1 + if $type eq 'bsdmake' + and $minus_v =~ /^usage: make \[-BeikNnqrstWwX\]/im; + $maketype2true{$type} = 0; # it wasn't whatever you asked + } + + + =head3 can_dep_space + + my $can_dep_space = $self->can_dep_space; + + Returns true if C can handle (probably by quoting) + dependencies that contain a space. Currently known true for GNU make, + false for BSD pmake derivative. + + =cut + + my $cached_dep_space; + sub can_dep_space { + my $self = shift; + return $cached_dep_space if defined $cached_dep_space; + return $cached_dep_space = 1 if $self->is_make_type('gmake'); + return $cached_dep_space = 0 if $self->is_make_type('dmake'); # only on W32 + return $cached_dep_space = 0 if $self->is_make_type('bsdmake'); + return $cached_dep_space = 0; # assume no + } + + + =head3 quote_dep + + $text = $mm->quote_dep($text); + + Method that protects Makefile single-value constants (mainly filenames), + so that make will still treat them as single values even if they + inconveniently have spaces in. If the make program being used cannot + achieve such protection and the given text would need it, throws an + exception. + + =cut + + sub quote_dep { + my ($self, $arg) = @_; + die <can_dep_space; + Tried to use make dependency with space for make that can't: + '$arg' + EOF + $arg =~ s/( )/\\$1/g; # how GNU make does it + return $arg; + } + + + =head3 split_command + + my @cmds = $MM->split_command($cmd, @args); + + Most OS have a maximum command length they can execute at once. Large + modules can easily generate commands well past that limit. Its + necessary to split long commands up into a series of shorter commands. + + C will return a series of @cmds each processing part of + the args. Collectively they will process all the arguments. Each + individual line in @cmds will not be longer than the + $self->max_exec_len being careful to take into account macro expansion. + + $cmd should include any switches and repeated initial arguments. + + If no @args are given, no @cmds will be returned. + + Pairs of arguments will always be preserved in a single command, this + is a heuristic for things like pm_to_blib and pod2man which work on + pairs of arguments. This makes things like this safe: + + $self->split_command($cmd, %pod2man); + + + =cut + + sub split_command { + my($self, $cmd, @args) = @_; + + my @cmds = (); + return(@cmds) unless @args; + + # If the command was given as a here-doc, there's probably a trailing + # newline. + chomp $cmd; + + # set aside 30% for macro expansion. + my $len_left = int($self->max_exec_len * 0.70); + $len_left -= length $self->_expand_macros($cmd); + + do { + my $arg_str = ''; + my @next_args; + while( @next_args = splice(@args, 0, 2) ) { + # Two at a time to preserve pairs. + my $next_arg_str = "\t ". join ' ', @next_args, "\n"; + + if( !length $arg_str ) { + $arg_str .= $next_arg_str + } + elsif( length($arg_str) + length($next_arg_str) > $len_left ) { + unshift @args, @next_args; + last; + } + else { + $arg_str .= $next_arg_str; + } + } + chop $arg_str; + + push @cmds, $self->escape_newlines("$cmd \n$arg_str"); + } while @args; + + return @cmds; + } + + + sub _expand_macros { + my($self, $cmd) = @_; + + $cmd =~ s{\$\((\w+)\)}{ + defined $self->{$1} ? $self->{$1} : "\$($1)" + }e; + return $cmd; + } + + + =head3 make_type + + Returns a suitable string describing the type of makefile being written. + + =cut + + # override if this isn't suitable! + sub make_type { return 'Unix-style'; } + + + =head3 stashmeta + + my @recipelines = $MM->stashmeta($text, $file); + + Generates a set of C<@recipelines> which will result in the literal + C<$text> ending up in literal C<$file> when the recipe is executed. Call + it once, with all the text you want in C<$file>. Make macros will not + be expanded, so the locations will be fixed at configure-time, not + at build-time. + + =cut + + sub stashmeta { + my($self, $text, $file) = @_; + require File::Path; + -d $STASHDIR or die "$STASHDIR: $!" unless File::Path::mkpath($STASHDIR,0,0777); + my $stashfile = File::Spec->catfile($STASHDIR, $file); + write_file_via_tmp($stashfile, [ $text ]); + my $qlfile = $self->quote_literal($file); + my $qlstashfile = $self->quote_literal($stashfile); + ( + sprintf('-$(NOECHO) $(RM_F) %s', $qlfile), + sprintf('-$(NOECHO) $(CP) %s %s', $qlstashfile, $qlfile), + ); + } + + + =head3 echo + + my @commands = $MM->echo($text); + my @commands = $MM->echo($text, $file); + my @commands = $MM->echo($text, $file, \%opts); + + Generates a set of @commands which print the $text to a $file. + + If $file is not given, output goes to STDOUT. + + If $opts{append} is true the $file will be appended to rather than + overwritten. Default is to overwrite. + + If $opts{allow_variables} is true, make variables of the form + C<$(...)> will not be escaped. Other C<$> will. Default is to escape + all C<$>. + + Example of use: + + my $make = join '', map "\t$_\n", $MM->echo($text, $file); + + =cut + + sub echo { + my($self, $text, $file, $opts) = @_; + + # Compatibility with old options + if( !ref $opts ) { + my $append = $opts; + $opts = { append => $append || 0 }; + } + $opts->{allow_variables} = 0 unless defined $opts->{allow_variables}; + + my $ql_opts = { allow_variables => $opts->{allow_variables} }; + my @cmds = map { '$(NOECHO) $(ECHO) '.$self->quote_literal($_, $ql_opts) } + split /\n/, $text; + if( $file ) { + my $redirect = $opts->{append} ? '>>' : '>'; + $cmds[0] .= " $redirect $file"; + $_ .= " >> $file" foreach @cmds[1..$#cmds]; + } + + return @cmds; + } + + + =head3 wraplist + + my $args = $mm->wraplist(@list); + + Takes an array of items and turns them into a well-formatted list of + arguments. In most cases this is simply something like: + + FOO \ + BAR \ + BAZ + + =cut + + sub wraplist { + my $self = shift; + return join " \\\n\t", @_; + } + + + =head3 maketext_filter + + my $filter_make_text = $mm->maketext_filter($make_text); + + The text of the Makefile is run through this method before writing to + disk. It allows systems a chance to make portability fixes to the + Makefile. + + By default it does nothing. + + This method is protected and not intended to be called outside of + MakeMaker. + + =cut + + sub maketext_filter { return $_[1] } + + + =head3 cd I + + my $subdir_cmd = $MM->cd($subdir, @cmds); + + This will generate a make fragment which runs the @cmds in the given + $dir. The rough equivalent to this, except cross platform. + + cd $subdir && $cmd + + Currently $dir can only go down one level. "foo" is fine. "foo/bar" is + not. "../foo" is right out. + + The resulting $subdir_cmd has no leading tab nor trailing newline. This + makes it easier to embed in a make string. For example. + + my $make = sprintf <<'CODE', $subdir_cmd; + foo : + $(ECHO) what + %s + $(ECHO) mouche + CODE + + + =head3 oneliner I + + my $oneliner = $MM->oneliner($perl_code); + my $oneliner = $MM->oneliner($perl_code, \@switches); + + This will generate a perl one-liner safe for the particular platform + you're on based on the given $perl_code and @switches (a -e is + assumed) suitable for using in a make target. It will use the proper + shell quoting and escapes. + + $(PERLRUN) will be used as perl. + + Any newlines in $perl_code will be escaped. Leading and trailing + newlines will be stripped. Makes this idiom much easier: + + my $code = $MM->oneliner(<<'CODE', [...switches...]); + some code here + another line here + CODE + + Usage might be something like: + + # an echo emulation + $oneliner = $MM->oneliner('print "Foo\n"'); + $make = '$oneliner > somefile'; + + Dollar signs in the $perl_code will be protected from make using the + C method, unless they are recognised as being a make + variable, C<$(varname)>, in which case they will be left for make + to expand. Remember to quote make macros else it might be used as a + bareword. For example: + + # Assign the value of the $(VERSION_FROM) make macro to $vf. + $oneliner = $MM->oneliner('$vf = "$(VERSION_FROM)"'); + + Its currently very simple and may be expanded sometime in the figure + to include more flexible code and switches. + + + =head3 quote_literal I + + my $safe_text = $MM->quote_literal($text); + my $safe_text = $MM->quote_literal($text, \%options); + + This will quote $text so it is interpreted literally in the shell. + + For example, on Unix this would escape any single-quotes in $text and + put single-quotes around the whole thing. + + If $options{allow_variables} is true it will leave C<'$(FOO)'> make + variables untouched. If false they will be escaped like any other + C<$>. Defaults to true. + + =head3 escape_dollarsigns + + my $escaped_text = $MM->escape_dollarsigns($text); + + Escapes stray C<$> so they are not interpreted as make variables. + + It lets by C<$(...)>. + + =cut + + sub escape_dollarsigns { + my($self, $text) = @_; + + # Escape dollar signs which are not starting a variable + $text =~ s{\$ (?!\() }{\$\$}gx; + + return $text; + } + + + =head3 escape_all_dollarsigns + + my $escaped_text = $MM->escape_all_dollarsigns($text); + + Escapes all C<$> so they are not interpreted as make variables. + + =cut + + sub escape_all_dollarsigns { + my($self, $text) = @_; + + # Escape dollar signs + $text =~ s{\$}{\$\$}gx; + + return $text; + } + + + =head3 escape_newlines I + + my $escaped_text = $MM->escape_newlines($text); + + Shell escapes newlines in $text. + + + =head3 max_exec_len I + + my $max_exec_len = $MM->max_exec_len; + + Calculates the maximum command size the OS can exec. Effectively, + this is the max size of a shell command line. + + =for _private + $self->{_MAX_EXEC_LEN} is set by this method, but only for testing purposes. + + + =head3 make + + my $make = $MM->make; + + Returns the make variant we're generating the Makefile for. This attempts + to do some normalization on the information from %Config or the user. + + =cut + + sub make { + my $self = shift; + + my $make = lc $self->{MAKE}; + + # Truncate anything like foomake6 to just foomake. + $make =~ s/^(\w+make).*/$1/; + + # Turn gnumake into gmake. + $make =~ s/^gnu/g/; + + return $make; + } + + + =head2 Targets + + These are methods which produce make targets. + + + =head3 all_target + + Generate the default target 'all'. + + =cut + + sub all_target { + my $self = shift; + + return <<'MAKE_EXT'; + all :: pure_all + $(NOECHO) $(NOOP) + MAKE_EXT + + } + + + =head3 blibdirs_target + + my $make_frag = $mm->blibdirs_target; + + Creates the blibdirs target which creates all the directories we use + in blib/. + + The blibdirs.ts target is deprecated. Depend on blibdirs instead. + + + =cut + + sub _xs_list_basenames { + my ($self) = @_; + map { (my $b = $_) =~ s/\.xs$//; $b } sort keys %{ $self->{XS} }; + } + + sub blibdirs_target { + my $self = shift; + + my @dirs = map { uc "\$(INST_$_)" } qw(libdir archlib + autodir archautodir + bin script + man1dir man3dir + ); + if ($self->{XSMULTI}) { + for my $ext ($self->_xs_list_basenames) { + my ($v, $d, $f) = File::Spec->splitpath($ext); + my @d = File::Spec->splitdir($d); + shift @d if $d[0] eq 'lib'; + push @dirs, $self->catdir('$(INST_ARCHLIB)', 'auto', @d, $f); + } + } + + my @exists = map { $_.'$(DFSEP).exists' } @dirs; + + my $make = sprintf <<'MAKE', join(' ', @exists); + blibdirs : %s + $(NOECHO) $(NOOP) + + # Backwards compat with 6.18 through 6.25 + blibdirs.ts : blibdirs + $(NOECHO) $(NOOP) + + MAKE + + $make .= $self->dir_target(@dirs); + + return $make; + } + + + =head3 clean (o) + + Defines the clean target. + + =cut + + sub clean { + # --- Cleanup and Distribution Sections --- + + my($self, %attribs) = @_; + my @m; + push(@m, ' + # Delete temporary files but do not touch installed files. We don\'t delete + # the Makefile here so a later make realclean still has a makefile to use. + + clean :: clean_subdirs + '); + + my @files = sort values %{$self->{XS}}; # .c files from *.xs files + push @files, map { + my $file = $_; + map { $file.$_ } $self->{OBJ_EXT}, qw(.def _def.old .bs .bso .exp .base); + } $self->_xs_list_basenames; + my @dirs = qw(blib _eumm); + + # Normally these are all under blib but they might have been + # redefined. + # XXX normally this would be a good idea, but the Perl core sets + # INST_LIB = ../../lib rather than actually installing the files. + # So a "make clean" in an ext/ directory would blow away lib. + # Until the core is adjusted let's leave this out. + # push @dirs, qw($(INST_ARCHLIB) $(INST_LIB) + # $(INST_BIN) $(INST_SCRIPT) + # $(INST_MAN1DIR) $(INST_MAN3DIR) + # $(INST_LIBDIR) $(INST_ARCHLIBDIR) $(INST_AUTODIR) + # $(INST_STATIC) $(INST_DYNAMIC) + # ); + + + if( $attribs{FILES} ) { + # Use @dirs because we don't know what's in here. + push @dirs, ref $attribs{FILES} ? + @{$attribs{FILES}} : + split /\s+/, $attribs{FILES} ; + } + + push(@files, qw[$(MAKE_APERL_FILE) + MYMETA.json MYMETA.yml perlmain.c tmon.out mon.out so_locations + blibdirs.ts pm_to_blib pm_to_blib.ts + *$(OBJ_EXT) *$(LIB_EXT) perl.exe perl perl$(EXE_EXT) + $(BOOTSTRAP) $(BASEEXT).bso + $(BASEEXT).def lib$(BASEEXT).def + $(BASEEXT).exp $(BASEEXT).x + ]); + + push(@files, $self->catfile('$(INST_ARCHAUTODIR)','extralibs.all')); + push(@files, $self->catfile('$(INST_ARCHAUTODIR)','extralibs.ld')); + + # core files + if ($^O eq 'vos') { + push(@files, qw[perl*.kp]); + } + else { + push(@files, qw[core core.*perl.*.? *perl.core]); + } + + push(@files, map { "core." . "[0-9]"x$_ } (1..5)); + + # OS specific things to clean up. Use @dirs since we don't know + # what might be in here. + push @dirs, $self->extra_clean_files; + + # Occasionally files are repeated several times from different sources + { my(%f) = map { ($_ => 1) } @files; @files = sort keys %f; } + { my(%d) = map { ($_ => 1) } @dirs; @dirs = sort keys %d; } + + push @m, map "\t$_\n", $self->split_command('- $(RM_F)', @files); + push @m, map "\t$_\n", $self->split_command('- $(RM_RF)', @dirs); + + # Leave Makefile.old around for realclean + push @m, <<'MAKE'; + $(NOECHO) $(RM_F) $(MAKEFILE_OLD) + - $(MV) $(FIRST_MAKEFILE) $(MAKEFILE_OLD) $(DEV_NULL) + MAKE + + push(@m, "\t$attribs{POSTOP}\n") if $attribs{POSTOP}; + + join("", @m); + } + + + =head3 clean_subdirs_target + + my $make_frag = $MM->clean_subdirs_target; + + Returns the clean_subdirs target. This is used by the clean target to + call clean on any subdirectories which contain Makefiles. + + =cut + + sub clean_subdirs_target { + my($self) = shift; + + # No subdirectories, no cleaning. + return <<'NOOP_FRAG' unless @{$self->{DIR}}; + clean_subdirs : + $(NOECHO) $(NOOP) + NOOP_FRAG + + + my $clean = "clean_subdirs :\n"; + + for my $dir (@{$self->{DIR}}) { + my $subclean = $self->oneliner(sprintf <<'CODE', $dir); + exit 0 unless chdir '%s'; system '$(MAKE) clean' if -f '$(FIRST_MAKEFILE)'; + CODE + + $clean .= "\t$subclean\n"; + } + + return $clean; + } + + + =head3 dir_target + + my $make_frag = $mm->dir_target(@directories); + + Generates targets to create the specified directories and set its + permission to PERM_DIR. + + Because depending on a directory to just ensure it exists doesn't work + too well (the modified time changes too often) dir_target() creates a + .exists file in the created directory. It is this you should depend on. + For portability purposes you should use the $(DIRFILESEP) macro rather + than a '/' to separate the directory from the file. + + yourdirectory$(DIRFILESEP).exists + + =cut + + sub dir_target { + my($self, @dirs) = @_; + + my $make = ''; + foreach my $dir (@dirs) { + $make .= sprintf <<'MAKE', ($dir) x 4; + %s$(DFSEP).exists :: Makefile.PL + $(NOECHO) $(MKPATH) %s + $(NOECHO) $(CHMOD) $(PERM_DIR) %s + $(NOECHO) $(TOUCH) %s$(DFSEP).exists + + MAKE + + } + + return $make; + } + + + =head3 distdir + + Defines the scratch directory target that will hold the distribution + before tar-ing (or shar-ing). + + =cut + + # For backwards compatibility. + *dist_dir = *distdir; + + sub distdir { + my($self) = shift; + + my $meta_target = $self->{NO_META} ? '' : 'distmeta'; + my $sign_target = !$self->{SIGN} ? '' : 'distsignature'; + + return sprintf <<'MAKE_FRAG', $meta_target, $sign_target; + create_distdir : + $(RM_RF) $(DISTVNAME) + $(PERLRUN) "-MExtUtils::Manifest=manicopy,maniread" \ + -e "manicopy(maniread(),'$(DISTVNAME)', '$(DIST_CP)');" + + distdir : create_distdir %s %s + $(NOECHO) $(NOOP) + + MAKE_FRAG + + } + + + =head3 dist_test + + Defines a target that produces the distribution in the + scratch directory, and runs 'perl Makefile.PL; make ;make test' in that + subdirectory. + + =cut + + sub dist_test { + my($self) = shift; + + my $mpl_args = join " ", map qq["$_"], @ARGV; + + my $test = $self->cd('$(DISTVNAME)', + '$(ABSPERLRUN) Makefile.PL '.$mpl_args, + '$(MAKE) $(PASTHRU)', + '$(MAKE) test $(PASTHRU)' + ); + + return sprintf <<'MAKE_FRAG', $test; + disttest : distdir + %s + + MAKE_FRAG + + + } + + + =head3 xs_dlsyms_ext + + Returns file-extension for C method's output file, + including any "." character. + + =cut + + sub xs_dlsyms_ext { + die "Pure virtual method"; + } + + =head3 xs_dlsyms_extra + + Returns any extra text to be prepended to the C<$extra> argument of + C. + + =cut + + sub xs_dlsyms_extra { + ''; + } + + =head3 xs_dlsyms_iterator + + Iterates over necessary shared objects, calling C method + for each with appropriate arguments. + + =cut + + sub xs_dlsyms_iterator { + my ($self, $attribs) = @_; + if ($self->{XSMULTI}) { + my @m; + for my $ext ($self->_xs_list_basenames) { + my @parts = File::Spec->splitdir($ext); + shift @parts if $parts[0] eq 'lib'; + my $name = join '::', @parts; + push @m, $self->xs_make_dlsyms( + $attribs, + $ext . $self->xs_dlsyms_ext, + "$ext.xs", + $name, + $parts[-1], + {}, [], {}, [], + $self->xs_dlsyms_extra . q!, 'FILE' => ! . neatvalue($ext), + ); + } + return join "\n", @m; + } else { + return $self->xs_make_dlsyms( + $attribs, + $self->{BASEEXT} . $self->xs_dlsyms_ext, + 'Makefile.PL', + $self->{NAME}, + $self->{DLBASE}, + $attribs->{DL_FUNCS} || $self->{DL_FUNCS} || {}, + $attribs->{FUNCLIST} || $self->{FUNCLIST} || [], + $attribs->{IMPORTS} || $self->{IMPORTS} || {}, + $attribs->{DL_VARS} || $self->{DL_VARS} || [], + $self->xs_dlsyms_extra, + ); + } + } + + =head3 xs_make_dlsyms + + $self->xs_make_dlsyms( + \%attribs, # hashref from %attribs in caller + "$self->{BASEEXT}.def", # output file for Makefile target + 'Makefile.PL', # dependency + $self->{NAME}, # shared object's "name" + $self->{DLBASE}, # last ::-separated part of name + $attribs{DL_FUNCS} || $self->{DL_FUNCS} || {}, # various params + $attribs{FUNCLIST} || $self->{FUNCLIST} || [], + $attribs{IMPORTS} || $self->{IMPORTS} || {}, + $attribs{DL_VARS} || $self->{DL_VARS} || [], + # optional extra param that will be added as param to Mksymlists + ); + + Utility method that returns Makefile snippet to call C. + + =cut + + sub xs_make_dlsyms { + my ($self, $attribs, $target, $dep, $name, $dlbase, $funcs, $funclist, $imports, $vars, $extra) = @_; + my @m = ( + "\n$target: $dep\n", + q! $(PERLRUN) -MExtUtils::Mksymlists \\ + -e "Mksymlists('NAME'=>\"!, $name, + q!\", 'DLBASE' => '!,$dlbase, + # The above two lines quoted differently to work around + # a bug in the 4DOS/4NT command line interpreter. The visible + # result of the bug was files named q('extension_name',) *with the + # single quotes and the comma* in the extension build directories. + q!', 'DL_FUNCS' => !,neatvalue($funcs), + q!, 'FUNCLIST' => !,neatvalue($funclist), + q!, 'IMPORTS' => !,neatvalue($imports), + q!, 'DL_VARS' => !, neatvalue($vars) + ); + push @m, $extra if defined $extra; + push @m, qq!);"\n!; + join '', @m; + } + + =head3 dynamic (o) + + Defines the dynamic target. + + =cut + + sub dynamic { + # --- Dynamic Loading Sections --- + + my($self) = shift; + ' + dynamic :: $(FIRST_MAKEFILE) $(INST_BOOT) $(INST_DYNAMIC) + $(NOECHO) $(NOOP) + '; + } + + + =head3 makemakerdflt_target + + my $make_frag = $mm->makemakerdflt_target + + Returns a make fragment with the makemakerdeflt_target specified. + This target is the first target in the Makefile, is the default target + and simply points off to 'all' just in case any make variant gets + confused or something gets snuck in before the real 'all' target. + + =cut + + sub makemakerdflt_target { + return <<'MAKE_FRAG'; + makemakerdflt : all + $(NOECHO) $(NOOP) + MAKE_FRAG + + } + + + =head3 manifypods_target + + my $manifypods_target = $self->manifypods_target; + + Generates the manifypods target. This target generates man pages from + all POD files in MAN1PODS and MAN3PODS. + + =cut + + sub manifypods_target { + my($self) = shift; + + my $man1pods = ''; + my $man3pods = ''; + my $dependencies = ''; + + # populate manXpods & dependencies: + foreach my $name (sort keys %{$self->{MAN1PODS}}, sort keys %{$self->{MAN3PODS}}) { + $dependencies .= " \\\n\t$name"; + } + + my $manify = <{"MAN${section}PODS"}; + my $p2m = sprintf <<'CMD', $section, $] > 5.008 ? " -u" : ""; + $(NOECHO) $(POD2MAN) --section=%s --perm_rw=$(PERM_RW)%s + CMD + push @man_cmds, $self->split_command($p2m, map {($_,$pods->{$_})} sort keys %$pods); + } + + $manify .= "\t\$(NOECHO) \$(NOOP)\n" unless @man_cmds; + $manify .= join '', map { "$_\n" } @man_cmds; + + return $manify; + } + + sub _has_cpan_meta { + return eval { + require CPAN::Meta; + CPAN::Meta->VERSION(2.112150); + 1; + }; + } + + =head3 metafile_target + + my $target = $mm->metafile_target; + + Generate the metafile target. + + Writes the file META.yml (YAML encoded meta-data) and META.json + (JSON encoded meta-data) about the module in the distdir. + The format follows Module::Build's as closely as possible. + + =cut + + sub metafile_target { + my $self = shift; + return <<'MAKE_FRAG' if $self->{NO_META} or ! _has_cpan_meta(); + metafile : + $(NOECHO) $(NOOP) + MAKE_FRAG + + my $metadata = $self->metafile_data( + $self->{META_ADD} || {}, + $self->{META_MERGE} || {}, + ); + + my $meta = $self->_fix_metadata_before_conversion( $metadata ); + + my @write_metayml = $self->stashmeta( + $meta->as_string({version => "1.4"}), 'META_new.yml' + ); + my @write_metajson = $self->stashmeta( + $meta->as_string({version => "2.0"}), 'META_new.json' + ); + + my $metayml = join("\n\t", @write_metayml); + my $metajson = join("\n\t", @write_metajson); + return sprintf <<'MAKE_FRAG', $metayml, $metajson; + metafile : create_distdir + $(NOECHO) $(ECHO) Generating META.yml + %s + -$(NOECHO) $(MV) META_new.yml $(DISTVNAME)/META.yml + $(NOECHO) $(ECHO) Generating META.json + %s + -$(NOECHO) $(MV) META_new.json $(DISTVNAME)/META.json + MAKE_FRAG + + } + + =begin private + + =head3 _fix_metadata_before_conversion + + $mm->_fix_metadata_before_conversion( \%metadata ); + + Fixes errors in the metadata before it's handed off to CPAN::Meta for + conversion. This hopefully results in something that can be used further + on, no guarantee is made though. + + =end private + + =cut + + sub _fix_metadata_before_conversion { + my ( $self, $metadata ) = @_; + + # we should never be called unless this already passed but + # prefer to be defensive in case somebody else calls this + + return unless _has_cpan_meta; + + my $bad_version = $metadata->{version} && + !CPAN::Meta::Validator->new->version( 'version', $metadata->{version} ); + # just delete all invalid versions + if( $bad_version ) { + warn "Can't parse version '$metadata->{version}'\n"; + $metadata->{version} = ''; + } + + my $validator2 = CPAN::Meta::Validator->new( $metadata ); + my @errors; + push @errors, $validator2->errors if !$validator2->is_valid; + my $validator14 = CPAN::Meta::Validator->new( + { + %$metadata, + 'meta-spec' => { version => 1.4 }, + } + ); + push @errors, $validator14->errors if !$validator14->is_valid; + # fix non-camelcase custom resource keys (only other trick we know) + for my $error ( @errors ) { + my ( $key ) = ( $error =~ /Custom resource '(.*)' must be in CamelCase./ ); + next if !$key; + + # first try to remove all non-alphabetic chars + ( my $new_key = $key ) =~ s/[^_a-zA-Z]//g; + + # if that doesn't work, uppercase first one + $new_key = ucfirst $new_key if !$validator14->custom_1( $new_key ); + + # copy to new key if that worked + $metadata->{resources}{$new_key} = $metadata->{resources}{$key} + if $validator14->custom_1( $new_key ); + + # and delete old one in any case + delete $metadata->{resources}{$key}; + } + + # paper over validation issues, but still complain, necessary because + # there's no guarantee that the above will fix ALL errors + my $meta = eval { CPAN::Meta->create( $metadata, { lazy_validation => 1 } ) }; + warn $@ if $@ and + $@ !~ /encountered CODE.*, but JSON can only represent references to arrays or hashes/; + + # use the original metadata straight if the conversion failed + # or if it can't be stringified. + if( !$meta || + !eval { $meta->as_string( { version => $METASPEC_V } ) } || + !eval { $meta->as_string } + ) { + $meta = bless $metadata, 'CPAN::Meta'; + } + + my $now_license = $meta->as_struct({ version => 2 })->{license}; + if ($self->{LICENSE} and $self->{LICENSE} ne 'unknown' and + @{$now_license} == 1 and $now_license->[0] eq 'unknown' + ) { + warn "Invalid LICENSE value '$self->{LICENSE}' ignored\n"; + } + + $meta; + } + + + =begin private + + =head3 _sort_pairs + + my @pairs = _sort_pairs($sort_sub, \%hash); + + Sorts the pairs of a hash based on keys ordered according + to C<$sort_sub>. + + =end private + + =cut + + sub _sort_pairs { + my $sort = shift; + my $pairs = shift; + return map { $_ => $pairs->{$_} } + sort $sort + keys %$pairs; + } + + + # Taken from Module::Build::Base + sub _hash_merge { + my ($self, $h, $k, $v) = @_; + if (ref $h->{$k} eq 'ARRAY') { + push @{$h->{$k}}, ref $v ? @$v : $v; + } elsif (ref $h->{$k} eq 'HASH') { + $self->_hash_merge($h->{$k}, $_, $v->{$_}) foreach keys %$v; + } else { + $h->{$k} = $v; + } + } + + + =head3 metafile_data + + my $metadata_hashref = $mm->metafile_data(\%meta_add, \%meta_merge); + + Returns the data which MakeMaker turns into the META.yml file + and the META.json file. It is always in version 2.0 of the format. + + Values of %meta_add will overwrite any existing metadata in those + keys. %meta_merge will be merged with them. + + =cut + + sub metafile_data { + my $self = shift; + my($meta_add, $meta_merge) = @_; + + $meta_add ||= {}; + $meta_merge ||= {}; + + my $version = _normalize_version($self->{VERSION}); + my $release_status = ($version =~ /_/) ? 'unstable' : 'stable'; + my %meta = ( + # required + abstract => $self->{ABSTRACT} || 'unknown', + author => defined($self->{AUTHOR}) ? $self->{AUTHOR} : ['unknown'], + dynamic_config => 1, + generated_by => "ExtUtils::MakeMaker version $ExtUtils::MakeMaker::VERSION", + license => [ $self->{LICENSE} || 'unknown' ], + 'meta-spec' => { + url => $METASPEC_URL, + version => $METASPEC_V, + }, + name => $self->{DISTNAME}, + release_status => $release_status, + version => $version, + + # optional + no_index => { directory => [qw(t inc)] }, + ); + $self->_add_requirements_to_meta(\%meta); + + if (!eval { require JSON::PP; require CPAN::Meta::Converter; CPAN::Meta::Converter->VERSION(2.141170) }) { + return \%meta; + } + + # needs to be based on the original version + my $v1_add = _metaspec_version($meta_add) !~ /^2/; + + for my $frag ($meta_add, $meta_merge) { + $frag = CPAN::Meta::Converter->new($frag, default_version => "1.4")->upgrade_fragment; + } + + # if we upgraded a 1.x _ADD fragment, we gave it a prereqs key that + # will override all prereqs, which is more than the user asked for; + # instead, we'll go inside the prereqs and override all those + while( my($key, $val) = each %$meta_add ) { + if ($v1_add and $key eq 'prereqs') { + $meta{$key}{$_} = $val->{$_} for keys %$val; + } elsif ($key ne 'meta-spec') { + $meta{$key} = $val; + } + } + + while( my($key, $val) = each %$meta_merge ) { + next if $key eq 'meta-spec'; + $self->_hash_merge(\%meta, $key, $val); + } + + return \%meta; + } + + + =begin private + + =cut + + sub _add_requirements_to_meta { + my ( $self, $meta ) = @_; + # Check the original args so we can tell between the user setting it + # to an empty hash and it just being initialized. + $meta->{prereqs}{configure}{requires} = $self->{ARGS}{CONFIGURE_REQUIRES} + ? $self->{CONFIGURE_REQUIRES} + : { 'ExtUtils::MakeMaker' => 0, }; + $meta->{prereqs}{build}{requires} = $self->{ARGS}{BUILD_REQUIRES} + ? $self->{BUILD_REQUIRES} + : { 'ExtUtils::MakeMaker' => 0, }; + $meta->{prereqs}{test}{requires} = $self->{TEST_REQUIRES} + if $self->{ARGS}{TEST_REQUIRES}; + $meta->{prereqs}{runtime}{requires} = $self->{PREREQ_PM} + if $self->{ARGS}{PREREQ_PM}; + $meta->{prereqs}{runtime}{requires}{perl} = _normalize_version($self->{MIN_PERL_VERSION}) + if $self->{MIN_PERL_VERSION}; + } + + # spec version of given fragment - if not given, assume 1.4 + sub _metaspec_version { + my ( $meta ) = @_; + return $meta->{'meta-spec'}->{version} + if defined $meta->{'meta-spec'} + and defined $meta->{'meta-spec'}->{version}; + return '1.4'; + } + + sub _add_requirements_to_meta_v1_4 { + my ( $self, $meta ) = @_; + # Check the original args so we can tell between the user setting it + # to an empty hash and it just being initialized. + if( $self->{ARGS}{CONFIGURE_REQUIRES} ) { + $meta->{configure_requires} = $self->{CONFIGURE_REQUIRES}; + } else { + $meta->{configure_requires} = { + 'ExtUtils::MakeMaker' => 0, + }; + } + if( $self->{ARGS}{BUILD_REQUIRES} ) { + $meta->{build_requires} = $self->{BUILD_REQUIRES}; + } else { + $meta->{build_requires} = { + 'ExtUtils::MakeMaker' => 0, + }; + } + if( $self->{ARGS}{TEST_REQUIRES} ) { + $meta->{build_requires} = { + %{ $meta->{build_requires} }, + %{ $self->{TEST_REQUIRES} }, + }; + } + $meta->{requires} = $self->{PREREQ_PM} + if defined $self->{PREREQ_PM}; + $meta->{requires}{perl} = _normalize_version($self->{MIN_PERL_VERSION}) + if $self->{MIN_PERL_VERSION}; + } + + # Adapted from Module::Build::Base + sub _normalize_version { + my ($version) = @_; + $version = 0 unless defined $version; + + if ( ref $version eq 'version' ) { # version objects + $version = $version->stringify; + } + elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots + # normalize string tuples without "v": "1.2.3" -> "v1.2.3" + $version = "v$version"; + } + else { + # leave alone + } + return $version; + } + + =head3 _dump_hash + + $yaml = _dump_hash(\%options, %hash); + + Implements a fake YAML dumper for a hash given + as a list of pairs. No quoting/escaping is done. Keys + are supposed to be strings. Values are undef, strings, + hash refs or array refs of strings. + + Supported options are: + + delta => STR - indentation delta + use_header => BOOL - whether to include a YAML header + indent => STR - a string of spaces + default: '' + + max_key_length => INT - maximum key length used to align + keys and values of the same hash + default: 20 + key_sort => CODE - a sort sub + It may be undef, which means no sorting by keys + default: sub { lc $a cmp lc $b } + + customs => HASH - special options for certain keys + (whose values are hashes themselves) + may contain: max_key_length, key_sort, customs + + =end private + + =cut + + sub _dump_hash { + croak "first argument should be a hash ref" unless ref $_[0] eq 'HASH'; + my $options = shift; + my %hash = @_; + + # Use a list to preserve order. + my @pairs; + + my $k_sort + = exists $options->{key_sort} ? $options->{key_sort} + : sub { lc $a cmp lc $b }; + if ($k_sort) { + croak "'key_sort' should be a coderef" unless ref $k_sort eq 'CODE'; + @pairs = _sort_pairs($k_sort, \%hash); + } else { # list of pairs, no sorting + @pairs = @_; + } + + my $yaml = $options->{use_header} ? "--- #YAML:1.0\n" : ''; + my $indent = $options->{indent} || ''; + my $k_length = min( + ($options->{max_key_length} || 20), + max(map { length($_) + 1 } grep { !ref $hash{$_} } keys %hash) + ); + my $customs = $options->{customs} || {}; + + # printf format for key + my $k_format = "%-${k_length}s"; + + while( @pairs ) { + my($key, $val) = splice @pairs, 0, 2; + $val = '~' unless defined $val; + if(ref $val eq 'HASH') { + if ( keys %$val ) { + my %k_options = ( # options for recursive call + delta => $options->{delta}, + use_header => 0, + indent => $indent . $options->{delta}, + ); + if (exists $customs->{$key}) { + my %k_custom = %{$customs->{$key}}; + foreach my $k (qw(key_sort max_key_length customs)) { + $k_options{$k} = $k_custom{$k} if exists $k_custom{$k}; + } + } + $yaml .= $indent . "$key:\n" + . _dump_hash(\%k_options, %$val); + } + else { + $yaml .= $indent . "$key: {}\n"; + } + } + elsif (ref $val eq 'ARRAY') { + if( @$val ) { + $yaml .= $indent . "$key:\n"; + + for (@$val) { + croak "only nested arrays of non-refs are supported" if ref $_; + $yaml .= $indent . $options->{delta} . "- $_\n"; + } + } + else { + $yaml .= $indent . "$key: []\n"; + } + } + elsif( ref $val and !blessed($val) ) { + croak "only nested hashes, arrays and objects are supported"; + } + else { # if it's an object, just stringify it + $yaml .= $indent . sprintf "$k_format %s\n", "$key:", $val; + } + }; + + return $yaml; + + } + + sub blessed { + return eval { $_[0]->isa("UNIVERSAL"); }; + } + + sub max { + return (sort { $b <=> $a } @_)[0]; + } + + sub min { + return (sort { $a <=> $b } @_)[0]; + } + + =head3 metafile_file + + my $meta_yml = $mm->metafile_file(@metadata_pairs); + + Turns the @metadata_pairs into YAML. + + This method does not implement a complete YAML dumper, being limited + to dump a hash with values which are strings, undef's or nested hashes + and arrays of strings. No quoting/escaping is done. + + =cut + + sub metafile_file { + my $self = shift; + + my %dump_options = ( + use_header => 1, + delta => ' ' x 4, + key_sort => undef, + ); + return _dump_hash(\%dump_options, @_); + + } + + + =head3 distmeta_target + + my $make_frag = $mm->distmeta_target; + + Generates the distmeta target to add META.yml and META.json to the MANIFEST + in the distdir. + + =cut + + sub distmeta_target { + my $self = shift; + + my @add_meta = ( + $self->oneliner(<<'CODE', ['-MExtUtils::Manifest=maniadd']), + exit unless -e q{META.yml}; + eval { maniadd({q{META.yml} => q{Module YAML meta-data (added by MakeMaker)}}) } + or die "Could not add META.yml to MANIFEST: ${'@'}" + CODE + $self->oneliner(<<'CODE', ['-MExtUtils::Manifest=maniadd']) + exit unless -f q{META.json}; + eval { maniadd({q{META.json} => q{Module JSON meta-data (added by MakeMaker)}}) } + or die "Could not add META.json to MANIFEST: ${'@'}" + CODE + ); + + my @add_meta_to_distdir = map { $self->cd('$(DISTVNAME)', $_) } @add_meta; + + return sprintf <<'MAKE', @add_meta_to_distdir; + distmeta : create_distdir metafile + $(NOECHO) %s + $(NOECHO) %s + + MAKE + + } + + + =head3 mymeta + + my $mymeta = $mm->mymeta; + + Generate MYMETA information as a hash either from an existing CPAN Meta file + (META.json or META.yml) or from internal data. + + =cut + + sub mymeta { + my $self = shift; + my $file = shift || ''; # for testing + + my $mymeta = $self->_mymeta_from_meta($file); + my $v2 = 1; + + unless ( $mymeta ) { + $mymeta = $self->metafile_data( + $self->{META_ADD} || {}, + $self->{META_MERGE} || {}, + ); + $v2 = 0; + } + + # Overwrite the non-configure dependency hashes + $self->_add_requirements_to_meta($mymeta); + + $mymeta->{dynamic_config} = 0; + + return $mymeta; + } + + + sub _mymeta_from_meta { + my $self = shift; + my $metafile = shift || ''; # for testing + + return unless _has_cpan_meta(); + + my $meta; + for my $file ( $metafile, "META.json", "META.yml" ) { + next unless -e $file; + eval { + $meta = CPAN::Meta->load_file($file)->as_struct( { version => 2 } ); + }; + last if $meta; + } + return unless $meta; + + # META.yml before 6.25_01 cannot be trusted. META.yml lived in the source directory. + # There was a good chance the author accidentally uploaded a stale META.yml if they + # rolled their own tarball rather than using "make dist". + if ($meta->{generated_by} && + $meta->{generated_by} =~ /ExtUtils::MakeMaker version ([\d\._]+)/) { + my $eummv = do { local $^W = 0; $1+0; }; + if ($eummv < 6.2501) { + return; + } + } + + return $meta; + } + + =head3 write_mymeta + + $self->write_mymeta( $mymeta ); + + Write MYMETA information to MYMETA.json and MYMETA.yml. + + =cut + + sub write_mymeta { + my $self = shift; + my $mymeta = shift; + + return unless _has_cpan_meta(); + + my $meta_obj = $self->_fix_metadata_before_conversion( $mymeta ); + + $meta_obj->save( 'MYMETA.json', { version => "2.0" } ); + $meta_obj->save( 'MYMETA.yml', { version => "1.4" } ); + return 1; + } + + =head3 realclean (o) + + Defines the realclean target. + + =cut + + sub realclean { + my($self, %attribs) = @_; + + my @dirs = qw($(DISTVNAME)); + my @files = qw($(FIRST_MAKEFILE) $(MAKEFILE_OLD)); + + # Special exception for the perl core where INST_* is not in blib. + # This cleans up the files built from the ext/ directory (all XS). + if( $self->{PERL_CORE} ) { + push @dirs, qw($(INST_AUTODIR) $(INST_ARCHAUTODIR)); + push @files, values %{$self->{PM}}; + } + + if( $self->has_link_code ){ + push @files, qw($(OBJECT)); + } + + if( $attribs{FILES} ) { + if( ref $attribs{FILES} ) { + push @dirs, @{ $attribs{FILES} }; + } + else { + push @dirs, split /\s+/, $attribs{FILES}; + } + } + + # Occasionally files are repeated several times from different sources + { my(%f) = map { ($_ => 1) } @files; @files = sort keys %f; } + { my(%d) = map { ($_ => 1) } @dirs; @dirs = sort keys %d; } + + my $rm_cmd = join "\n\t", map { "$_" } + $self->split_command('- $(RM_F)', @files); + my $rmf_cmd = join "\n\t", map { "$_" } + $self->split_command('- $(RM_RF)', @dirs); + + my $m = sprintf <<'MAKE', $rm_cmd, $rmf_cmd; + # Delete temporary files (via clean) and also delete dist files + realclean purge :: realclean_subdirs + %s + %s + MAKE + + $m .= "\t$attribs{POSTOP}\n" if $attribs{POSTOP}; + + return $m; + } + + + =head3 realclean_subdirs_target + + my $make_frag = $MM->realclean_subdirs_target; + + Returns the realclean_subdirs target. This is used by the realclean + target to call realclean on any subdirectories which contain Makefiles. + + =cut + + sub realclean_subdirs_target { + my $self = shift; + my @m = <<'EOF'; + # so clean is forced to complete before realclean_subdirs runs + realclean_subdirs : clean + EOF + return join '', @m, "\t\$(NOECHO) \$(NOOP)\n" unless @{$self->{DIR}}; + foreach my $dir (@{$self->{DIR}}) { + foreach my $makefile ('$(MAKEFILE_OLD)', '$(FIRST_MAKEFILE)' ) { + my $subrclean .= $self->oneliner(_sprintf562 <<'CODE', $dir, $makefile); + chdir '%1$s'; system '$(MAKE) $(USEMAKEFILE) %2$s realclean' if -f '%2$s'; + CODE + push @m, "\t- $subrclean\n"; + } + } + return join '', @m; + } + + + =head3 signature_target + + my $target = $mm->signature_target; + + Generate the signature target. + + Writes the file SIGNATURE with "cpansign -s". + + =cut + + sub signature_target { + my $self = shift; + + return <<'MAKE_FRAG'; + signature : + cpansign -s + MAKE_FRAG + + } + + + =head3 distsignature_target + + my $make_frag = $mm->distsignature_target; + + Generates the distsignature target to add SIGNATURE to the MANIFEST in the + distdir. + + =cut + + sub distsignature_target { + my $self = shift; + + my $add_sign = $self->oneliner(<<'CODE', ['-MExtUtils::Manifest=maniadd']); + eval { maniadd({q{SIGNATURE} => q{Public-key signature (added by MakeMaker)}}) } + or die "Could not add SIGNATURE to MANIFEST: ${'@'}" + CODE + + my $sign_dist = $self->cd('$(DISTVNAME)' => 'cpansign -s'); + + # cpansign -s complains if SIGNATURE is in the MANIFEST yet does not + # exist + my $touch_sig = $self->cd('$(DISTVNAME)' => '$(TOUCH) SIGNATURE'); + my $add_sign_to_dist = $self->cd('$(DISTVNAME)' => $add_sign ); + + return sprintf <<'MAKE', $add_sign_to_dist, $touch_sig, $sign_dist + distsignature : distmeta + $(NOECHO) %s + $(NOECHO) %s + %s + + MAKE + + } + + + =head3 special_targets + + my $make_frag = $mm->special_targets + + Returns a make fragment containing any targets which have special + meaning to make. For example, .SUFFIXES and .PHONY. + + =cut + + sub special_targets { + my $make_frag = <<'MAKE_FRAG'; + .SUFFIXES : .xs .c .C .cpp .i .s .cxx .cc $(OBJ_EXT) + + .PHONY: all config static dynamic test linkext manifest blibdirs clean realclean disttest distdir pure_all subdirs clean_subdirs makemakerdflt manifypods realclean_subdirs subdirs_dynamic subdirs_pure_nolink subdirs_static subdirs-test_dynamic subdirs-test_static test_dynamic test_static + + MAKE_FRAG + + $make_frag .= <<'MAKE_FRAG' if $ENV{CLEARCASE_ROOT}; + .NO_CONFIG_REC: Makefile + + MAKE_FRAG + + return $make_frag; + } + + + + + =head2 Init methods + + Methods which help initialize the MakeMaker object and macros. + + + =head3 init_ABSTRACT + + $mm->init_ABSTRACT + + =cut + + sub init_ABSTRACT { + my $self = shift; + + if( $self->{ABSTRACT_FROM} and $self->{ABSTRACT} ) { + warn "Both ABSTRACT_FROM and ABSTRACT are set. ". + "Ignoring ABSTRACT_FROM.\n"; + return; + } + + if ($self->{ABSTRACT_FROM}){ + $self->{ABSTRACT} = $self->parse_abstract($self->{ABSTRACT_FROM}) or + carp "WARNING: Setting ABSTRACT via file ". + "'$self->{ABSTRACT_FROM}' failed\n"; + } + + if ($self->{ABSTRACT} && $self->{ABSTRACT} =~ m![[:cntrl:]]+!) { + warn "WARNING: ABSTRACT contains control character(s),". + " they will be removed\n"; + $self->{ABSTRACT} =~ s![[:cntrl:]]+!!g; + return; + } + } + + =head3 init_INST + + $mm->init_INST; + + Called by init_main. Sets up all INST_* variables except those related + to XS code. Those are handled in init_xs. + + =cut + + sub init_INST { + my($self) = shift; + + $self->{INST_ARCHLIB} ||= $self->catdir($Curdir,"blib","arch"); + $self->{INST_BIN} ||= $self->catdir($Curdir,'blib','bin'); + + # INST_LIB typically pre-set if building an extension after + # perl has been built and installed. Setting INST_LIB allows + # you to build directly into, say $Config{privlibexp}. + unless ($self->{INST_LIB}){ + if ($self->{PERL_CORE}) { + $self->{INST_LIB} = $self->{INST_ARCHLIB} = $self->{PERL_LIB}; + } else { + $self->{INST_LIB} = $self->catdir($Curdir,"blib","lib"); + } + } + + my @parentdir = split(/::/, $self->{PARENT_NAME}); + $self->{INST_LIBDIR} = $self->catdir('$(INST_LIB)', @parentdir); + $self->{INST_ARCHLIBDIR} = $self->catdir('$(INST_ARCHLIB)', @parentdir); + $self->{INST_AUTODIR} = $self->catdir('$(INST_LIB)', 'auto', + '$(FULLEXT)'); + $self->{INST_ARCHAUTODIR} = $self->catdir('$(INST_ARCHLIB)', 'auto', + '$(FULLEXT)'); + + $self->{INST_SCRIPT} ||= $self->catdir($Curdir,'blib','script'); + + $self->{INST_MAN1DIR} ||= $self->catdir($Curdir,'blib','man1'); + $self->{INST_MAN3DIR} ||= $self->catdir($Curdir,'blib','man3'); + + return 1; + } + + + =head3 init_INSTALL + + $mm->init_INSTALL; + + Called by init_main. Sets up all INSTALL_* variables (except + INSTALLDIRS) and *PREFIX. + + =cut + + sub init_INSTALL { + my($self) = shift; + + if( $self->{ARGS}{INSTALL_BASE} and $self->{ARGS}{PREFIX} ) { + die "Only one of PREFIX or INSTALL_BASE can be given. Not both.\n"; + } + + if( $self->{ARGS}{INSTALL_BASE} ) { + $self->init_INSTALL_from_INSTALL_BASE; + } + else { + $self->init_INSTALL_from_PREFIX; + } + } + + + =head3 init_INSTALL_from_PREFIX + + $mm->init_INSTALL_from_PREFIX; + + =cut + + sub init_INSTALL_from_PREFIX { + my $self = shift; + + $self->init_lib2arch; + + # There are often no Config.pm defaults for these new man variables so + # we fall back to the old behavior which is to use installman*dir + foreach my $num (1, 3) { + my $k = 'installsiteman'.$num.'dir'; + + $self->{uc $k} ||= uc "\$(installman${num}dir)" + unless $Config{$k}; + } + + foreach my $num (1, 3) { + my $k = 'installvendorman'.$num.'dir'; + + unless( $Config{$k} ) { + $self->{uc $k} ||= $Config{usevendorprefix} + ? uc "\$(installman${num}dir)" + : ''; + } + } + + $self->{INSTALLSITEBIN} ||= '$(INSTALLBIN)' + unless $Config{installsitebin}; + $self->{INSTALLSITESCRIPT} ||= '$(INSTALLSCRIPT)' + unless $Config{installsitescript}; + + unless( $Config{installvendorbin} ) { + $self->{INSTALLVENDORBIN} ||= $Config{usevendorprefix} + ? $Config{installbin} + : ''; + } + unless( $Config{installvendorscript} ) { + $self->{INSTALLVENDORSCRIPT} ||= $Config{usevendorprefix} + ? $Config{installscript} + : ''; + } + + + my $iprefix = $Config{installprefixexp} || $Config{installprefix} || + $Config{prefixexp} || $Config{prefix} || ''; + my $vprefix = $Config{usevendorprefix} ? $Config{vendorprefixexp} : ''; + my $sprefix = $Config{siteprefixexp} || ''; + + # 5.005_03 doesn't have a siteprefix. + $sprefix = $iprefix unless $sprefix; + + + $self->{PREFIX} ||= ''; + + if( $self->{PREFIX} ) { + @{$self}{qw(PERLPREFIX SITEPREFIX VENDORPREFIX)} = + ('$(PREFIX)') x 3; + } + else { + $self->{PERLPREFIX} ||= $iprefix; + $self->{SITEPREFIX} ||= $sprefix; + $self->{VENDORPREFIX} ||= $vprefix; + + # Lots of MM extension authors like to use $(PREFIX) so we + # put something sensible in there no matter what. + $self->{PREFIX} = '$('.uc $self->{INSTALLDIRS}.'PREFIX)'; + } + + my $arch = $Config{archname}; + my $version = $Config{version}; + + # default style + my $libstyle = $Config{installstyle} || 'lib/perl5'; + my $manstyle = ''; + + if( $self->{LIBSTYLE} ) { + $libstyle = $self->{LIBSTYLE}; + $manstyle = $self->{LIBSTYLE} eq 'lib/perl5' ? 'lib/perl5' : ''; + } + + # Some systems, like VOS, set installman*dir to '' if they can't + # read man pages. + for my $num (1, 3) { + $self->{'INSTALLMAN'.$num.'DIR'} ||= 'none' + unless $Config{'installman'.$num.'dir'}; + } + + my %bin_layouts = + ( + bin => { s => $iprefix, + t => 'perl', + d => 'bin' }, + vendorbin => { s => $vprefix, + t => 'vendor', + d => 'bin' }, + sitebin => { s => $sprefix, + t => 'site', + d => 'bin' }, + script => { s => $iprefix, + t => 'perl', + d => 'bin' }, + vendorscript=> { s => $vprefix, + t => 'vendor', + d => 'bin' }, + sitescript => { s => $sprefix, + t => 'site', + d => 'bin' }, + ); + + my %man_layouts = + ( + man1dir => { s => $iprefix, + t => 'perl', + d => 'man/man1', + style => $manstyle, }, + siteman1dir => { s => $sprefix, + t => 'site', + d => 'man/man1', + style => $manstyle, }, + vendorman1dir => { s => $vprefix, + t => 'vendor', + d => 'man/man1', + style => $manstyle, }, + + man3dir => { s => $iprefix, + t => 'perl', + d => 'man/man3', + style => $manstyle, }, + siteman3dir => { s => $sprefix, + t => 'site', + d => 'man/man3', + style => $manstyle, }, + vendorman3dir => { s => $vprefix, + t => 'vendor', + d => 'man/man3', + style => $manstyle, }, + ); + + my %lib_layouts = + ( + privlib => { s => $iprefix, + t => 'perl', + d => '', + style => $libstyle, }, + vendorlib => { s => $vprefix, + t => 'vendor', + d => '', + style => $libstyle, }, + sitelib => { s => $sprefix, + t => 'site', + d => 'site_perl', + style => $libstyle, }, + + archlib => { s => $iprefix, + t => 'perl', + d => "$version/$arch", + style => $libstyle }, + vendorarch => { s => $vprefix, + t => 'vendor', + d => "$version/$arch", + style => $libstyle }, + sitearch => { s => $sprefix, + t => 'site', + d => "site_perl/$version/$arch", + style => $libstyle }, + ); + + + # Special case for LIB. + if( $self->{LIB} ) { + foreach my $var (keys %lib_layouts) { + my $Installvar = uc "install$var"; + + if( $var =~ /arch/ ) { + $self->{$Installvar} ||= + $self->catdir($self->{LIB}, $Config{archname}); + } + else { + $self->{$Installvar} ||= $self->{LIB}; + } + } + } + + my %type2prefix = ( perl => 'PERLPREFIX', + site => 'SITEPREFIX', + vendor => 'VENDORPREFIX' + ); + + my %layouts = (%bin_layouts, %man_layouts, %lib_layouts); + while( my($var, $layout) = each(%layouts) ) { + my($s, $t, $d, $style) = @{$layout}{qw(s t d style)}; + my $r = '$('.$type2prefix{$t}.')'; + + warn "Prefixing $var\n" if $Verbose >= 2; + + my $installvar = "install$var"; + my $Installvar = uc $installvar; + next if $self->{$Installvar}; + + $d = "$style/$d" if $style; + $self->prefixify($installvar, $s, $r, $d); + + warn " $Installvar == $self->{$Installvar}\n" + if $Verbose >= 2; + } + + # Generate these if they weren't figured out. + $self->{VENDORARCHEXP} ||= $self->{INSTALLVENDORARCH}; + $self->{VENDORLIBEXP} ||= $self->{INSTALLVENDORLIB}; + + return 1; + } + + + =head3 init_from_INSTALL_BASE + + $mm->init_from_INSTALL_BASE + + =cut + + my %map = ( + lib => [qw(lib perl5)], + arch => [('lib', 'perl5', $Config{archname})], + bin => [qw(bin)], + man1dir => [qw(man man1)], + man3dir => [qw(man man3)] + ); + $map{script} = $map{bin}; + + sub init_INSTALL_from_INSTALL_BASE { + my $self = shift; + + @{$self}{qw(PREFIX VENDORPREFIX SITEPREFIX PERLPREFIX)} = + '$(INSTALL_BASE)'; + + my %install; + foreach my $thing (keys %map) { + foreach my $dir (('', 'SITE', 'VENDOR')) { + my $uc_thing = uc $thing; + my $key = "INSTALL".$dir.$uc_thing; + + $install{$key} ||= + $self->catdir('$(INSTALL_BASE)', @{$map{$thing}}); + } + } + + # Adjust for variable quirks. + $install{INSTALLARCHLIB} ||= delete $install{INSTALLARCH}; + $install{INSTALLPRIVLIB} ||= delete $install{INSTALLLIB}; + + foreach my $key (keys %install) { + $self->{$key} ||= $install{$key}; + } + + return 1; + } + + + =head3 init_VERSION I + + $mm->init_VERSION + + Initialize macros representing versions of MakeMaker and other tools + + MAKEMAKER: path to the MakeMaker module. + + MM_VERSION: ExtUtils::MakeMaker Version + + MM_REVISION: ExtUtils::MakeMaker version control revision (for backwards + compat) + + VERSION: version of your module + + VERSION_MACRO: which macro represents the version (usually 'VERSION') + + VERSION_SYM: like version but safe for use as an RCS revision number + + DEFINE_VERSION: -D line to set the module version when compiling + + XS_VERSION: version in your .xs file. Defaults to $(VERSION) + + XS_VERSION_MACRO: which macro represents the XS version. + + XS_DEFINE_VERSION: -D line to set the xs version when compiling. + + Called by init_main. + + =cut + + sub init_VERSION { + my($self) = shift; + + $self->{MAKEMAKER} = $ExtUtils::MakeMaker::Filename; + $self->{MM_VERSION} = $ExtUtils::MakeMaker::VERSION; + $self->{MM_REVISION}= $ExtUtils::MakeMaker::Revision; + $self->{VERSION_FROM} ||= ''; + + if ($self->{VERSION_FROM}){ + $self->{VERSION} = $self->parse_version($self->{VERSION_FROM}); + if( $self->{VERSION} eq 'undef' ) { + carp("WARNING: Setting VERSION via file ". + "'$self->{VERSION_FROM}' failed\n"); + } + } + + if (defined $self->{VERSION}) { + if ( $self->{VERSION} !~ /^\s*v?[\d_\.]+\s*$/ ) { + require version; + my $normal = eval { version->new( $self->{VERSION} ) }; + $self->{VERSION} = $normal if defined $normal; + } + $self->{VERSION} =~ s/^\s+//; + $self->{VERSION} =~ s/\s+$//; + } + else { + $self->{VERSION} = ''; + } + + + $self->{VERSION_MACRO} = 'VERSION'; + ($self->{VERSION_SYM} = $self->{VERSION}) =~ s/\W/_/g; + $self->{DEFINE_VERSION} = '-D$(VERSION_MACRO)=\"$(VERSION)\"'; + + + # Graham Barr and Paul Marquess had some ideas how to ensure + # version compatibility between the *.pm file and the + # corresponding *.xs file. The bottom line was, that we need an + # XS_VERSION macro that defaults to VERSION: + $self->{XS_VERSION} ||= $self->{VERSION}; + + $self->{XS_VERSION_MACRO} = 'XS_VERSION'; + $self->{XS_DEFINE_VERSION} = '-D$(XS_VERSION_MACRO)=\"$(XS_VERSION)\"'; + + } + + + =head3 init_tools + + $MM->init_tools(); + + Initializes the simple macro definitions used by tools_other() and + places them in the $MM object. These use conservative cross platform + versions and should be overridden with platform specific versions for + performance. + + Defines at least these macros. + + Macro Description + + NOOP Do nothing + NOECHO Tell make not to display the command itself + + SHELL Program used to run shell commands + + ECHO Print text adding a newline on the end + RM_F Remove a file + RM_RF Remove a directory + TOUCH Update a file's timestamp + TEST_F Test for a file's existence + TEST_S Test the size of a file + CP Copy a file + CP_NONEMPTY Copy a file if it is not empty + MV Move a file + CHMOD Change permissions on a file + FALSE Exit with non-zero + TRUE Exit with zero + + UMASK_NULL Nullify umask + DEV_NULL Suppress all command output + + =cut + + sub init_tools { + my $self = shift; + + $self->{ECHO} ||= $self->oneliner('binmode STDOUT, qq{:raw}; print qq{@ARGV}', ['-l']); + $self->{ECHO_N} ||= $self->oneliner('print qq{@ARGV}'); + + $self->{TOUCH} ||= $self->oneliner('touch', ["-MExtUtils::Command"]); + $self->{CHMOD} ||= $self->oneliner('chmod', ["-MExtUtils::Command"]); + $self->{RM_F} ||= $self->oneliner('rm_f', ["-MExtUtils::Command"]); + $self->{RM_RF} ||= $self->oneliner('rm_rf', ["-MExtUtils::Command"]); + $self->{TEST_F} ||= $self->oneliner('test_f', ["-MExtUtils::Command"]); + $self->{TEST_S} ||= $self->oneliner('test_s', ["-MExtUtils::Command::MM"]); + $self->{CP_NONEMPTY} ||= $self->oneliner('cp_nonempty', ["-MExtUtils::Command::MM"]); + $self->{FALSE} ||= $self->oneliner('exit 1'); + $self->{TRUE} ||= $self->oneliner('exit 0'); + + $self->{MKPATH} ||= $self->oneliner('mkpath', ["-MExtUtils::Command"]); + + $self->{CP} ||= $self->oneliner('cp', ["-MExtUtils::Command"]); + $self->{MV} ||= $self->oneliner('mv', ["-MExtUtils::Command"]); + + $self->{MOD_INSTALL} ||= + $self->oneliner(<<'CODE', ['-MExtUtils::Install']); + install([ from_to => {@ARGV}, verbose => '$(VERBINST)', uninstall_shadows => '$(UNINST)', dir_mode => '$(PERM_DIR)' ]); + CODE + $self->{DOC_INSTALL} ||= $self->oneliner('perllocal_install', ["-MExtUtils::Command::MM"]); + $self->{UNINSTALL} ||= $self->oneliner('uninstall', ["-MExtUtils::Command::MM"]); + $self->{WARN_IF_OLD_PACKLIST} ||= + $self->oneliner('warn_if_old_packlist', ["-MExtUtils::Command::MM"]); + $self->{FIXIN} ||= $self->oneliner('MY->fixin(shift)', ["-MExtUtils::MY"]); + $self->{EQUALIZE_TIMESTAMP} ||= $self->oneliner('eqtime', ["-MExtUtils::Command"]); + + $self->{UNINST} ||= 0; + $self->{VERBINST} ||= 0; + + $self->{SHELL} ||= $Config{sh}; + + # UMASK_NULL is not used by MakeMaker but some CPAN modules + # make use of it. + $self->{UMASK_NULL} ||= "umask 0"; + + # Not the greatest default, but its something. + $self->{DEV_NULL} ||= "> /dev/null 2>&1"; + + $self->{NOOP} ||= '$(TRUE)'; + $self->{NOECHO} = '@' unless defined $self->{NOECHO}; + + $self->{FIRST_MAKEFILE} ||= $self->{MAKEFILE} || 'Makefile'; + $self->{MAKEFILE} ||= $self->{FIRST_MAKEFILE}; + $self->{MAKEFILE_OLD} ||= $self->{MAKEFILE}.'.old'; + $self->{MAKE_APERL_FILE} ||= $self->{MAKEFILE}.'.aperl'; + + # Not everybody uses -f to indicate "use this Makefile instead" + $self->{USEMAKEFILE} ||= '-f'; + + # Some makes require a wrapper around macros passed in on the command + # line. + $self->{MACROSTART} ||= ''; + $self->{MACROEND} ||= ''; + + return; + } + + + =head3 init_others + + $MM->init_others(); + + Initializes the macro definitions having to do with compiling and + linking used by tools_other() and places them in the $MM object. + + If there is no description, its the same as the parameter to + WriteMakefile() documented in ExtUtils::MakeMaker. + + =cut + + sub init_others { + my $self = shift; + + $self->{LD_RUN_PATH} = ""; + + $self->{LIBS} = $self->_fix_libs($self->{LIBS}); + + # Compute EXTRALIBS, BSLOADLIBS and LDLOADLIBS from $self->{LIBS} + foreach my $libs ( @{$self->{LIBS}} ){ + $libs =~ s/^\s*(.*\S)\s*$/$1/; # remove leading and trailing whitespace + my(@libs) = $self->extliblist($libs); + if ($libs[0] or $libs[1] or $libs[2]){ + # LD_RUN_PATH now computed by ExtUtils::Liblist + ($self->{EXTRALIBS}, $self->{BSLOADLIBS}, + $self->{LDLOADLIBS}, $self->{LD_RUN_PATH}) = @libs; + last; + } + } + + if ( $self->{OBJECT} ) { + $self->{OBJECT} = join(" ", @{$self->{OBJECT}}) if ref $self->{OBJECT}; + $self->{OBJECT} =~ s!\.o(bj)?\b!\$(OBJ_EXT)!g; + } elsif ( ($self->{MAGICXS} || $self->{XSMULTI}) && @{$self->{O_FILES}||[]} ) { + $self->{OBJECT} = join(" ", @{$self->{O_FILES}}); + $self->{OBJECT} =~ s!\.o(bj)?\b!\$(OBJ_EXT)!g; + } else { + # init_dirscan should have found out, if we have C files + $self->{OBJECT} = ""; + $self->{OBJECT} = '$(BASEEXT)$(OBJ_EXT)' if @{$self->{C}||[]}; + } + $self->{OBJECT} =~ s/\n+/ \\\n\t/g; + + $self->{BOOTDEP} = (-f "$self->{BASEEXT}_BS") ? "$self->{BASEEXT}_BS" : ""; + $self->{PERLMAINCC} ||= '$(CC)'; + $self->{LDFROM} = '$(OBJECT)' unless $self->{LDFROM}; + + # Sanity check: don't define LINKTYPE = dynamic if we're skipping + # the 'dynamic' section of MM. We don't have this problem with + # 'static', since we either must use it (%Config says we can't + # use dynamic loading) or the caller asked for it explicitly. + if (!$self->{LINKTYPE}) { + $self->{LINKTYPE} = $self->{SKIPHASH}{'dynamic'} + ? 'static' + : ($Config{usedl} ? 'dynamic' : 'static'); + } + + return; + } + + + # Lets look at $self->{LIBS} carefully: It may be an anon array, a string or + # undefined. In any case we turn it into an anon array + sub _fix_libs { + my($self, $libs) = @_; + + return !defined $libs ? [''] : + !ref $libs ? [$libs] : + !defined $libs->[0] ? [''] : + $libs ; + } + + + =head3 tools_other + + my $make_frag = $MM->tools_other; + + Returns a make fragment containing definitions for the macros init_others() + initializes. + + =cut + + sub tools_other { + my($self) = shift; + my @m; + + # We set PM_FILTER as late as possible so it can see all the earlier + # on macro-order sensitive makes such as nmake. + for my $tool (qw{ SHELL CHMOD CP MV NOOP NOECHO RM_F RM_RF TEST_F TOUCH + UMASK_NULL DEV_NULL MKPATH EQUALIZE_TIMESTAMP + FALSE TRUE + ECHO ECHO_N + UNINST VERBINST + MOD_INSTALL DOC_INSTALL UNINSTALL + WARN_IF_OLD_PACKLIST + MACROSTART MACROEND + USEMAKEFILE + PM_FILTER + FIXIN + CP_NONEMPTY + } ) + { + next unless defined $self->{$tool}; + push @m, "$tool = $self->{$tool}\n"; + } + + return join "", @m; + } + + + =head3 init_DIRFILESEP I + + $MM->init_DIRFILESEP; + my $dirfilesep = $MM->{DIRFILESEP}; + + Initializes the DIRFILESEP macro which is the separator between the + directory and filename in a filepath. ie. / on Unix, \ on Win32 and + nothing on VMS. + + For example: + + # instead of $(INST_ARCHAUTODIR)/extralibs.ld + $(INST_ARCHAUTODIR)$(DIRFILESEP)extralibs.ld + + Something of a hack but it prevents a lot of code duplication between + MM_* variants. + + Do not use this as a separator between directories. Some operating + systems use different separators between subdirectories as between + directories and filenames (for example: VOLUME:[dir1.dir2]file on VMS). + + =head3 init_linker I + + $mm->init_linker; + + Initialize macros which have to do with linking. + + PERL_ARCHIVE: path to libperl.a equivalent to be linked to dynamic + extensions. + + PERL_ARCHIVE_AFTER: path to a library which should be put on the + linker command line I the external libraries to be linked to + dynamic extensions. This may be needed if the linker is one-pass, and + Perl includes some overrides for C RTL functions, such as malloc(). + + EXPORT_LIST: name of a file that is passed to linker to define symbols + to be exported. + + Some OSes do not need these in which case leave it blank. + + + =head3 init_platform + + $mm->init_platform + + Initialize any macros which are for platform specific use only. + + A typical one is the version number of your OS specific module. + (ie. MM_Unix_VERSION or MM_VMS_VERSION). + + =cut + + sub init_platform { + return ''; + } + + + =head3 init_MAKE + + $mm->init_MAKE + + Initialize MAKE from either a MAKE environment variable or $Config{make}. + + =cut + + sub init_MAKE { + my $self = shift; + + $self->{MAKE} ||= $ENV{MAKE} || $Config{make}; + } + + + =head2 Tools + + A grab bag of methods to generate specific macros and commands. + + + + =head3 manifypods + + Defines targets and routines to translate the pods into manpages and + put them into the INST_* directories. + + =cut + + sub manifypods { + my $self = shift; + + my $POD2MAN_macro = $self->POD2MAN_macro(); + my $manifypods_target = $self->manifypods_target(); + + return <POD2MAN_macro + + Returns a definition for the POD2MAN macro. This is a program + which emulates the pod2man utility. You can add more switches to the + command by simply appending them on the macro. + + Typical usage: + + $(POD2MAN) --section=3 --perm_rw=$(PERM_RW) podfile1 man_page1 ... + + =cut + + sub POD2MAN_macro { + my $self = shift; + + # Need the trailing '--' so perl stops gobbling arguments and - happens + # to be an alternative end of line separator on VMS so we quote it + return <<'END_OF_DEF'; + POD2MAN_EXE = $(PERLRUN) "-MExtUtils::Command::MM" -e pod2man "--" + POD2MAN = $(POD2MAN_EXE) + END_OF_DEF + } + + + =head3 test_via_harness + + my $command = $mm->test_via_harness($perl, $tests); + + Returns a $command line which runs the given set of $tests with + Test::Harness and the given $perl. + + Used on the t/*.t files. + + =cut + + sub test_via_harness { + my($self, $perl, $tests) = @_; + + return qq{\t$perl "-MExtUtils::Command::MM" "-MTest::Harness" }. + qq{"-e" "undef *Test::Harness::Switches; test_harness(\$(TEST_VERBOSE), '\$(INST_LIB)', '\$(INST_ARCHLIB)')" $tests\n}; + } + + =head3 test_via_script + + my $command = $mm->test_via_script($perl, $script); + + Returns a $command line which just runs a single test without + Test::Harness. No checks are done on the results, they're just + printed. + + Used for test.pl, since they don't always follow Test::Harness + formatting. + + =cut + + sub test_via_script { + my($self, $perl, $script) = @_; + return qq{\t$perl "-I\$(INST_LIB)" "-I\$(INST_ARCHLIB)" $script\n}; + } + + + =head3 tool_autosplit + + Defines a simple perl call that runs autosplit. May be deprecated by + pm_to_blib soon. + + =cut + + sub tool_autosplit { + my($self, %attribs) = @_; + + my $maxlen = $attribs{MAXLEN} ? '$$AutoSplit::Maxlen=$attribs{MAXLEN};' + : ''; + + my $asplit = $self->oneliner(sprintf <<'PERL_CODE', $maxlen); + use AutoSplit; %s autosplit($$ARGV[0], $$ARGV[1], 0, 1, 1) + PERL_CODE + + return sprintf <<'MAKE_FRAG', $asplit; + # Usage: $(AUTOSPLITFILE) FileToSplit AutoDirToSplitInto + AUTOSPLITFILE = %s + + MAKE_FRAG + + } + + + =head3 arch_check + + my $arch_ok = $mm->arch_check( + $INC{"Config.pm"}, + File::Spec->catfile($Config{archlibexp}, "Config.pm") + ); + + A sanity check that what Perl thinks the architecture is and what + Config thinks the architecture is are the same. If they're not it + will return false and show a diagnostic message. + + When building Perl it will always return true, as nothing is installed + yet. + + The interface is a bit odd because this is the result of a + quick refactoring. Don't rely on it. + + =cut + + sub arch_check { + my $self = shift; + my($pconfig, $cconfig) = @_; + + return 1 if $self->{PERL_SRC}; + + my($pvol, $pthinks) = $self->splitpath($pconfig); + my($cvol, $cthinks) = $self->splitpath($cconfig); + + $pthinks = $self->canonpath($pthinks); + $cthinks = $self->canonpath($cthinks); + + my $ret = 1; + if ($pthinks ne $cthinks) { + print "Have $pthinks\n"; + print "Want $cthinks\n"; + + $ret = 0; + + my $arch = (grep length, $self->splitdir($pthinks))[-1]; + + print <{UNINSTALLED_PERL}; + Your perl and your Config.pm seem to have different ideas about the + architecture they are running on. + Perl thinks: [$arch] + Config says: [$Config{archname}] + This may or may not cause problems. Please check your installation of perl + if you have problems building this extension. + END + } + + return $ret; + } + + + + =head2 File::Spec wrappers + + ExtUtils::MM_Any is a subclass of File::Spec. The methods noted here + override File::Spec. + + + + =head3 catfile + + File::Spec <= 0.83 has a bug where the file part of catfile is not + canonicalized. This override fixes that bug. + + =cut + + sub catfile { + my $self = shift; + return $self->canonpath($self->SUPER::catfile(@_)); + } + + + + =head2 Misc + + Methods I can't really figure out where they should go yet. + + + =head3 find_tests + + my $test = $mm->find_tests; + + Returns a string suitable for feeding to the shell to return all + tests in t/*.t. + + =cut + + sub find_tests { + my($self) = shift; + return -d 't' ? 't/*.t' : ''; + } + + =head3 find_tests_recursive + + my $tests = $mm->find_tests_recursive; + + Returns a string suitable for feeding to the shell to return all + tests in t/ but recursively. + + =cut + + sub find_tests_recursive { + my($self) = shift; + return '' unless -d 't'; + + require File::Find; + + my %testfiles; + + my $wanted = sub { + return unless m!\.t$!; + my ($volume,$directories,$file) = + File::Spec->splitpath( $File::Find::name ); + my @dirs = File::Spec->splitdir( $directories ); + for ( @dirs ) { + next if $_ eq 't'; + unless ( $_ ) { + $_ = '*.t'; + next; + } + $_ = '*'; + } + my $testfile = join '/', @dirs; + $testfiles{ $testfile } = 1; + }; + + File::Find::find( $wanted, 't' ); + + return join ' ', sort keys %testfiles; + } + + =head3 extra_clean_files + + my @files_to_clean = $MM->extra_clean_files; + + Returns a list of OS specific files to be removed in the clean target in + addition to the usual set. + + =cut + + # An empty method here tickled a perl 5.8.1 bug and would return its object. + sub extra_clean_files { + return; + } + + + =head3 installvars + + my @installvars = $mm->installvars; + + A list of all the INSTALL* variables without the INSTALL prefix. Useful + for iteration or building related variable sets. + + =cut + + sub installvars { + return qw(PRIVLIB SITELIB VENDORLIB + ARCHLIB SITEARCH VENDORARCH + BIN SITEBIN VENDORBIN + SCRIPT SITESCRIPT VENDORSCRIPT + MAN1DIR SITEMAN1DIR VENDORMAN1DIR + MAN3DIR SITEMAN3DIR VENDORMAN3DIR + ); + } + + + =head3 libscan + + my $wanted = $self->libscan($path); + + Takes a path to a file or dir and returns an empty string if we don't + want to include this file in the library. Otherwise it returns the + the $path unchanged. + + Mainly used to exclude version control administrative directories from + installation. + + =cut + + sub libscan { + my($self,$path) = @_; + my($dirs,$file) = ($self->splitpath($path))[1,2]; + return '' if grep /^(?:RCS|CVS|SCCS|\.svn|_darcs)$/, + $self->splitdir($dirs), $file; + + return $path; + } + + + =head3 platform_constants + + my $make_frag = $mm->platform_constants + + Returns a make fragment defining all the macros initialized in + init_platform() rather than put them in constants(). + + =cut + + sub platform_constants { + return ''; + } + + =head3 post_constants (o) + + Returns an empty string per default. Dedicated to overrides from + within Makefile.PL after all constants have been defined. + + =cut + + sub post_constants { + ""; + } + + =head3 post_initialize (o) + + Returns an empty string per default. Used in Makefile.PLs to add some + chunk of text to the Makefile after the object is initialized. + + =cut + + sub post_initialize { + ""; + } + + =head3 postamble (o) + + Returns an empty string. Can be used in Makefile.PLs to write some + text to the Makefile at the end. + + =cut + + sub postamble { + ""; + } + + =begin private + + =head3 _PREREQ_PRINT + + $self->_PREREQ_PRINT; + + Implements PREREQ_PRINT. + + Refactored out of MakeMaker->new(). + + =end private + + =cut + + sub _PREREQ_PRINT { + my $self = shift; + + require Data::Dumper; + my @what = ('PREREQ_PM'); + push @what, 'MIN_PERL_VERSION' if $self->{MIN_PERL_VERSION}; + push @what, 'BUILD_REQUIRES' if $self->{BUILD_REQUIRES}; + print Data::Dumper->Dump([@{$self}{@what}], \@what); + exit 0; + } + + + =begin private + + =head3 _PRINT_PREREQ + + $mm->_PRINT_PREREQ; + + Implements PRINT_PREREQ, a slightly different version of PREREQ_PRINT + added by Redhat to, I think, support generating RPMs from Perl modules. + + Should not include BUILD_REQUIRES as RPMs do not include them. + + Refactored out of MakeMaker->new(). + + =end private + + =cut + + sub _PRINT_PREREQ { + my $self = shift; + + my $prereqs= $self->{PREREQ_PM}; + my @prereq = map { [$_, $prereqs->{$_}] } keys %$prereqs; + + if ( $self->{MIN_PERL_VERSION} ) { + push @prereq, ['perl' => $self->{MIN_PERL_VERSION}]; + } + + print join(" ", map { "perl($_->[0])>=$_->[1] " } + sort { $a->[0] cmp $b->[0] } @prereq), "\n"; + exit 0; + } + + + =begin private + + =head3 _perl_header_files + + my $perl_header_files= $self->_perl_header_files; + + returns a sorted list of header files as found in PERL_SRC or $archlibexp/CORE. + + Used by perldepend() in MM_Unix and MM_VMS via _perl_header_files_fragment() + + =end private + + =cut + + sub _perl_header_files { + my $self = shift; + + my $header_dir = $self->{PERL_SRC} || $ENV{PERL_SRC} || $self->catdir($Config{archlibexp}, 'CORE'); + opendir my $dh, $header_dir + or die "Failed to opendir '$header_dir' to find header files: $!"; + + # we need to use a temporary here as the sort in scalar context would have undefined results. + my @perl_headers= sort grep { /\.h\z/ } readdir($dh); + + closedir $dh; + + return @perl_headers; + } + + =begin private + + =head3 _perl_header_files_fragment ($o, $separator) + + my $perl_header_files_fragment= $self->_perl_header_files_fragment("/"); + + return a Makefile fragment which holds the list of perl header files which + XS code depends on $(PERL_INC), and sets up the dependency for the $(OBJECT) file. + + The $separator argument defaults to "". MM_VMS will set it to "" and MM_UNIX to "/" + in perldepend(). This reason child subclasses need to control this is that in + VMS the $(PERL_INC) directory will already have delimiters in it, but in + UNIX $(PERL_INC) will need a slash between it an the filename. Hypothetically + win32 could use "\\" (but it doesn't need to). + + =end private + + =cut + + sub _perl_header_files_fragment { + my ($self, $separator)= @_; + $separator ||= ""; + return join("\\\n", + "PERL_HDRS = ", + map { + sprintf( " \$(PERL_INCDEP)%s%s ", $separator, $_ ) + } $self->_perl_header_files() + ) . "\n\n" + . "\$(OBJECT) : \$(PERL_HDRS)\n"; + } + + + =head1 AUTHOR + + Michael G Schwern and the denizens of + makemaker@perl.org with code from ExtUtils::MM_Unix and + ExtUtils::MM_Win32. + + + =cut + + 1; +EXTUTILS_MM_ANY + +$fatpacked{"ExtUtils/MM_BeOS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_BEOS'; + package ExtUtils::MM_BeOS; + + use strict; + + =head1 NAME + + ExtUtils::MM_BeOS - methods to override UN*X behaviour in ExtUtils::MakeMaker + + =head1 SYNOPSIS + + use ExtUtils::MM_BeOS; # Done internally by ExtUtils::MakeMaker if needed + + =head1 DESCRIPTION + + See ExtUtils::MM_Unix for a documentation of the methods provided + there. This package overrides the implementation of these methods, not + the semantics. + + =over 4 + + =cut + + use ExtUtils::MakeMaker::Config; + use File::Spec; + require ExtUtils::MM_Any; + require ExtUtils::MM_Unix; + + our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix ); + our $VERSION = '7.06'; + $VERSION = eval $VERSION; + + + =item os_flavor + + BeOS is BeOS. + + =cut + + sub os_flavor { + return('BeOS'); + } + + =item init_linker + + libperl.a equivalent to be linked to dynamic extensions. + + =cut + + sub init_linker { + my($self) = shift; + + $self->{PERL_ARCHIVE} ||= + File::Spec->catdir('$(PERL_INC)',$Config{libperl}); + $self->{PERL_ARCHIVEDEP} ||= ''; + $self->{PERL_ARCHIVE_AFTER} ||= ''; + $self->{EXPORT_LIST} ||= ''; + } + + =back + + 1; + __END__ + +EXTUTILS_MM_BEOS + +$fatpacked{"ExtUtils/MM_Cygwin.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_CYGWIN'; + package ExtUtils::MM_Cygwin; + + use strict; + + use ExtUtils::MakeMaker::Config; + use File::Spec; + + require ExtUtils::MM_Unix; + require ExtUtils::MM_Win32; + our @ISA = qw( ExtUtils::MM_Unix ); + + our $VERSION = '7.06'; + $VERSION = eval $VERSION; + + + =head1 NAME + + ExtUtils::MM_Cygwin - methods to override UN*X behaviour in ExtUtils::MakeMaker + + =head1 SYNOPSIS + + use ExtUtils::MM_Cygwin; # Done internally by ExtUtils::MakeMaker if needed + + =head1 DESCRIPTION + + See ExtUtils::MM_Unix for a documentation of the methods provided there. + + =over 4 + + =item os_flavor + + We're Unix and Cygwin. + + =cut + + sub os_flavor { + return('Unix', 'Cygwin'); + } + + =item cflags + + if configured for dynamic loading, triggers #define EXT in EXTERN.h + + =cut + + sub cflags { + my($self,$libperl)=@_; + return $self->{CFLAGS} if $self->{CFLAGS}; + return '' unless $self->needs_linking(); + + my $base = $self->SUPER::cflags($libperl); + foreach (split /\n/, $base) { + /^(\S*)\s*=\s*(\S*)$/ and $self->{$1} = $2; + }; + $self->{CCFLAGS} .= " -DUSEIMPORTLIB" if ($Config{useshrplib} eq 'true'); + + return $self->{CFLAGS} = qq{ + CCFLAGS = $self->{CCFLAGS} + OPTIMIZE = $self->{OPTIMIZE} + PERLTYPE = $self->{PERLTYPE} + }; + + } + + + =item replace_manpage_separator + + replaces strings '::' with '.' in MAN*POD man page names + + =cut + + sub replace_manpage_separator { + my($self, $man) = @_; + $man =~ s{/+}{.}g; + return $man; + } + + =item init_linker + + points to libperl.a + + =cut + + sub init_linker { + my $self = shift; + + if ($Config{useshrplib} eq 'true') { + my $libperl = '$(PERL_INC)' .'/'. "$Config{libperl}"; + if( $] >= 5.006002 ) { + $libperl =~ s/a$/dll.a/; + } + $self->{PERL_ARCHIVE} = $libperl; + } else { + $self->{PERL_ARCHIVE} = + '$(PERL_INC)' .'/'. ("$Config{libperl}" or "libperl.a"); + } + + $self->{PERL_ARCHIVEDEP} ||= ''; + $self->{PERL_ARCHIVE_AFTER} ||= ''; + $self->{EXPORT_LIST} ||= ''; + } + + =item maybe_command + + Determine whether a file is native to Cygwin by checking whether it + resides inside the Cygwin installation (using Windows paths). If so, + use C to determine if it may be a command. + Otherwise use the tests from C. + + =cut + + sub maybe_command { + my ($self, $file) = @_; + + my $cygpath = Cygwin::posix_to_win_path('/', 1); + my $filepath = Cygwin::posix_to_win_path($file, 1); + + return (substr($filepath,0,length($cygpath)) eq $cygpath) + ? $self->SUPER::maybe_command($file) # Unix + : ExtUtils::MM_Win32->maybe_command($file); # Win32 + } + + =item dynamic_lib + + Use the default to produce the *.dll's. + But for new archdir dll's use the same rebase address if the old exists. + + =cut + + sub dynamic_lib { + my($self, %attribs) = @_; + my $s = ExtUtils::MM_Unix::dynamic_lib($self, %attribs); + return '' unless $s; + return $s unless %{$self->{XS}}; + + # do an ephemeral rebase so the new DLL fits to the current rebase map + $s .= "\t/bin/find \$\(INST_ARCHLIB\)/auto -xdev -name \\*.$self->{DLEXT} | /bin/rebase -sOT -" if (( $Config{myarchname} eq 'i686-cygwin' ) and not ( exists $ENV{CYGPORT_PACKAGE_VERSION} )); + $s; + } + + =item install + + Rebase dll's with the global rebase database after installation. + + =cut + + sub install { + my($self, %attribs) = @_; + my $s = ExtUtils::MM_Unix::install($self, %attribs); + return '' unless $s; + return $s unless %{$self->{XS}}; + + my $INSTALLDIRS = $self->{INSTALLDIRS}; + my $INSTALLLIB = $self->{"INSTALL". ($INSTALLDIRS eq 'perl' ? 'ARCHLIB' : uc($INSTALLDIRS)."ARCH")}; + my $dop = "\$\(DESTDIR\)$INSTALLLIB/auto/"; + my $dll = "$dop/$self->{FULLEXT}/$self->{BASEEXT}.$self->{DLEXT}"; + $s =~ s|^(pure_install :: pure_\$\(INSTALLDIRS\)_install\n\t)\$\(NOECHO\) \$\(NOOP\)\n|$1\$(CHMOD) \$(PERM_RWX) $dll\n\t/bin/find $dop -xdev -name \\*.$self->{DLEXT} \| /bin/rebase -sOT -\n|m if (( $Config{myarchname} eq 'i686-cygwin') and not ( exists $ENV{CYGPORT_PACKAGE_VERSION} )); + $s; + } + + =item all_target + + Build man pages, too + + =cut + + sub all_target { + ExtUtils::MM_Unix::all_target(shift); + } + + =back + + =cut + + 1; +EXTUTILS_MM_CYGWIN + +$fatpacked{"ExtUtils/MM_DOS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_DOS'; + package ExtUtils::MM_DOS; + + use strict; + + our $VERSION = '7.06'; + $VERSION = eval $VERSION; + + require ExtUtils::MM_Any; + require ExtUtils::MM_Unix; + our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix ); + + + =head1 NAME + + ExtUtils::MM_DOS - DOS specific subclass of ExtUtils::MM_Unix + + =head1 SYNOPSIS + + Don't use this module directly. + Use ExtUtils::MM and let it choose. + + =head1 DESCRIPTION + + This is a subclass of ExtUtils::MM_Unix which contains functionality + for DOS. + + Unless otherwise stated, it works just like ExtUtils::MM_Unix + + =head2 Overridden methods + + =over 4 + + =item os_flavor + + =cut + + sub os_flavor { + return('DOS'); + } + + =item B + + Generates Foo__Bar.3 style man page names + + =cut + + sub replace_manpage_separator { + my($self, $man) = @_; + + $man =~ s,/+,__,g; + return $man; + } + + =back + + =head1 AUTHOR + + Michael G Schwern with code from ExtUtils::MM_Unix + + =head1 SEE ALSO + + L, L + + =cut + + 1; +EXTUTILS_MM_DOS + +$fatpacked{"ExtUtils/MM_Darwin.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_DARWIN'; + package ExtUtils::MM_Darwin; + + use strict; + + BEGIN { + require ExtUtils::MM_Unix; + our @ISA = qw( ExtUtils::MM_Unix ); + } + + our $VERSION = '7.06'; + $VERSION = eval $VERSION; + + + =head1 NAME + + ExtUtils::MM_Darwin - special behaviors for OS X + + =head1 SYNOPSIS + + For internal MakeMaker use only + + =head1 DESCRIPTION + + See L for L for documentation on the + methods overridden here. + + =head2 Overriden Methods + + =head3 init_dist + + Turn off Apple tar's tendency to copy resource forks as "._foo" files. + + =cut + + sub init_dist { + my $self = shift; + + # Thank you, Apple, for breaking tar and then breaking the work around. + # 10.4 wants COPY_EXTENDED_ATTRIBUTES_DISABLE while 10.5 wants + # COPYFILE_DISABLE. I'm not going to push my luck and instead just + # set both. + $self->{TAR} ||= + 'COPY_EXTENDED_ATTRIBUTES_DISABLE=1 COPYFILE_DISABLE=1 tar'; + + $self->SUPER::init_dist(@_); + } + + 1; +EXTUTILS_MM_DARWIN + +$fatpacked{"ExtUtils/MM_MacOS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_MACOS'; + package ExtUtils::MM_MacOS; + + use strict; + + our $VERSION = '7.06'; + $VERSION = eval $VERSION; + + sub new { + die 'MacOS Classic (MacPerl) is no longer supported by MakeMaker'; + } + + =head1 NAME + + ExtUtils::MM_MacOS - once produced Makefiles for MacOS Classic + + =head1 SYNOPSIS + + # MM_MacOS no longer contains any code. This is just a stub. + + =head1 DESCRIPTION + + Once upon a time, MakeMaker could produce an approximation of a correct + Makefile on MacOS Classic (MacPerl). Due to a lack of maintainers, this + fell out of sync with the rest of MakeMaker and hadn't worked in years. + Since there's little chance of it being repaired, MacOS Classic is fading + away, and the code was icky to begin with, the code has been deleted to + make maintenance easier. + + Anyone interested in resurrecting this file should pull the old version + from the MakeMaker CVS repository and contact makemaker@perl.org. + + =cut + + 1; +EXTUTILS_MM_MACOS + +$fatpacked{"ExtUtils/MM_NW5.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_NW5'; + package ExtUtils::MM_NW5; + + =head1 NAME + + ExtUtils::MM_NW5 - methods to override UN*X behaviour in ExtUtils::MakeMaker + + =head1 SYNOPSIS + + use ExtUtils::MM_NW5; # Done internally by ExtUtils::MakeMaker if needed + + =head1 DESCRIPTION + + See ExtUtils::MM_Unix for a documentation of the methods provided + there. This package overrides the implementation of these methods, not + the semantics. + + =over + + =cut + + use strict; + use ExtUtils::MakeMaker::Config; + use File::Basename; + + our $VERSION = '7.06'; + $VERSION = eval $VERSION; + + require ExtUtils::MM_Win32; + our @ISA = qw(ExtUtils::MM_Win32); + + use ExtUtils::MakeMaker qw(&neatvalue &_sprintf562); + + $ENV{EMXSHELL} = 'sh'; # to run `commands` + + my $BORLAND = $Config{'cc'} =~ /\bbcc/i; + my $GCC = $Config{'cc'} =~ /\bgcc/i; + + + =item os_flavor + + We're Netware in addition to being Windows. + + =cut + + sub os_flavor { + my $self = shift; + return ($self->SUPER::os_flavor, 'Netware'); + } + + =item init_platform + + Add Netware macros. + + LIBPTH, BASE_IMPORT, NLM_VERSION, MPKTOOL, TOOLPATH, BOOT_SYMBOL, + NLM_SHORT_NAME, INCLUDE, PATH, MM_NW5_REVISION + + + =item platform_constants + + Add Netware macros initialized above to the Makefile. + + =cut + + sub init_platform { + my($self) = shift; + + # To get Win32's setup. + $self->SUPER::init_platform; + + # incpath is copied to makefile var INCLUDE in constants sub, here just + # make it empty + my $libpth = $Config{'libpth'}; + $libpth =~ s( )(;); + $self->{'LIBPTH'} = $libpth; + + $self->{'BASE_IMPORT'} = $Config{'base_import'}; + + # Additional import file specified from Makefile.pl + if($self->{'base_import'}) { + $self->{'BASE_IMPORT'} .= ', ' . $self->{'base_import'}; + } + + $self->{'NLM_VERSION'} = $Config{'nlm_version'}; + $self->{'MPKTOOL'} = $Config{'mpktool'}; + $self->{'TOOLPATH'} = $Config{'toolpath'}; + + (my $boot = $self->{'NAME'}) =~ s/:/_/g; + $self->{'BOOT_SYMBOL'}=$boot; + + # If the final binary name is greater than 8 chars, + # truncate it here. + if(length($self->{'BASEEXT'}) > 8) { + $self->{'NLM_SHORT_NAME'} = substr($self->{'BASEEXT'},0,8); + } + + # Get the include path and replace the spaces with ; + # Copy this to makefile as INCLUDE = d:\...;d:\; + ($self->{INCLUDE} = $Config{'incpath'}) =~ s/([ ]*)-I/;/g; + + # Set the path to CodeWarrior binaries which might not have been set in + # any other place + $self->{PATH} = '$(PATH);$(TOOLPATH)'; + + $self->{MM_NW5_VERSION} = $VERSION; + } + + sub platform_constants { + my($self) = shift; + my $make_frag = ''; + + # Setup Win32's constants. + $make_frag .= $self->SUPER::platform_constants; + + foreach my $macro (qw(LIBPTH BASE_IMPORT NLM_VERSION MPKTOOL + TOOLPATH BOOT_SYMBOL NLM_SHORT_NAME INCLUDE PATH + MM_NW5_VERSION + )) + { + next unless defined $self->{$macro}; + $make_frag .= "$macro = $self->{$macro}\n"; + } + + return $make_frag; + } + + =item static_lib_pure_cmd + + Defines how to run the archive utility + + =cut + + sub static_lib_pure_cmd { + my ($self, $src) = @_; + $src =~ s/(\$\(\w+)(\))/$1:^"+"$2/g if $BORLAND; + sprintf qq{\t\$(AR) %s\n}, ($BORLAND ? '$@ ' . $src + : ($GCC ? '-ru $@ ' . $src + : '-type library -o $@ ' . $src)); + } + + =item dynamic_lib + + Override of utility methods for OS-specific work. + + =cut + + sub xs_make_dynamic_lib { + my ($self, $attribs, $from, $to, $todir, $ldfrom, $exportlist) = @_; + my @m; + # Taking care of long names like FileHandle, ByteLoader, SDBM_File etc + if ($to =~ /^\$/) { + if ($self->{NLM_SHORT_NAME}) { + # deal with shortnames + my $newto = q{$(INST_AUTODIR)\\$(NLM_SHORT_NAME).$(DLEXT)}; + push @m, "$to: $newto\n\n"; + $to = $newto; + } + } else { + my ($v, $d, $f) = File::Spec->splitpath($to); + # relies on $f having a literal "." in it, unlike for $(OBJ_EXT) + if ($f =~ /[^\.]{9}\./) { + # 9+ chars before '.', need to shorten + $f = substr $f, 0, 8; + } + my $newto = File::Spec->catpath($v, $d, $f); + push @m, "$to: $newto\n\n"; + $to = $newto; + } + # bits below should be in dlsyms, not here + # 1 2 3 4 + push @m, _sprintf562 <<'MAKE_FRAG', $to, $from, $todir, $exportlist; + # Create xdc data for an MT safe NLM in case of mpk build + %1$s: %2$s $(MYEXTLIB) $(BOOTSTRAP) %3$s$(DFSEP).exists + $(NOECHO) $(ECHO) Export boot_$(BOOT_SYMBOL) > %4$s + $(NOECHO) $(ECHO) $(BASE_IMPORT) >> %4$s + $(NOECHO) $(ECHO) Import @$(PERL_INC)\perl.imp >> %4$s + MAKE_FRAG + if ( $self->{CCFLAGS} =~ m/ -DMPK_ON /) { + (my $xdc = $exportlist) =~ s#def\z#xdc#; + $xdc = '$(BASEEXT).xdc'; + push @m, sprintf <<'MAKE_FRAG', $xdc, $exportlist; + $(MPKTOOL) $(XDCFLAGS) %s + $(NOECHO) $(ECHO) xdcdata $(BASEEXT).xdc >> %s + MAKE_FRAG + } + # Reconstruct the X.Y.Z version. + my $version = join '.', map { sprintf "%d", $_ } + $] =~ /(\d)\.(\d{3})(\d{2})/; + push @m, sprintf <<'EOF', $from, $version, $to, $exportlist; + $(LD) $(LDFLAGS) %s -desc "Perl %s Extension ($(BASEEXT)) XS_VERSION: $(XS_VERSION)" -nlmversion $(NLM_VERSION) -o %s $(MYEXTLIB) $(PERL_INC)\Main.lib -commandfile %s + $(CHMOD) 755 $@ + EOF + join '', @m; + } + + 1; + __END__ + + =back + + =cut +EXTUTILS_MM_NW5 + +$fatpacked{"ExtUtils/MM_OS2.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_OS2'; + package ExtUtils::MM_OS2; + + use strict; + + use ExtUtils::MakeMaker qw(neatvalue); + use File::Spec; + + our $VERSION = '7.06'; + $VERSION = eval $VERSION; + + require ExtUtils::MM_Any; + require ExtUtils::MM_Unix; + our @ISA = qw(ExtUtils::MM_Any ExtUtils::MM_Unix); + + =pod + + =head1 NAME + + ExtUtils::MM_OS2 - methods to override UN*X behaviour in ExtUtils::MakeMaker + + =head1 SYNOPSIS + + use ExtUtils::MM_OS2; # Done internally by ExtUtils::MakeMaker if needed + + =head1 DESCRIPTION + + See ExtUtils::MM_Unix for a documentation of the methods provided + there. This package overrides the implementation of these methods, not + the semantics. + + =head1 METHODS + + =over 4 + + =item init_dist + + Define TO_UNIX to convert OS2 linefeeds to Unix style. + + =cut + + sub init_dist { + my($self) = @_; + + $self->{TO_UNIX} ||= <<'MAKE_TEXT'; + $(NOECHO) $(TEST_F) tmp.zip && $(RM_F) tmp.zip; $(ZIP) -ll -mr tmp.zip $(DISTVNAME) && unzip -o tmp.zip && $(RM_F) tmp.zip + MAKE_TEXT + + $self->SUPER::init_dist; + } + + sub dlsyms { + my($self,%attribs) = @_; + if ($self->{IMPORTS} && %{$self->{IMPORTS}}) { + # Make import files (needed for static build) + -d 'tmp_imp' or mkdir 'tmp_imp', 0777 or die "Can't mkdir tmp_imp"; + open my $imp, '>', 'tmpimp.imp' or die "Can't open tmpimp.imp"; + while (my($name, $exp) = each %{$self->{IMPORTS}}) { + my ($lib, $id) = ($exp =~ /(.*)\.(.*)/) or die "Malformed IMPORT `$exp'"; + print $imp "$name $lib $id ?\n"; + } + close $imp or die "Can't close tmpimp.imp"; + # print "emximp -o tmpimp$Config::Config{lib_ext} tmpimp.imp\n"; + system "emximp -o tmpimp$Config::Config{lib_ext} tmpimp.imp" + and die "Cannot make import library: $!, \$?=$?"; + # May be running under miniperl, so have no glob... + eval { unlink ; 1 } or system "rm tmp_imp/*"; + system "cd tmp_imp; $Config::Config{ar} x ../tmpimp$Config::Config{lib_ext}" + and die "Cannot extract import objects: $!, \$?=$?"; + } + return '' if $self->{SKIPHASH}{'dynamic'}; + $self->xs_dlsyms_iterator(\%attribs); + } + + sub xs_dlsyms_ext { + '.def'; + } + + sub xs_dlsyms_extra { + join '', map { qq{, "$_" => "\$($_)"} } qw(VERSION DISTNAME INSTALLDIRS); + } + + sub static_lib_pure_cmd { + my($self) = @_; + my $old = $self->SUPER::static_lib_pure_cmd; + return $old unless $self->{IMPORTS} && %{$self->{IMPORTS}}; + $old . <<'EOC'; + $(AR) $(AR_STATIC_ARGS) "$@" tmp_imp/* + $(RANLIB) "$@" + EOC + } + + sub replace_manpage_separator { + my($self,$man) = @_; + $man =~ s,/+,.,g; + $man; + } + + sub maybe_command { + my($self,$file) = @_; + $file =~ s,[/\\]+,/,g; + return $file if -x $file && ! -d _; + return "$file.exe" if -x "$file.exe" && ! -d _; + return "$file.cmd" if -x "$file.cmd" && ! -d _; + return; + } + + =item init_linker + + =cut + + sub init_linker { + my $self = shift; + + $self->{PERL_ARCHIVE} = "\$(PERL_INC)/libperl\$(LIB_EXT)"; + + $self->{PERL_ARCHIVEDEP} ||= ''; + $self->{PERL_ARCHIVE_AFTER} = $OS2::is_aout + ? '' + : '$(PERL_INC)/libperl_override$(LIB_EXT)'; + $self->{EXPORT_LIST} = '$(BASEEXT).def'; + } + + =item os_flavor + + OS/2 is OS/2 + + =cut + + sub os_flavor { + return('OS/2'); + } + + =back + + =cut + + 1; +EXTUTILS_MM_OS2 + +$fatpacked{"ExtUtils/MM_QNX.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_QNX'; + package ExtUtils::MM_QNX; + + use strict; + our $VERSION = '7.06'; + $VERSION = eval $VERSION; + + require ExtUtils::MM_Unix; + our @ISA = qw(ExtUtils::MM_Unix); + + + =head1 NAME + + ExtUtils::MM_QNX - QNX specific subclass of ExtUtils::MM_Unix + + =head1 SYNOPSIS + + Don't use this module directly. + Use ExtUtils::MM and let it choose. + + =head1 DESCRIPTION + + This is a subclass of ExtUtils::MM_Unix which contains functionality for + QNX. + + Unless otherwise stated it works just like ExtUtils::MM_Unix + + =head2 Overridden methods + + =head3 extra_clean_files + + Add .err files corresponding to each .c file. + + =cut + + sub extra_clean_files { + my $self = shift; + + my @errfiles = @{$self->{C}}; + for ( @errfiles ) { + s/.c$/.err/; + } + + return( @errfiles, 'perlmain.err' ); + } + + + =head1 AUTHOR + + Michael G Schwern with code from ExtUtils::MM_Unix + + =head1 SEE ALSO + + L + + =cut + + + 1; +EXTUTILS_MM_QNX + +$fatpacked{"ExtUtils/MM_UWIN.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_UWIN'; + package ExtUtils::MM_UWIN; + + use strict; + our $VERSION = '7.06'; + $VERSION = eval $VERSION; + + require ExtUtils::MM_Unix; + our @ISA = qw(ExtUtils::MM_Unix); + + + =head1 NAME + + ExtUtils::MM_UWIN - U/WIN specific subclass of ExtUtils::MM_Unix + + =head1 SYNOPSIS + + Don't use this module directly. + Use ExtUtils::MM and let it choose. + + =head1 DESCRIPTION + + This is a subclass of ExtUtils::MM_Unix which contains functionality for + the AT&T U/WIN UNIX on Windows environment. + + Unless otherwise stated it works just like ExtUtils::MM_Unix + + =head2 Overridden methods + + =over 4 + + =item os_flavor + + In addition to being Unix, we're U/WIN. + + =cut + + sub os_flavor { + return('Unix', 'U/WIN'); + } + + + =item B + + =cut + + sub replace_manpage_separator { + my($self, $man) = @_; + + $man =~ s,/+,.,g; + return $man; + } + + =back + + =head1 AUTHOR + + Michael G Schwern with code from ExtUtils::MM_Unix + + =head1 SEE ALSO + + L, L + + =cut + + 1; +EXTUTILS_MM_UWIN + +$fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_UNIX'; + package ExtUtils::MM_Unix; + + require 5.006; + + use strict; + + use Carp; + use ExtUtils::MakeMaker::Config; + use File::Basename qw(basename dirname); + use DirHandle; + + our %Config_Override; + + use ExtUtils::MakeMaker qw($Verbose neatvalue _sprintf562); + + # If we make $VERSION an our variable parse_version() breaks + use vars qw($VERSION); + $VERSION = '7.06'; + $VERSION = eval $VERSION; ## no critic [BuiltinFunctions::ProhibitStringyEval] + + require ExtUtils::MM_Any; + our @ISA = qw(ExtUtils::MM_Any); + + my %Is; + BEGIN { + $Is{OS2} = $^O eq 'os2'; + $Is{Win32} = $^O eq 'MSWin32' || $Config{osname} eq 'NetWare'; + $Is{Dos} = $^O eq 'dos'; + $Is{VMS} = $^O eq 'VMS'; + $Is{OSF} = $^O eq 'dec_osf'; + $Is{IRIX} = $^O eq 'irix'; + $Is{NetBSD} = $^O eq 'netbsd'; + $Is{Interix} = $^O eq 'interix'; + $Is{SunOS4} = $^O eq 'sunos'; + $Is{Solaris} = $^O eq 'solaris'; + $Is{SunOS} = $Is{SunOS4} || $Is{Solaris}; + $Is{BSD} = ($^O =~ /^(?:free|net|open)bsd$/ or + grep( $^O eq $_, qw(bsdos interix dragonfly) ) + ); + $Is{Android} = $^O =~ /android/; + } + + BEGIN { + if( $Is{VMS} ) { + # For things like vmsify() + require VMS::Filespec; + VMS::Filespec->import; + } + } + + + =head1 NAME + + ExtUtils::MM_Unix - methods used by ExtUtils::MakeMaker + + =head1 SYNOPSIS + + C + + =head1 DESCRIPTION + + The methods provided by this package are designed to be used in + conjunction with ExtUtils::MakeMaker. When MakeMaker writes a + Makefile, it creates one or more objects that inherit their methods + from a package C. MM itself doesn't provide any methods, but it + ISA ExtUtils::MM_Unix class. The inheritance tree of MM lets operating + specific packages take the responsibility for all the methods provided + by MM_Unix. We are trying to reduce the number of the necessary + overrides by defining rather primitive operations within + ExtUtils::MM_Unix. + + If you are going to write a platform specific MM package, please try + to limit the necessary overrides to primitive methods, and if it is not + possible to do so, let's work out how to achieve that gain. + + If you are overriding any of these methods in your Makefile.PL (in the + MY class), please report that to the makemaker mailing list. We are + trying to minimize the necessary method overrides and switch to data + driven Makefile.PLs wherever possible. In the long run less methods + will be overridable via the MY class. + + =head1 METHODS + + The following description of methods is still under + development. Please refer to the code for not suitably documented + sections and complain loudly to the makemaker@perl.org mailing list. + Better yet, provide a patch. + + Not all of the methods below are overridable in a + Makefile.PL. Overridable methods are marked as (o). All methods are + overridable by a platform specific MM_*.pm file. + + Cross-platform methods are being moved into MM_Any. If you can't find + something that used to be in here, look in MM_Any. + + =cut + + # So we don't have to keep calling the methods over and over again, + # we have these globals to cache the values. Faster and shrtr. + my $Curdir = __PACKAGE__->curdir; + my $Rootdir = __PACKAGE__->rootdir; + my $Updir = __PACKAGE__->updir; + + + =head2 Methods + + =over 4 + + =item os_flavor + + Simply says that we're Unix. + + =cut + + sub os_flavor { + return('Unix'); + } + + + =item c_o (o) + + Defines the suffix rules to compile different flavors of C files to + object files. + + =cut + + sub c_o { + # --- Translation Sections --- + + my($self) = shift; + return '' unless $self->needs_linking(); + my(@m); + + my $command = '$(CCCMD)'; + my $flags = '$(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) $(DEFINE)'; + + if (my $cpp = $Config{cpprun}) { + my $cpp_cmd = $self->const_cccmd; + $cpp_cmd =~ s/^CCCMD\s*=\s*\$\(CC\)/$cpp/; + push @m, qq{ + .c.i: + $cpp_cmd $flags \$*.c > \$*.i + }; + } + + push @m, sprintf <<'EOF', $command, $flags, $self->xs_obj_opt('$*.s'); + + .c.s : + %s -S %s $*.c %s + EOF + + my @exts = qw(c cpp cxx cc); + push @exts, 'C' if !$Is{OS2} and !$Is{Win32} and !$Is{Dos}; #Case-specific + my $oo = $self->xs_obj_opt('$*$(OBJ_EXT)'); + for my $ext (@exts) { + push @m, "\n.$ext\$(OBJ_EXT) :\n\t$command $flags \$*.$ext $oo\n"; + } + return join "", @m; + } + + + =item xs_obj_opt + + Takes the object file as an argument, and returns the portion of compile + command-line that will output to the specified object file. + + =cut + + sub xs_obj_opt { + my ($self, $output_file) = @_; + "-o $output_file"; + } + + + =item cflags (o) + + Does very much the same as the cflags script in the perl + distribution. It doesn't return the whole compiler command line, but + initializes all of its parts. The const_cccmd method then actually + returns the definition of the CCCMD macro which uses these parts. + + =cut + + #' + + sub cflags { + my($self,$libperl)=@_; + return $self->{CFLAGS} if $self->{CFLAGS}; + return '' unless $self->needs_linking(); + + my($prog, $uc, $perltype, %cflags); + $libperl ||= $self->{LIBPERL_A} || "libperl$self->{LIB_EXT}" ; + $libperl =~ s/\.\$\(A\)$/$self->{LIB_EXT}/; + + @cflags{qw(cc ccflags optimize shellflags)} + = @Config{qw(cc ccflags optimize shellflags)}; + + # Perl 5.21.4 adds the (gcc) warning (-Wall ...) and std (-std=c89) + # flags to the %Config, and the modules in the core should be built + # with the warning flags, but NOT the -std=c89 flags (the latter + # would break using any system header files that are strict C99). + my @ccextraflags = qw(ccwarnflags); + if ($ENV{PERL_CORE}) { + for my $x (@ccextraflags) { + if (exists $Config{$x}) { + $cflags{$x} = $Config{$x}; + } + } + } + + my($optdebug) = ""; + + $cflags{shellflags} ||= ''; + + my(%map) = ( + D => '-DDEBUGGING', + E => '-DEMBED', + DE => '-DDEBUGGING -DEMBED', + M => '-DEMBED -DMULTIPLICITY', + DM => '-DDEBUGGING -DEMBED -DMULTIPLICITY', + ); + + if ($libperl =~ /libperl(\w*)\Q$self->{LIB_EXT}/){ + $uc = uc($1); + } else { + $uc = ""; # avoid warning + } + $perltype = $map{$uc} ? $map{$uc} : ""; + + if ($uc =~ /^D/) { + $optdebug = "-g"; + } + + + my($name); + ( $name = $self->{NAME} . "_cflags" ) =~ s/:/_/g ; + if ($prog = $Config{$name}) { + # Expand hints for this extension via the shell + print "Processing $name hint:\n" if $Verbose; + my(@o)=`cc=\"$cflags{cc}\" + ccflags=\"$cflags{ccflags}\" + optimize=\"$cflags{optimize}\" + perltype=\"$cflags{perltype}\" + optdebug=\"$cflags{optdebug}\" + eval '$prog' + echo cc=\$cc + echo ccflags=\$ccflags + echo optimize=\$optimize + echo perltype=\$perltype + echo optdebug=\$optdebug + `; + foreach my $line (@o){ + chomp $line; + if ($line =~ /(.*?)=\s*(.*)\s*$/){ + $cflags{$1} = $2; + print " $1 = $2\n" if $Verbose; + } else { + print "Unrecognised result from hint: '$line'\n"; + } + } + } + + if ($optdebug) { + $cflags{optimize} = $optdebug; + } + + for (qw(ccflags optimize perltype)) { + $cflags{$_} ||= ''; + $cflags{$_} =~ s/^\s+//; + $cflags{$_} =~ s/\s+/ /g; + $cflags{$_} =~ s/\s+$//; + $self->{uc $_} ||= $cflags{$_}; + } + + if ($self->{POLLUTE}) { + $self->{CCFLAGS} .= ' -DPERL_POLLUTE '; + } + + for my $x (@ccextraflags) { + next unless exists $cflags{$x}; + $self->{CCFLAGS} .= $cflags{$x} =~ m!^\s! ? $cflags{$x} : ' ' . $cflags{$x}; + } + + my $pollute = ''; + if ($Config{usemymalloc} and not $Config{bincompat5005} + and not $Config{ccflags} =~ /-DPERL_POLLUTE_MALLOC\b/ + and $self->{PERL_MALLOC_OK}) { + $pollute = '$(PERL_MALLOC_DEF)'; + } + + return $self->{CFLAGS} = qq{ + CCFLAGS = $self->{CCFLAGS} + OPTIMIZE = $self->{OPTIMIZE} + PERLTYPE = $self->{PERLTYPE} + MPOLLUTE = $pollute + }; + + } + + + =item const_cccmd (o) + + Returns the full compiler call for C programs and stores the + definition in CONST_CCCMD. + + =cut + + sub const_cccmd { + my($self,$libperl)=@_; + return $self->{CONST_CCCMD} if $self->{CONST_CCCMD}; + return '' unless $self->needs_linking(); + return $self->{CONST_CCCMD} = + q{CCCMD = $(CC) -c $(PASTHRU_INC) $(INC) \\ + $(CCFLAGS) $(OPTIMIZE) \\ + $(PERLTYPE) $(MPOLLUTE) $(DEFINE_VERSION) \\ + $(XS_DEFINE_VERSION)}; + } + + =item const_config (o) + + Sets SHELL if needed, then defines a couple of constants in the Makefile + that are imported from %Config. + + =cut + + sub const_config { + # --- Constants Sections --- + + my($self) = shift; + my @m = $self->specify_shell(); # Usually returns empty string + push @m, <<"END"; + + # These definitions are from config.sh (via $INC{'Config.pm'}). + # They may have been overridden via Makefile.PL or on the command line. + END + + my(%once_only); + foreach my $key (@{$self->{CONFIG}}){ + # SITE*EXP macros are defined in &constants; avoid duplicates here + next if $once_only{$key}; + push @m, uc($key) , ' = ' , $self->{uc $key}, "\n"; + $once_only{$key} = 1; + } + join('', @m); + } + + =item const_loadlibs (o) + + Defines EXTRALIBS, LDLOADLIBS, BSLOADLIBS, LD_RUN_PATH. See + L for details. + + =cut + + sub const_loadlibs { + my($self) = shift; + return "" unless $self->needs_linking; + my @m; + push @m, qq{ + # $self->{NAME} might depend on some other libraries: + # See ExtUtils::Liblist for details + # + }; + for my $tmp (qw/ + EXTRALIBS LDLOADLIBS BSLOADLIBS + /) { + next unless defined $self->{$tmp}; + push @m, "$tmp = $self->{$tmp}\n"; + } + # don't set LD_RUN_PATH if empty + for my $tmp (qw/ + LD_RUN_PATH + /) { + next unless $self->{$tmp}; + push @m, "$tmp = $self->{$tmp}\n"; + } + return join "", @m; + } + + =item constants (o) + + my $make_frag = $mm->constants; + + Prints out macros for lots of constants. + + =cut + + sub constants { + my($self) = @_; + my @m = (); + + $self->{DFSEP} = '$(DIRFILESEP)'; # alias for internal use + + for my $macro (qw( + + AR_STATIC_ARGS DIRFILESEP DFSEP + NAME NAME_SYM + VERSION VERSION_MACRO VERSION_SYM DEFINE_VERSION + XS_VERSION XS_VERSION_MACRO XS_DEFINE_VERSION + INST_ARCHLIB INST_SCRIPT INST_BIN INST_LIB + INST_MAN1DIR INST_MAN3DIR + MAN1EXT MAN3EXT + INSTALLDIRS INSTALL_BASE DESTDIR PREFIX + PERLPREFIX SITEPREFIX VENDORPREFIX + ), + (map { ("INSTALL".$_, + "DESTINSTALL".$_) + } $self->installvars), + qw( + PERL_LIB + PERL_ARCHLIB PERL_ARCHLIBDEP + LIBPERL_A MYEXTLIB + FIRST_MAKEFILE MAKEFILE_OLD MAKE_APERL_FILE + PERLMAINCC PERL_SRC PERL_INC PERL_INCDEP + PERL FULLPERL ABSPERL + PERLRUN FULLPERLRUN ABSPERLRUN + PERLRUNINST FULLPERLRUNINST ABSPERLRUNINST + PERL_CORE + PERM_DIR PERM_RW PERM_RWX + + ) ) + { + next unless defined $self->{$macro}; + + # pathnames can have sharp signs in them; escape them so + # make doesn't think it is a comment-start character. + $self->{$macro} =~ s/#/\\#/g; + $self->{$macro} = $self->quote_dep($self->{$macro}) + if $ExtUtils::MakeMaker::macro_dep{$macro}; + push @m, "$macro = $self->{$macro}\n"; + } + + push @m, qq{ + MAKEMAKER = $self->{MAKEMAKER} + MM_VERSION = $self->{MM_VERSION} + MM_REVISION = $self->{MM_REVISION} + }; + + push @m, q{ + # FULLEXT = Pathname for extension directory (eg Foo/Bar/Oracle). + # BASEEXT = Basename part of FULLEXT. May be just equal FULLEXT. (eg Oracle) + # PARENT_NAME = NAME without BASEEXT and no trailing :: (eg Foo::Bar) + # DLBASE = Basename part of dynamic library. May be just equal BASEEXT. + }; + + for my $macro (qw/ + MAKE + FULLEXT BASEEXT PARENT_NAME DLBASE VERSION_FROM INC DEFINE OBJECT + LDFROM LINKTYPE BOOTDEP + / ) + { + next unless defined $self->{$macro}; + push @m, "$macro = $self->{$macro}\n"; + } + + push @m, " + # Handy lists of source code files: + XS_FILES = ".$self->wraplist(sort keys %{$self->{XS}})." + C_FILES = ".$self->wraplist(sort @{$self->{C}})." + O_FILES = ".$self->wraplist(sort @{$self->{O_FILES}})." + H_FILES = ".$self->wraplist(sort @{$self->{H}})." + MAN1PODS = ".$self->wraplist(sort keys %{$self->{MAN1PODS}})." + MAN3PODS = ".$self->wraplist(sort keys %{$self->{MAN3PODS}})." + "; + + + push @m, q{ + # Where is the Config information that we are using/depend on + CONFIGDEP = $(PERL_ARCHLIBDEP)$(DFSEP)Config.pm $(PERL_INCDEP)$(DFSEP)config.h + } if -e File::Spec->catfile( $self->{PERL_INC}, 'config.h' ); + + + push @m, qq{ + # Where to build things + INST_LIBDIR = $self->{INST_LIBDIR} + INST_ARCHLIBDIR = $self->{INST_ARCHLIBDIR} + + INST_AUTODIR = $self->{INST_AUTODIR} + INST_ARCHAUTODIR = $self->{INST_ARCHAUTODIR} + + INST_STATIC = $self->{INST_STATIC} + INST_DYNAMIC = $self->{INST_DYNAMIC} + INST_BOOT = $self->{INST_BOOT} + }; + + push @m, qq{ + # Extra linker info + EXPORT_LIST = $self->{EXPORT_LIST} + PERL_ARCHIVE = $self->{PERL_ARCHIVE} + PERL_ARCHIVEDEP = $self->{PERL_ARCHIVEDEP} + PERL_ARCHIVE_AFTER = $self->{PERL_ARCHIVE_AFTER} + }; + + push @m, " + + TO_INST_PM = ".$self->wraplist(map $self->quote_dep($_), sort keys %{$self->{PM}})."\n"; + + join('',@m); + } + + + =item depend (o) + + Same as macro for the depend attribute. + + =cut + + sub depend { + my($self,%attribs) = @_; + my(@m,$key,$val); + for my $key (sort keys %attribs){ + my $val = $attribs{$key}; + next unless defined $key and defined $val; + push @m, "$key : $val\n"; + } + join "", @m; + } + + + =item init_DEST + + $mm->init_DEST + + Defines the DESTDIR and DEST* variables paralleling the INSTALL*. + + =cut + + sub init_DEST { + my $self = shift; + + # Initialize DESTDIR + $self->{DESTDIR} ||= ''; + + # Make DEST variables. + foreach my $var ($self->installvars) { + my $destvar = 'DESTINSTALL'.$var; + $self->{$destvar} ||= '$(DESTDIR)$(INSTALL'.$var.')'; + } + } + + + =item init_dist + + $mm->init_dist; + + Defines a lot of macros for distribution support. + + macro description default + + TAR tar command to use tar + TARFLAGS flags to pass to TAR cvf + + ZIP zip command to use zip + ZIPFLAGS flags to pass to ZIP -r + + COMPRESS compression command to gzip --best + use for tarfiles + SUFFIX suffix to put on .gz + compressed files + + SHAR shar command to use shar + + PREOP extra commands to run before + making the archive + POSTOP extra commands to run after + making the archive + + TO_UNIX a command to convert linefeeds + to Unix style in your archive + + CI command to checkin your ci -u + sources to version control + RCS_LABEL command to label your sources rcs -Nv$(VERSION_SYM): -q + just after CI is run + + DIST_CP $how argument to manicopy() best + when the distdir is created + + DIST_DEFAULT default target to use to tardist + create a distribution + + DISTVNAME name of the resulting archive $(DISTNAME)-$(VERSION) + (minus suffixes) + + =cut + + sub init_dist { + my $self = shift; + + $self->{TAR} ||= 'tar'; + $self->{TARFLAGS} ||= 'cvf'; + $self->{ZIP} ||= 'zip'; + $self->{ZIPFLAGS} ||= '-r'; + $self->{COMPRESS} ||= 'gzip --best'; + $self->{SUFFIX} ||= '.gz'; + $self->{SHAR} ||= 'shar'; + $self->{PREOP} ||= '$(NOECHO) $(NOOP)'; # eg update MANIFEST + $self->{POSTOP} ||= '$(NOECHO) $(NOOP)'; # eg remove the distdir + $self->{TO_UNIX} ||= '$(NOECHO) $(NOOP)'; + + $self->{CI} ||= 'ci -u'; + $self->{RCS_LABEL}||= 'rcs -Nv$(VERSION_SYM): -q'; + $self->{DIST_CP} ||= 'best'; + $self->{DIST_DEFAULT} ||= 'tardist'; + + ($self->{DISTNAME} = $self->{NAME}) =~ s{::}{-}g unless $self->{DISTNAME}; + $self->{DISTVNAME} ||= $self->{DISTNAME}.'-'.$self->{VERSION}; + } + + =item dist (o) + + my $dist_macros = $mm->dist(%overrides); + + Generates a make fragment defining all the macros initialized in + init_dist. + + %overrides can be used to override any of the above. + + =cut + + sub dist { + my($self, %attribs) = @_; + + my $make = ''; + if ( $attribs{SUFFIX} && $attribs{SUFFIX} !~ m!^\.! ) { + $attribs{SUFFIX} = '.' . $attribs{SUFFIX}; + } + foreach my $key (qw( + TAR TARFLAGS ZIP ZIPFLAGS COMPRESS SUFFIX SHAR + PREOP POSTOP TO_UNIX + CI RCS_LABEL DIST_CP DIST_DEFAULT + DISTNAME DISTVNAME + )) + { + my $value = $attribs{$key} || $self->{$key}; + $make .= "$key = $value\n"; + } + + return $make; + } + + =item dist_basics (o) + + Defines the targets distclean, distcheck, skipcheck, manifest, veryclean. + + =cut + + sub dist_basics { + my($self) = shift; + + return <<'MAKE_FRAG'; + distclean :: realclean distcheck + $(NOECHO) $(NOOP) + + distcheck : + $(PERLRUN) "-MExtUtils::Manifest=fullcheck" -e fullcheck + + skipcheck : + $(PERLRUN) "-MExtUtils::Manifest=skipcheck" -e skipcheck + + manifest : + $(PERLRUN) "-MExtUtils::Manifest=mkmanifest" -e mkmanifest + + veryclean : realclean + $(RM_F) *~ */*~ *.orig */*.orig *.bak */*.bak *.old */*.old + + MAKE_FRAG + + } + + =item dist_ci (o) + + Defines a check in target for RCS. + + =cut + + sub dist_ci { + my($self) = shift; + return sprintf "ci :\n\t%s\n", $self->oneliner(<<'EOF', [qw(-MExtUtils::Manifest=maniread)]); + @all = keys %{ maniread() }; + print(qq{Executing $(CI) @all\n}); + system(qq{$(CI) @all}) == 0 or die $!; + print(qq{Executing $(RCS_LABEL) ...\n}); + system(qq{$(RCS_LABEL) @all}) == 0 or die $!; + EOF + } + + =item dist_core (o) + + my $dist_make_fragment = $MM->dist_core; + + Puts the targets necessary for 'make dist' together into one make + fragment. + + =cut + + sub dist_core { + my($self) = shift; + + my $make_frag = ''; + foreach my $target (qw(dist tardist uutardist tarfile zipdist zipfile + shdist)) + { + my $method = $target.'_target'; + $make_frag .= "\n"; + $make_frag .= $self->$method(); + } + + return $make_frag; + } + + + =item B + + my $make_frag = $MM->dist_target; + + Returns the 'dist' target to make an archive for distribution. This + target simply checks to make sure the Makefile is up-to-date and + depends on $(DIST_DEFAULT). + + =cut + + sub dist_target { + my($self) = shift; + + my $date_check = $self->oneliner(<<'CODE', ['-l']); + print 'Warning: Makefile possibly out of date with $(VERSION_FROM)' + if -e '$(VERSION_FROM)' and -M '$(VERSION_FROM)' < -M '$(FIRST_MAKEFILE)'; + CODE + + return sprintf <<'MAKE_FRAG', $date_check; + dist : $(DIST_DEFAULT) $(FIRST_MAKEFILE) + $(NOECHO) %s + MAKE_FRAG + } + + =item B + + my $make_frag = $MM->tardist_target; + + Returns the 'tardist' target which is simply so 'make tardist' works. + The real work is done by the dynamically named tardistfile_target() + method, tardist should have that as a dependency. + + =cut + + sub tardist_target { + my($self) = shift; + + return <<'MAKE_FRAG'; + tardist : $(DISTVNAME).tar$(SUFFIX) + $(NOECHO) $(NOOP) + MAKE_FRAG + } + + =item B + + my $make_frag = $MM->zipdist_target; + + Returns the 'zipdist' target which is simply so 'make zipdist' works. + The real work is done by the dynamically named zipdistfile_target() + method, zipdist should have that as a dependency. + + =cut + + sub zipdist_target { + my($self) = shift; + + return <<'MAKE_FRAG'; + zipdist : $(DISTVNAME).zip + $(NOECHO) $(NOOP) + MAKE_FRAG + } + + =item B + + my $make_frag = $MM->tarfile_target; + + The name of this target is the name of the tarball generated by + tardist. This target does the actual work of turning the distdir into + a tarball. + + =cut + + sub tarfile_target { + my($self) = shift; + + return <<'MAKE_FRAG'; + $(DISTVNAME).tar$(SUFFIX) : distdir + $(PREOP) + $(TO_UNIX) + $(TAR) $(TARFLAGS) $(DISTVNAME).tar $(DISTVNAME) + $(RM_RF) $(DISTVNAME) + $(COMPRESS) $(DISTVNAME).tar + $(NOECHO) $(ECHO) 'Created $(DISTVNAME).tar$(SUFFIX)' + $(POSTOP) + MAKE_FRAG + } + + =item zipfile_target + + my $make_frag = $MM->zipfile_target; + + The name of this target is the name of the zip file generated by + zipdist. This target does the actual work of turning the distdir into + a zip file. + + =cut + + sub zipfile_target { + my($self) = shift; + + return <<'MAKE_FRAG'; + $(DISTVNAME).zip : distdir + $(PREOP) + $(ZIP) $(ZIPFLAGS) $(DISTVNAME).zip $(DISTVNAME) + $(RM_RF) $(DISTVNAME) + $(NOECHO) $(ECHO) 'Created $(DISTVNAME).zip' + $(POSTOP) + MAKE_FRAG + } + + =item uutardist_target + + my $make_frag = $MM->uutardist_target; + + Converts the tarfile into a uuencoded file + + =cut + + sub uutardist_target { + my($self) = shift; + + return <<'MAKE_FRAG'; + uutardist : $(DISTVNAME).tar$(SUFFIX) + uuencode $(DISTVNAME).tar$(SUFFIX) $(DISTVNAME).tar$(SUFFIX) > $(DISTVNAME).tar$(SUFFIX)_uu + $(NOECHO) $(ECHO) 'Created $(DISTVNAME).tar$(SUFFIX)_uu' + MAKE_FRAG + } + + + =item shdist_target + + my $make_frag = $MM->shdist_target; + + Converts the distdir into a shell archive. + + =cut + + sub shdist_target { + my($self) = shift; + + return <<'MAKE_FRAG'; + shdist : distdir + $(PREOP) + $(SHAR) $(DISTVNAME) > $(DISTVNAME).shar + $(RM_RF) $(DISTVNAME) + $(NOECHO) $(ECHO) 'Created $(DISTVNAME).shar' + $(POSTOP) + MAKE_FRAG + } + + + =item dlsyms (o) + + Used by some OS' to define DL_FUNCS and DL_VARS and write the *.exp files. + + Normally just returns an empty string. + + =cut + + sub dlsyms { + return ''; + } + + + =item dynamic_bs (o) + + Defines targets for bootstrap files. + + =cut + + sub dynamic_bs { + my($self, %attribs) = @_; + return "\nBOOTSTRAP =\n" unless $self->has_link_code(); + my @exts; + if ($self->{XSMULTI}) { + @exts = $self->_xs_list_basenames; + } else { + @exts = '$(BASEEXT)'; + } + return join "\n", + "BOOTSTRAP = @{[map { qq{$_.bs} } @exts]}\n", + map { $self->_xs_make_bs($_) } @exts; + } + + sub _xs_make_bs { + my ($self, $basename) = @_; + my ($v, $d, $f) = File::Spec->splitpath($basename); + my @d = File::Spec->splitdir($d); + shift @d if $self->{XSMULTI} and $d[0] eq 'lib'; + my $instdir = File::Spec->catdir('$(INST_ARCHLIB)', 'auto', @d, $f); + $instdir = '$(INST_ARCHAUTODIR)' if $basename eq '$(BASEEXT)'; + my $instfile = File::Spec->catfile($instdir, "$f.bs"); + my $exists = "$instdir\$(DFSEP).exists"; # match blibdirs_target + # 1 2 3 + return _sprintf562 <<'MAKE_FRAG', $basename, $instfile, $exists; + # As Mkbootstrap might not write a file (if none is required) + # we use touch to prevent make continually trying to remake it. + # The DynaLoader only reads a non-empty file. + %1$s.bs : $(FIRST_MAKEFILE) $(BOOTDEP) + $(NOECHO) $(ECHO) "Running Mkbootstrap for %1$s ($(BSLOADLIBS))" + $(NOECHO) $(PERLRUN) \ + "-MExtUtils::Mkbootstrap" \ + -e "Mkbootstrap('%1$s','$(BSLOADLIBS)');" + $(NOECHO) $(TOUCH) "%1$s.bs" + $(CHMOD) $(PERM_RW) "%1$s.bs" + + %2$s : %1$s.bs %3$s + $(NOECHO) $(RM_RF) %2$s + - $(CP_NONEMPTY) %1$s.bs %2$s $(PERM_RW) + MAKE_FRAG + } + + =item dynamic_lib (o) + + Defines how to produce the *.so (or equivalent) files. + + =cut + + sub dynamic_lib { + my($self, %attribs) = @_; + return '' unless $self->needs_linking(); #might be because of a subdir + return '' unless $self->has_link_code; + my @m = $self->xs_dynamic_lib_macros(\%attribs); + my @libs; + if ($self->{XSMULTI}) { + my @exts = $self->_xs_list_basenames; + for my $ext (@exts) { + my ($v, $d, $f) = File::Spec->splitpath($ext); + my @d = File::Spec->splitdir($d); + shift @d if $d[0] eq 'lib'; + my $instdir = File::Spec->catdir('$(INST_ARCHLIB)', 'auto', @d, $f); + my $instfile = File::Spec->catfile($instdir, "$f.\$(DLEXT)"); + my $objfile = $self->_xsbuild_value('xs', $ext, 'OBJECT'); + $objfile = "$ext\$(OBJ_EXT)" unless defined $objfile; + my $ldfrom = $self->_xsbuild_value('xs', $ext, 'LDFROM'); + $ldfrom = $objfile unless defined $ldfrom; + my $exportlist = "$ext.def"; + push @libs, [ $objfile, $instfile, $instdir, $ldfrom, $exportlist ]; + } + } else { + @libs = ([ qw($(OBJECT) $(INST_DYNAMIC) $(INST_ARCHAUTODIR) $(LDFROM) $(EXPORT_LIST)) ]); + } + push @m, map { $self->xs_make_dynamic_lib(\%attribs, @$_); } @libs; + + return join("\n",@m); + } + + =item xs_dynamic_lib_macros + + Defines the macros for the C section. + + =cut + + sub xs_dynamic_lib_macros { + my ($self, $attribs) = @_; + my $otherldflags = $attribs->{OTHERLDFLAGS} || ""; + my $inst_dynamic_dep = $attribs->{INST_DYNAMIC_DEP} || ""; + my $armaybe = $self->_xs_armaybe($attribs); + my $ld_opt = $Is{OS2} ? '$(OPTIMIZE) ' : ''; # Useful on other systems too? + my $ld_fix = $Is{OS2} ? '|| ( $(RM_F) $@ && sh -c false )' : ''; + sprintf <<'EOF', $armaybe, $ld_opt.$otherldflags, $inst_dynamic_dep, $ld_fix; + # This section creates the dynamically loadable objects from relevant + # objects and possibly $(MYEXTLIB). + ARMAYBE = %s + OTHERLDFLAGS = %s + INST_DYNAMIC_DEP = %s + INST_DYNAMIC_FIX = %s + EOF + } + + sub _xs_armaybe { + my ($self, $attribs) = @_; + my $armaybe = $attribs->{ARMAYBE} || $self->{ARMAYBE} || ":"; + $armaybe = 'ar' if ($Is{OSF} and $armaybe eq ':'); + $armaybe; + } + + =item xs_make_dynamic_lib + + Defines the recipes for the C section. + + =cut + + sub xs_make_dynamic_lib { + my ($self, $attribs, $object, $to, $todir, $ldfrom, $exportlist) = @_; + $exportlist = '' if $exportlist ne '$(EXPORT_LIST)'; + my $armaybe = $self->_xs_armaybe($attribs); + my @m = sprintf '%s : %s $(MYEXTLIB) %s$(DFSEP).exists %s $(PERL_ARCHIVEDEP) $(PERL_ARCHIVE_AFTER) $(INST_DYNAMIC_DEP)'."\n", $to, $object, $todir, $exportlist; + if ($armaybe ne ':'){ + $ldfrom = 'tmp$(LIB_EXT)'; + push(@m," \$(ARMAYBE) cr $ldfrom $object\n"); + push(@m," \$(RANLIB) $ldfrom\n"); + } + $ldfrom = "-all $ldfrom -none" if $Is{OSF}; + + # The IRIX linker doesn't use LD_RUN_PATH + my $ldrun = $Is{IRIX} && $self->{LD_RUN_PATH} ? + qq{-rpath "$self->{LD_RUN_PATH}"} : ''; + + # For example in AIX the shared objects/libraries from previous builds + # linger quite a while in the shared dynalinker cache even when nobody + # is using them. This is painful if one for instance tries to restart + # a failed build because the link command will fail unnecessarily 'cos + # the shared object/library is 'busy'. + push(@m," \$(RM_F) \$\@\n"); + + my $libs = '$(LDLOADLIBS)'; + if (($Is{NetBSD} || $Is{Interix} || $Is{Android}) && $Config{'useshrplib'} eq 'true') { + # Use nothing on static perl platforms, and to the flags needed + # to link against the shared libperl library on shared perl + # platforms. We peek at lddlflags to see if we need -Wl,-R + # or -R to add paths to the run-time library search path. + if ($Config{'lddlflags'} =~ /-Wl,-R/) { + $libs .= ' "-L$(PERL_INC)" "-Wl,-R$(INSTALLARCHLIB)/CORE" "-Wl,-R$(PERL_ARCHLIB)/CORE" -lperl'; + } elsif ($Config{'lddlflags'} =~ /-R/) { + $libs .= ' "-L$(PERL_INC)" "-R$(INSTALLARCHLIB)/CORE" "-R$(PERL_ARCHLIB)/CORE" -lperl'; + } elsif ( $Is{Android} ) { + # The Android linker will not recognize symbols from + # libperl unless the module explicitly depends on it. + $libs .= ' "-L$(PERL_INC)" -lperl'; + } + } + + my $ld_run_path_shell = ""; + if ($self->{LD_RUN_PATH} ne "") { + $ld_run_path_shell = 'LD_RUN_PATH="$(LD_RUN_PATH)" '; + } + + push @m, sprintf <<'MAKE', $ld_run_path_shell, $ldrun, $self->xs_obj_opt('$@'), $ldfrom, $libs, $exportlist; + %s$(LD) %s $(LDDLFLAGS) %s $(OTHERLDFLAGS) %s $(MYEXTLIB) \ + $(PERL_ARCHIVE) %s $(PERL_ARCHIVE_AFTER) %s \ + $(INST_DYNAMIC_FIX) + $(CHMOD) $(PERM_RWX) $@ + MAKE + join '', @m; + } + + =item exescan + + Deprecated method. Use libscan instead. + + =cut + + sub exescan { + my($self,$path) = @_; + $path; + } + + =item extliblist + + Called by init_others, and calls ext ExtUtils::Liblist. See + L for details. + + =cut + + sub extliblist { + my($self,$libs) = @_; + require ExtUtils::Liblist; + $self->ext($libs, $Verbose); + } + + =item find_perl + + Finds the executables PERL and FULLPERL + + =cut + + sub find_perl { + my($self, $ver, $names, $dirs, $trace) = @_; + + if ($trace >= 2){ + print "Looking for perl $ver by these names: + @$names + in these dirs: + @$dirs + "; + } + + my $stderr_duped = 0; + local *STDERR_COPY; + + unless ($Is{BSD}) { + # >& and lexical filehandles together give 5.6.2 indigestion + if( open(STDERR_COPY, '>&STDERR') ) { ## no critic + $stderr_duped = 1; + } + else { + warn <{PERL_SRC} may be undefined + my ($abs, $val); + if ($self->file_name_is_absolute($name)) { # /foo/bar + $abs = $name; + } elsif ($self->canonpath($name) eq + $self->canonpath(basename($name))) { # foo + $abs = File::Spec->catfile($dir, $name); + } else { # foo/bar + $abs = File::Spec->catfile($Curdir, $name); + } + print "Checking $abs\n" if ($trace >= 2); + next unless $self->maybe_command($abs); + print "Executing $abs\n" if ($trace >= 2); + + my $version_check = qq{"$abs" -le "require $ver; print qq{VER_OK}"}; + + # To avoid using the unportable 2>&1 to suppress STDERR, + # we close it before running the command. + # However, thanks to a thread library bug in many BSDs + # ( http://www.freebsd.org/cgi/query-pr.cgi?pr=51535 ) + # we cannot use the fancier more portable way in here + # but instead need to use the traditional 2>&1 construct. + if ($Is{BSD}) { + $val = `$version_check 2>&1`; + } else { + close STDERR if $stderr_duped; + $val = `$version_check`; + + # 5.6.2's 3-arg open doesn't work with >& + open STDERR, ">&STDERR_COPY" ## no critic + if $stderr_duped; + } + + if ($val =~ /^VER_OK/m) { + print "Using PERL=$abs\n" if $trace; + return $abs; + } elsif ($trace >= 2) { + print "Result: '$val' ".($? >> 8)."\n"; + } + } + } + print "Unable to find a perl $ver (by these names: @$names, in these dirs: @$dirs)\n"; + 0; # false and not empty + } + + + =item fixin + + $mm->fixin(@files); + + Inserts the sharpbang or equivalent magic number to a set of @files. + + =cut + + sub fixin { # stolen from the pink Camel book, more or less + my ( $self, @files ) = @_; + + for my $file (@files) { + my $file_new = "$file.new"; + my $file_bak = "$file.bak"; + + open( my $fixin, '<', $file ) or croak "Can't process '$file': $!"; + local $/ = "\n"; + chomp( my $line = <$fixin> ); + next unless $line =~ s/^\s*\#!\s*//; # Not a shebang file. + + my $shb = $self->_fixin_replace_shebang( $file, $line ); + next unless defined $shb; + + open( my $fixout, ">", "$file_new" ) or do { + warn "Can't create new $file: $!\n"; + next; + }; + + # Print out the new #! line (or equivalent). + local $\; + local $/; + print $fixout $shb, <$fixin>; + close $fixin; + close $fixout; + + chmod 0666, $file_bak; + unlink $file_bak; + unless ( _rename( $file, $file_bak ) ) { + warn "Can't rename $file to $file_bak: $!"; + next; + } + unless ( _rename( $file_new, $file ) ) { + warn "Can't rename $file_new to $file: $!"; + unless ( _rename( $file_bak, $file ) ) { + warn "Can't rename $file_bak back to $file either: $!"; + warn "Leaving $file renamed as $file_bak\n"; + } + next; + } + unlink $file_bak; + } + continue { + system("$Config{'eunicefix'} $file") if $Config{'eunicefix'} ne ':'; + } + } + + + sub _rename { + my($old, $new) = @_; + + foreach my $file ($old, $new) { + if( $Is{VMS} and basename($file) !~ /\./ ) { + # rename() in 5.8.0 on VMS will not rename a file if it + # does not contain a dot yet it returns success. + $file = "$file."; + } + } + + return rename($old, $new); + } + + sub _fixin_replace_shebang { + my ( $self, $file, $line ) = @_; + + # Now figure out the interpreter name. + my ( $cmd, $arg ) = split ' ', $line, 2; + $cmd =~ s!^.*/!!; + + # Now look (in reverse) for interpreter in absolute PATH (unless perl). + my $interpreter; + if ( $cmd =~ m{^perl(?:\z|[^a-z])} ) { + if ( $Config{startperl} =~ m,^\#!.*/perl, ) { + $interpreter = $Config{startperl}; + $interpreter =~ s,^\#!,,; + } + else { + $interpreter = $Config{perlpath}; + } + } + else { + my (@absdirs) + = reverse grep { $self->file_name_is_absolute($_) } $self->path; + $interpreter = ''; + + foreach my $dir (@absdirs) { + my $maybefile = File::Spec->catfile($dir,$cmd); + if ( $self->maybe_command($maybefile) ) { + warn "Ignoring $interpreter in $file\n" + if $Verbose && $interpreter; + $interpreter = $maybefile; + } + } + } + + # Figure out how to invoke interpreter on this machine. + + my ($does_shbang) = $Config{'sharpbang'} =~ /^\s*\#\!/; + my ($shb) = ""; + if ($interpreter) { + print "Changing sharpbang in $file to $interpreter" + if $Verbose; + # this is probably value-free on DOSISH platforms + if ($does_shbang) { + $shb .= "$Config{'sharpbang'}$interpreter"; + $shb .= ' ' . $arg if defined $arg; + $shb .= "\n"; + } + } + else { + warn "Can't find $cmd in PATH, $file unchanged" + if $Verbose; + return; + } + return $shb + } + + =item force (o) + + Writes an empty FORCE: target. + + =cut + + sub force { + my($self) = shift; + '# Phony target to force checking subdirectories. + FORCE : + $(NOECHO) $(NOOP) + '; + } + + =item guess_name + + Guess the name of this package by examining the working directory's + name. MakeMaker calls this only if the developer has not supplied a + NAME attribute. + + =cut + + # '; + + sub guess_name { + my($self) = @_; + use Cwd 'cwd'; + my $name = basename(cwd()); + $name =~ s|[\-_][\d\.\-]+\z||; # this is new with MM 5.00, we + # strip minus or underline + # followed by a float or some such + print "Warning: Guessing NAME [$name] from current directory name.\n"; + $name; + } + + =item has_link_code + + Returns true if C, XS, MYEXTLIB or similar objects exist within this + object that need a compiler. Does not descend into subdirectories as + needs_linking() does. + + =cut + + sub has_link_code { + my($self) = shift; + return $self->{HAS_LINK_CODE} if defined $self->{HAS_LINK_CODE}; + if ($self->{OBJECT} or @{$self->{C} || []} or $self->{MYEXTLIB}){ + $self->{HAS_LINK_CODE} = 1; + return 1; + } + return $self->{HAS_LINK_CODE} = 0; + } + + + =item init_dirscan + + Scans the directory structure and initializes DIR, XS, XS_FILES, + C, C_FILES, O_FILES, H, H_FILES, PL_FILES, EXE_FILES. + + Called by init_main. + + =cut + + sub init_dirscan { # --- File and Directory Lists (.xs .pm .pod etc) + my($self) = @_; + my(%dir, %xs, %c, %o, %h, %pl_files, %pm); + + my %ignore = map {( $_ => 1 )} qw(Makefile.PL Build.PL test.pl t); + + # ignore the distdir + $Is{VMS} ? $ignore{"$self->{DISTVNAME}.dir"} = 1 + : $ignore{$self->{DISTVNAME}} = 1; + + my $distprefix = $Is{VMS} ? qr/^\Q$self->{DISTNAME}\E-v?[\d\.]+\.dir$/i + : qr/^\Q$self->{DISTNAME}\E-v?[\d\.]+$/; + + @ignore{map lc, keys %ignore} = values %ignore if $Is{VMS}; + + if ( defined $self->{XS} and !defined $self->{C} ) { + my @c_files = grep { m/\.c(pp|xx)?\z/i } values %{$self->{XS}}; + my @o_files = grep { m/(?:.(?:o(?:bj)?)|\$\(OBJ_EXT\))\z/i } values %{$self->{XS}}; + %c = map { $_ => 1 } @c_files; + %o = map { $_ => 1 } @o_files; + } + + foreach my $name ($self->lsdir($Curdir)){ + next if $name =~ /\#/; + next if $name =~ $distprefix && -d $name; + $name = lc($name) if $Is{VMS}; + next if $name eq $Curdir or $name eq $Updir or $ignore{$name}; + next unless $self->libscan($name); + if (-d $name){ + next if -l $name; # We do not support symlinks at all + next if $self->{NORECURS}; + $dir{$name} = $name if (-f File::Spec->catfile($name,"Makefile.PL")); + } elsif ($name =~ /\.xs\z/){ + my($c); ($c = $name) =~ s/\.xs\z/.c/; + $xs{$name} = $c; + $c{$c} = 1; + } elsif ($name =~ /\.c(pp|xx|c)?\z/i){ # .c .C .cpp .cxx .cc + $c{$name} = 1 + unless $name =~ m/perlmain\.c/; # See MAP_TARGET + } elsif ($name =~ /\.h\z/i){ + $h{$name} = 1; + } elsif ($name =~ /\.PL\z/) { + ($pl_files{$name} = $name) =~ s/\.PL\z// ; + } elsif (($Is{VMS} || $Is{Dos}) && $name =~ /[._]pl$/i) { + # case-insensitive filesystem, one dot per name, so foo.h.PL + # under Unix appears as foo.h_pl under VMS or fooh.pl on Dos + local($/); open(my $pl, '<', $name); my $txt = <$pl>; close $pl; + if ($txt =~ /Extracting \S+ \(with variable substitutions/) { + ($pl_files{$name} = $name) =~ s/[._]pl\z//i ; + } + else { + $pm{$name} = File::Spec->catfile($self->{INST_LIBDIR},$name); + } + } elsif ($name =~ /\.(p[ml]|pod)\z/){ + $pm{$name} = File::Spec->catfile($self->{INST_LIBDIR},$name); + } + } + + $self->{PL_FILES} ||= \%pl_files; + $self->{DIR} ||= [sort keys %dir]; + $self->{XS} ||= \%xs; + $self->{C} ||= [sort keys %c]; + $self->{H} ||= [sort keys %h]; + $self->{PM} ||= \%pm; + + my @o_files = @{$self->{C}}; + %o = (%o, map { $_ => 1 } grep s/\.c(pp|xx|c)?\z/$self->{OBJ_EXT}/i, @o_files); + $self->{O_FILES} = [sort keys %o]; + } + + + =item init_MANPODS + + Determines if man pages should be generated and initializes MAN1PODS + and MAN3PODS as appropriate. + + =cut + + sub init_MANPODS { + my $self = shift; + + # Set up names of manual pages to generate from pods + foreach my $man (qw(MAN1 MAN3)) { + if ( $self->{"${man}PODS"} + or $self->{"INSTALL${man}DIR"} =~ /^(none|\s*)$/ + ) { + $self->{"${man}PODS"} ||= {}; + } + else { + my $init_method = "init_${man}PODS"; + $self->$init_method(); + } + } + } + + + sub _has_pod { + my($self, $file) = @_; + + my($ispod)=0; + if (open( my $fh, '<', $file )) { + while (<$fh>) { + if (/^=(?:head\d+|item|pod)\b/) { + $ispod=1; + last; + } + } + close $fh; + } else { + # If it doesn't exist yet, we assume, it has pods in it + $ispod = 1; + } + + return $ispod; + } + + + =item init_MAN1PODS + + Initializes MAN1PODS from the list of EXE_FILES. + + =cut + + sub init_MAN1PODS { + my($self) = @_; + + if ( exists $self->{EXE_FILES} ) { + foreach my $name (@{$self->{EXE_FILES}}) { + next unless $self->_has_pod($name); + + $self->{MAN1PODS}->{$name} = + File::Spec->catfile("\$(INST_MAN1DIR)", + basename($name).".\$(MAN1EXT)"); + } + } + } + + + =item init_MAN3PODS + + Initializes MAN3PODS from the list of PM files. + + =cut + + sub init_MAN3PODS { + my $self = shift; + + my %manifypods = (); # we collect the keys first, i.e. the files + # we have to convert to pod + + foreach my $name (keys %{$self->{PM}}) { + if ($name =~ /\.pod\z/ ) { + $manifypods{$name} = $self->{PM}{$name}; + } elsif ($name =~ /\.p[ml]\z/ ) { + if( $self->_has_pod($name) ) { + $manifypods{$name} = $self->{PM}{$name}; + } + } + } + + my $parentlibs_re = join '|', @{$self->{PMLIBPARENTDIRS}}; + + # Remove "Configure.pm" and similar, if it's not the only pod listed + # To force inclusion, just name it "Configure.pod", or override + # MAN3PODS + foreach my $name (keys %manifypods) { + if ( + ($self->{PERL_CORE} and $name =~ /(config|setup).*\.pm/is) or + ( $name eq 'README.pod') # don't manify top-level README.pod + ) { + delete $manifypods{$name}; + next; + } + my($manpagename) = $name; + $manpagename =~ s/\.p(od|m|l)\z//; + # everything below lib is ok + unless($manpagename =~ s!^\W*($parentlibs_re)\W+!!s) { + $manpagename = File::Spec->catfile( + split(/::/,$self->{PARENT_NAME}),$manpagename + ); + } + $manpagename = $self->replace_manpage_separator($manpagename); + $self->{MAN3PODS}->{$name} = + File::Spec->catfile("\$(INST_MAN3DIR)", "$manpagename.\$(MAN3EXT)"); + } + } + + + =item init_PM + + Initializes PMLIBDIRS and PM from PMLIBDIRS. + + =cut + + sub init_PM { + my $self = shift; + + # Some larger extensions often wish to install a number of *.pm/pl + # files into the library in various locations. + + # The attribute PMLIBDIRS holds an array reference which lists + # subdirectories which we should search for library files to + # install. PMLIBDIRS defaults to [ 'lib', $self->{BASEEXT} ]. We + # recursively search through the named directories (skipping any + # which don't exist or contain Makefile.PL files). + + # For each *.pm or *.pl file found $self->libscan() is called with + # the default installation path in $_[1]. The return value of + # libscan defines the actual installation location. The default + # libscan function simply returns the path. The file is skipped + # if libscan returns false. + + # The default installation location passed to libscan in $_[1] is: + # + # ./*.pm => $(INST_LIBDIR)/*.pm + # ./xyz/... => $(INST_LIBDIR)/xyz/... + # ./lib/... => $(INST_LIB)/... + # + # In this way the 'lib' directory is seen as the root of the actual + # perl library whereas the others are relative to INST_LIBDIR + # (which includes PARENT_NAME). This is a subtle distinction but one + # that's important for nested modules. + + unless( $self->{PMLIBDIRS} ) { + if( $Is{VMS} ) { + # Avoid logical name vs directory collisions + $self->{PMLIBDIRS} = ['./lib', "./$self->{BASEEXT}"]; + } + else { + $self->{PMLIBDIRS} = ['lib', $self->{BASEEXT}]; + } + } + + #only existing directories that aren't in $dir are allowed + + # Avoid $_ wherever possible: + # @{$self->{PMLIBDIRS}} = grep -d && !$dir{$_}, @{$self->{PMLIBDIRS}}; + my (@pmlibdirs) = @{$self->{PMLIBDIRS}}; + @{$self->{PMLIBDIRS}} = (); + my %dir = map { ($_ => $_) } @{$self->{DIR}}; + foreach my $pmlibdir (@pmlibdirs) { + -d $pmlibdir && !$dir{$pmlibdir} && push @{$self->{PMLIBDIRS}}, $pmlibdir; + } + + unless( $self->{PMLIBPARENTDIRS} ) { + @{$self->{PMLIBPARENTDIRS}} = ('lib'); + } + + return if $self->{PM} and $self->{ARGS}{PM}; + + if (@{$self->{PMLIBDIRS}}){ + print "Searching PMLIBDIRS: @{$self->{PMLIBDIRS}}\n" + if ($Verbose >= 2); + require File::Find; + File::Find::find(sub { + if (-d $_){ + unless ($self->libscan($_)){ + $File::Find::prune = 1; + } + return; + } + return if /\#/; + return if /~$/; # emacs temp files + return if /,v$/; # RCS files + return if m{\.swp$}; # vim swap files + + my $path = $File::Find::name; + my $prefix = $self->{INST_LIBDIR}; + my $striplibpath; + + my $parentlibs_re = join '|', @{$self->{PMLIBPARENTDIRS}}; + $prefix = $self->{INST_LIB} + if ($striplibpath = $path) =~ s{^(\W*)($parentlibs_re)\W} + {$1}i; + + my($inst) = File::Spec->catfile($prefix,$striplibpath); + local($_) = $inst; # for backwards compatibility + $inst = $self->libscan($inst); + print "libscan($path) => '$inst'\n" if ($Verbose >= 2); + return unless $inst; + if ($self->{XSMULTI} and $inst =~ /\.xs\z/) { + my($base); ($base = $path) =~ s/\.xs\z//; + $self->{XS}{$path} = "$base.c"; + push @{$self->{C}}, "$base.c"; + push @{$self->{O_FILES}}, "$base$self->{OBJ_EXT}"; + } else { + $self->{PM}{$path} = $inst; + } + }, @{$self->{PMLIBDIRS}}); + } + } + + + =item init_DIRFILESEP + + Using / for Unix. Called by init_main. + + =cut + + sub init_DIRFILESEP { + my($self) = shift; + + $self->{DIRFILESEP} = '/'; + } + + + =item init_main + + Initializes AR, AR_STATIC_ARGS, BASEEXT, CONFIG, DISTNAME, DLBASE, + EXE_EXT, FULLEXT, FULLPERL, FULLPERLRUN, FULLPERLRUNINST, INST_*, + INSTALL*, INSTALLDIRS, LIB_EXT, LIBPERL_A, MAP_TARGET, NAME, + OBJ_EXT, PARENT_NAME, PERL, PERL_ARCHLIB, PERL_INC, PERL_LIB, + PERL_SRC, PERLRUN, PERLRUNINST, PREFIX, VERSION, + VERSION_SYM, XS_VERSION. + + =cut + + sub init_main { + my($self) = @_; + + # --- Initialize Module Name and Paths + + # NAME = Foo::Bar::Oracle + # FULLEXT = Foo/Bar/Oracle + # BASEEXT = Oracle + # PARENT_NAME = Foo::Bar + ### Only UNIX: + ### ($self->{FULLEXT} = + ### $self->{NAME}) =~ s!::!/!g ; #eg. BSD/Foo/Socket + $self->{FULLEXT} = File::Spec->catdir(split /::/, $self->{NAME}); + + + # Copied from DynaLoader: + + my(@modparts) = split(/::/,$self->{NAME}); + my($modfname) = $modparts[-1]; + + # Some systems have restrictions on files names for DLL's etc. + # mod2fname returns appropriate file base name (typically truncated) + # It may also edit @modparts if required. + # We require DynaLoader to make sure that mod2fname is loaded + eval { require DynaLoader }; + if (defined &DynaLoader::mod2fname) { + $modfname = &DynaLoader::mod2fname(\@modparts); + } + + ($self->{PARENT_NAME}, $self->{BASEEXT}) = $self->{NAME} =~ m!(?:([\w:]+)::)?(\w+)\z! ; + $self->{PARENT_NAME} ||= ''; + + if (defined &DynaLoader::mod2fname) { + # As of 5.001m, dl_os2 appends '_' + $self->{DLBASE} = $modfname; + } else { + $self->{DLBASE} = '$(BASEEXT)'; + } + + + # --- Initialize PERL_LIB, PERL_SRC + + # *Real* information: where did we get these two from? ... + my $inc_config_dir = dirname($INC{'Config.pm'}); + my $inc_carp_dir = dirname($INC{'Carp.pm'}); + + unless ($self->{PERL_SRC}){ + foreach my $dir_count (1..8) { # 8 is the VMS limit for nesting + my $dir = File::Spec->catdir(($Updir) x $dir_count); + + if (-f File::Spec->catfile($dir,"config_h.SH") && + -f File::Spec->catfile($dir,"perl.h") && + -f File::Spec->catfile($dir,"lib","strict.pm") + ) { + $self->{PERL_SRC}=$dir ; + last; + } + } + } + + warn "PERL_CORE is set but I can't find your PERL_SRC!\n" if + $self->{PERL_CORE} and !$self->{PERL_SRC}; + + if ($self->{PERL_SRC}){ + $self->{PERL_LIB} ||= File::Spec->catdir("$self->{PERL_SRC}","lib"); + + $self->{PERL_ARCHLIB} = $self->{PERL_LIB}; + $self->{PERL_INC} = ($Is{Win32}) ? + File::Spec->catdir($self->{PERL_LIB},"CORE") : $self->{PERL_SRC}; + + # catch a situation that has occurred a few times in the past: + unless ( + -s File::Spec->catfile($self->{PERL_SRC},'cflags') + or + $Is{VMS} + && + -s File::Spec->catfile($self->{PERL_SRC},'vmsish.h') + or + $Is{Win32} + ){ + warn qq{ + You cannot build extensions below the perl source tree after executing + a 'make clean' in the perl source tree. + + To rebuild extensions distributed with the perl source you should + simply Configure (to include those extensions) and then build perl as + normal. After installing perl the source tree can be deleted. It is + not needed for building extensions by running 'perl Makefile.PL' + usually without extra arguments. + + It is recommended that you unpack and build additional extensions away + from the perl source tree. + }; + } + } else { + # we should also consider $ENV{PERL5LIB} here + my $old = $self->{PERL_LIB} || $self->{PERL_ARCHLIB} || $self->{PERL_INC}; + $self->{PERL_LIB} ||= $Config{privlibexp}; + $self->{PERL_ARCHLIB} ||= $Config{archlibexp}; + $self->{PERL_INC} = File::Spec->catdir("$self->{PERL_ARCHLIB}","CORE"); # wild guess for now + my $perl_h; + + if (not -f ($perl_h = File::Spec->catfile($self->{PERL_INC},"perl.h")) + and not $old){ + # Maybe somebody tries to build an extension with an + # uninstalled Perl outside of Perl build tree + my $lib; + for my $dir (@INC) { + $lib = $dir, last if -e File::Spec->catfile($dir, "Config.pm"); + } + if ($lib) { + # Win32 puts its header files in /perl/src/lib/CORE. + # Unix leaves them in /perl/src. + my $inc = $Is{Win32} ? File::Spec->catdir($lib, "CORE" ) + : dirname $lib; + if (-e File::Spec->catfile($inc, "perl.h")) { + $self->{PERL_LIB} = $lib; + $self->{PERL_ARCHLIB} = $lib; + $self->{PERL_INC} = $inc; + $self->{UNINSTALLED_PERL} = 1; + print <{PERL_LIB} = File::Spec->rel2abs($self->{PERL_LIB}); + $self->{PERL_ARCHLIB} = File::Spec->rel2abs($self->{PERL_ARCHLIB}); + } + $self->{PERL_INCDEP} = $self->{PERL_INC}; + $self->{PERL_ARCHLIBDEP} = $self->{PERL_ARCHLIB}; + + # We get SITELIBEXP and SITEARCHEXP directly via + # Get_from_Config. When we are running standard modules, these + # won't matter, we will set INSTALLDIRS to "perl". Otherwise we + # set it to "site". I prefer that INSTALLDIRS be set from outside + # MakeMaker. + $self->{INSTALLDIRS} ||= "site"; + + $self->{MAN1EXT} ||= $Config{man1ext}; + $self->{MAN3EXT} ||= $Config{man3ext}; + + # Get some stuff out of %Config if we haven't yet done so + print "CONFIG must be an array ref\n" + if ($self->{CONFIG} and ref $self->{CONFIG} ne 'ARRAY'); + $self->{CONFIG} = [] unless (ref $self->{CONFIG}); + push(@{$self->{CONFIG}}, @ExtUtils::MakeMaker::Get_from_Config); + push(@{$self->{CONFIG}}, 'shellflags') if $Config{shellflags}; + my(%once_only); + foreach my $m (@{$self->{CONFIG}}){ + next if $once_only{$m}; + print "CONFIG key '$m' does not exist in Config.pm\n" + unless exists $Config{$m}; + $self->{uc $m} ||= $Config{$m}; + $once_only{$m} = 1; + } + + # This is too dangerous: + # if ($^O eq "next") { + # $self->{AR} = "libtool"; + # $self->{AR_STATIC_ARGS} = "-o"; + # } + # But I leave it as a placeholder + + $self->{AR_STATIC_ARGS} ||= "cr"; + + # These should never be needed + $self->{OBJ_EXT} ||= '.o'; + $self->{LIB_EXT} ||= '.a'; + + $self->{MAP_TARGET} ||= "perl"; + + $self->{LIBPERL_A} ||= "libperl$self->{LIB_EXT}"; + + # make a simple check if we find strict + warn "Warning: PERL_LIB ($self->{PERL_LIB}) seems not to be a perl library directory + (strict.pm not found)" + unless -f File::Spec->catfile("$self->{PERL_LIB}","strict.pm") || + $self->{NAME} eq "ExtUtils::MakeMaker"; + } + + =item init_tools + + Initializes tools to use their common (and faster) Unix commands. + + =cut + + sub init_tools { + my $self = shift; + + $self->{ECHO} ||= 'echo'; + $self->{ECHO_N} ||= 'echo -n'; + $self->{RM_F} ||= "rm -f"; + $self->{RM_RF} ||= "rm -rf"; + $self->{TOUCH} ||= "touch"; + $self->{TEST_F} ||= "test -f"; + $self->{TEST_S} ||= "test -s"; + $self->{CP} ||= "cp"; + $self->{MV} ||= "mv"; + $self->{CHMOD} ||= "chmod"; + $self->{FALSE} ||= 'false'; + $self->{TRUE} ||= 'true'; + + $self->{LD} ||= 'ld'; + + return $self->SUPER::init_tools(@_); + + # After SUPER::init_tools so $Config{shell} has a + # chance to get set. + $self->{SHELL} ||= '/bin/sh'; + + return; + } + + + =item init_linker + + Unix has no need of special linker flags. + + =cut + + sub init_linker { + my($self) = shift; + $self->{PERL_ARCHIVE} ||= ''; + $self->{PERL_ARCHIVEDEP} ||= ''; + $self->{PERL_ARCHIVE_AFTER} ||= ''; + $self->{EXPORT_LIST} ||= ''; + } + + + =begin _protected + + =item init_lib2arch + + $mm->init_lib2arch + + =end _protected + + =cut + + sub init_lib2arch { + my($self) = shift; + + # The user who requests an installation directory explicitly + # should not have to tell us an architecture installation directory + # as well. We look if a directory exists that is named after the + # architecture. If not we take it as a sign that it should be the + # same as the requested installation directory. Otherwise we take + # the found one. + for my $libpair ({l=>"privlib", a=>"archlib"}, + {l=>"sitelib", a=>"sitearch"}, + {l=>"vendorlib", a=>"vendorarch"}, + ) + { + my $lib = "install$libpair->{l}"; + my $Lib = uc $lib; + my $Arch = uc "install$libpair->{a}"; + if( $self->{$Lib} && ! $self->{$Arch} ){ + my($ilib) = $Config{$lib}; + + $self->prefixify($Arch,$ilib,$self->{$Lib}); + + unless (-d $self->{$Arch}) { + print "Directory $self->{$Arch} not found\n" + if $Verbose; + $self->{$Arch} = $self->{$Lib}; + } + print "Defaulting $Arch to $self->{$Arch}\n" if $Verbose; + } + } + } + + + =item init_PERL + + $mm->init_PERL; + + Called by init_main. Sets up ABSPERL, PERL, FULLPERL and all the + *PERLRUN* permutations. + + PERL is allowed to be miniperl + FULLPERL must be a complete perl + + ABSPERL is PERL converted to an absolute path + + *PERLRUN contains everything necessary to run perl, find it's + libraries, etc... + + *PERLRUNINST is *PERLRUN + everything necessary to find the + modules being built. + + =cut + + sub init_PERL { + my($self) = shift; + + my @defpath = (); + foreach my $component ($self->{PERL_SRC}, $self->path(), + $Config{binexp}) + { + push @defpath, $component if defined $component; + } + + # Build up a set of file names (not command names). + my $thisperl = $self->canonpath($^X); + $thisperl .= $Config{exe_ext} unless + # VMS might have a file version # at the end + $Is{VMS} ? $thisperl =~ m/$Config{exe_ext}(;\d+)?$/i + : $thisperl =~ m/$Config{exe_ext}$/i; + + # We need a relative path to perl when in the core. + $thisperl = $self->abs2rel($thisperl) if $self->{PERL_CORE}; + + my @perls = ($thisperl); + push @perls, map { "$_$Config{exe_ext}" } + ("perl$Config{version}", 'perl5', 'perl'); + + # miniperl has priority over all but the canonical perl when in the + # core. Otherwise its a last resort. + my $miniperl = "miniperl$Config{exe_ext}"; + if( $self->{PERL_CORE} ) { + splice @perls, 1, 0, $miniperl; + } + else { + push @perls, $miniperl; + } + + $self->{PERL} ||= + $self->find_perl(5.0, \@perls, \@defpath, $Verbose ); + + my $perl = $self->{PERL}; + $perl =~ s/^"//; + my $has_mcr = $perl =~ s/^MCR\s*//; + my $perlflags = ''; + my $stripped_perl; + while ($perl) { + ($stripped_perl = $perl) =~ s/"$//; + last if -x $stripped_perl; + last unless $perl =~ s/(\s+\S+)$//; + $perlflags = $1.$perlflags; + } + $self->{PERL} = $stripped_perl; + $self->{PERL} = 'MCR '.$self->{PERL} if $has_mcr || $Is{VMS}; + + # When built for debugging, VMS doesn't create perl.exe but ndbgperl.exe. + my $perl_name = 'perl'; + $perl_name = 'ndbgperl' if $Is{VMS} && + defined $Config{usevmsdebug} && $Config{usevmsdebug} eq 'define'; + + # XXX This logic is flawed. If "miniperl" is anywhere in the path + # it will get confused. It should be fixed to work only on the filename. + # Define 'FULLPERL' to be a non-miniperl (used in test: target) + unless ($self->{FULLPERL}) { + ($self->{FULLPERL} = $self->{PERL}) =~ s/\Q$miniperl\E$/$perl_name$Config{exe_ext}/i; + $self->{FULLPERL} = qq{"$self->{FULLPERL}"}.$perlflags; + } + # Can't have an image name with quotes, and findperl will have + # already escaped spaces. + $self->{FULLPERL} =~ tr/"//d if $Is{VMS}; + + # Little hack to get around VMS's find_perl putting "MCR" in front + # sometimes. + $self->{ABSPERL} = $self->{PERL}; + $has_mcr = $self->{ABSPERL} =~ s/^MCR\s*//; + if( $self->file_name_is_absolute($self->{ABSPERL}) ) { + $self->{ABSPERL} = '$(PERL)'; + } + else { + $self->{ABSPERL} = $self->rel2abs($self->{ABSPERL}); + + # Quote the perl command if it contains whitespace + $self->{ABSPERL} = $self->quote_literal($self->{ABSPERL}) + if $self->{ABSPERL} =~ /\s/; + + $self->{ABSPERL} = 'MCR '.$self->{ABSPERL} if $has_mcr; + } + $self->{PERL} = qq{"$self->{PERL}"}.$perlflags; + + # Can't have an image name with quotes, and findperl will have + # already escaped spaces. + $self->{PERL} =~ tr/"//d if $Is{VMS}; + + # Are we building the core? + $self->{PERL_CORE} = $ENV{PERL_CORE} unless exists $self->{PERL_CORE}; + $self->{PERL_CORE} = 0 unless defined $self->{PERL_CORE}; + + # Make sure perl can find itself before it's installed. + my $lib_paths = $self->{UNINSTALLED_PERL} || $self->{PERL_CORE} + ? $self->{PERL_ARCHLIB} ne $self->{PERL_LIB} ? + q{ "-I$(PERL_LIB)" "-I$(PERL_ARCHLIB)"} : q{ "-I$(PERL_LIB)"} + : undef; + my $inst_lib_paths = $self->{INST_ARCHLIB} ne $self->{INST_LIB} + ? 'RUN)'.$perlflags.' "-I$(INST_ARCHLIB)" "-I$(INST_LIB)"' + : 'RUN)'.$perlflags.' "-I$(INST_LIB)"'; + # How do we run perl? + foreach my $perl (qw(PERL FULLPERL ABSPERL)) { + my $run = $perl.'RUN'; + + $self->{$run} = qq{\$($perl)}; + $self->{$run} .= $lib_paths if $lib_paths; + + $self->{$perl.'RUNINST'} = '$('.$perl.$inst_lib_paths; + } + + return 1; + } + + + =item init_platform + + =item platform_constants + + Add MM_Unix_VERSION. + + =cut + + sub init_platform { + my($self) = shift; + + $self->{MM_Unix_VERSION} = $VERSION; + $self->{PERL_MALLOC_DEF} = '-DPERL_EXTMALLOC_DEF -Dmalloc=Perl_malloc '. + '-Dfree=Perl_mfree -Drealloc=Perl_realloc '. + '-Dcalloc=Perl_calloc'; + + } + + sub platform_constants { + my($self) = shift; + my $make_frag = ''; + + foreach my $macro (qw(MM_Unix_VERSION PERL_MALLOC_DEF)) + { + next unless defined $self->{$macro}; + $make_frag .= "$macro = $self->{$macro}\n"; + } + + return $make_frag; + } + + + =item init_PERM + + $mm->init_PERM + + Called by init_main. Initializes PERL_* + + =cut + + sub init_PERM { + my($self) = shift; + + $self->{PERM_DIR} = 755 unless defined $self->{PERM_DIR}; + $self->{PERM_RW} = 644 unless defined $self->{PERM_RW}; + $self->{PERM_RWX} = 755 unless defined $self->{PERM_RWX}; + + return 1; + } + + + =item init_xs + + $mm->init_xs + + Sets up macros having to do with XS code. Currently just INST_STATIC, + INST_DYNAMIC and INST_BOOT. + + =cut + + sub init_xs { + my $self = shift; + + if ($self->has_link_code()) { + $self->{INST_STATIC} = + File::Spec->catfile('$(INST_ARCHAUTODIR)', '$(BASEEXT)$(LIB_EXT)'); + $self->{INST_DYNAMIC} = + File::Spec->catfile('$(INST_ARCHAUTODIR)', '$(DLBASE).$(DLEXT)'); + $self->{INST_BOOT} = + File::Spec->catfile('$(INST_ARCHAUTODIR)', '$(BASEEXT).bs'); + if ($self->{XSMULTI}) { + my @exts = $self->_xs_list_basenames; + my (@statics, @dynamics, @boots); + for my $ext (@exts) { + my ($v, $d, $f) = File::Spec->splitpath($ext); + my @d = File::Spec->splitdir($d); + shift @d if defined $d[0] and $d[0] eq 'lib'; + my $instdir = File::Spec->catdir('$(INST_ARCHLIB)', 'auto', @d, $f); + my $instfile = File::Spec->catfile($instdir, $f); + push @statics, "$instfile\$(LIB_EXT)"; + push @dynamics, "$instfile.\$(DLEXT)"; + push @boots, "$instfile.bs"; + } + $self->{INST_STATIC} = join ' ', @statics; + $self->{INST_DYNAMIC} = join ' ', @dynamics; + $self->{INST_BOOT} = join ' ', @boots; + } + } else { + $self->{INST_STATIC} = ''; + $self->{INST_DYNAMIC} = ''; + $self->{INST_BOOT} = ''; + } + } + + =item install (o) + + Defines the install target. + + =cut + + sub install { + my($self, %attribs) = @_; + my(@m); + + push @m, q{ + install :: pure_install doc_install + $(NOECHO) $(NOOP) + + install_perl :: pure_perl_install doc_perl_install + $(NOECHO) $(NOOP) + + install_site :: pure_site_install doc_site_install + $(NOECHO) $(NOOP) + + install_vendor :: pure_vendor_install doc_vendor_install + $(NOECHO) $(NOOP) + + pure_install :: pure_$(INSTALLDIRS)_install + $(NOECHO) $(NOOP) + + doc_install :: doc_$(INSTALLDIRS)_install + $(NOECHO) $(NOOP) + + pure__install : pure_site_install + $(NOECHO) $(ECHO) INSTALLDIRS not defined, defaulting to INSTALLDIRS=site + + doc__install : doc_site_install + $(NOECHO) $(ECHO) INSTALLDIRS not defined, defaulting to INSTALLDIRS=site + + pure_perl_install :: all + $(NOECHO) $(MOD_INSTALL) \ + }; + + push @m, + q{ read "}.File::Spec->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q{" \ + write "}.File::Spec->catfile('$(DESTINSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').q{" \ + } unless $self->{NO_PACKLIST}; + + push @m, + q{ "$(INST_LIB)" "$(DESTINSTALLPRIVLIB)" \ + "$(INST_ARCHLIB)" "$(DESTINSTALLARCHLIB)" \ + "$(INST_BIN)" "$(DESTINSTALLBIN)" \ + "$(INST_SCRIPT)" "$(DESTINSTALLSCRIPT)" \ + "$(INST_MAN1DIR)" "$(DESTINSTALLMAN1DIR)" \ + "$(INST_MAN3DIR)" "$(DESTINSTALLMAN3DIR)" + $(NOECHO) $(WARN_IF_OLD_PACKLIST) \ + "}.File::Spec->catdir('$(SITEARCHEXP)','auto','$(FULLEXT)').q{" + + + pure_site_install :: all + $(NOECHO) $(MOD_INSTALL) \ + }; + push @m, + q{ read "}.File::Spec->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q{" \ + write "}.File::Spec->catfile('$(DESTINSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').q{" \ + } unless $self->{NO_PACKLIST}; + + push @m, + q{ "$(INST_LIB)" "$(DESTINSTALLSITELIB)" \ + "$(INST_ARCHLIB)" "$(DESTINSTALLSITEARCH)" \ + "$(INST_BIN)" "$(DESTINSTALLSITEBIN)" \ + "$(INST_SCRIPT)" "$(DESTINSTALLSITESCRIPT)" \ + "$(INST_MAN1DIR)" "$(DESTINSTALLSITEMAN1DIR)" \ + "$(INST_MAN3DIR)" "$(DESTINSTALLSITEMAN3DIR)" + $(NOECHO) $(WARN_IF_OLD_PACKLIST) \ + "}.File::Spec->catdir('$(PERL_ARCHLIB)','auto','$(FULLEXT)').q{" + + pure_vendor_install :: all + $(NOECHO) $(MOD_INSTALL) \ + }; + push @m, + q{ read "}.File::Spec->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').q{" \ + write "}.File::Spec->catfile('$(DESTINSTALLVENDORARCH)','auto','$(FULLEXT)','.packlist').q{" \ + } unless $self->{NO_PACKLIST}; + + push @m, + q{ "$(INST_LIB)" "$(DESTINSTALLVENDORLIB)" \ + "$(INST_ARCHLIB)" "$(DESTINSTALLVENDORARCH)" \ + "$(INST_BIN)" "$(DESTINSTALLVENDORBIN)" \ + "$(INST_SCRIPT)" "$(DESTINSTALLVENDORSCRIPT)" \ + "$(INST_MAN1DIR)" "$(DESTINSTALLVENDORMAN1DIR)" \ + "$(INST_MAN3DIR)" "$(DESTINSTALLVENDORMAN3DIR)" + + }; + + push @m, q{ + doc_perl_install :: all + $(NOECHO) $(NOOP) + + doc_site_install :: all + $(NOECHO) $(NOOP) + + doc_vendor_install :: all + $(NOECHO) $(NOOP) + + } if $self->{NO_PERLLOCAL}; + + push @m, q{ + doc_perl_install :: all + $(NOECHO) $(ECHO) Appending installation info to "$(DESTINSTALLARCHLIB)/perllocal.pod" + -$(NOECHO) $(MKPATH) "$(DESTINSTALLARCHLIB)" + -$(NOECHO) $(DOC_INSTALL) \ + "Module" "$(NAME)" \ + "installed into" "$(INSTALLPRIVLIB)" \ + LINKTYPE "$(LINKTYPE)" \ + VERSION "$(VERSION)" \ + EXE_FILES "$(EXE_FILES)" \ + >> "}.File::Spec->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{" + + doc_site_install :: all + $(NOECHO) $(ECHO) Appending installation info to "$(DESTINSTALLARCHLIB)/perllocal.pod" + -$(NOECHO) $(MKPATH) "$(DESTINSTALLARCHLIB)" + -$(NOECHO) $(DOC_INSTALL) \ + "Module" "$(NAME)" \ + "installed into" "$(INSTALLSITELIB)" \ + LINKTYPE "$(LINKTYPE)" \ + VERSION "$(VERSION)" \ + EXE_FILES "$(EXE_FILES)" \ + >> "}.File::Spec->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{" + + doc_vendor_install :: all + $(NOECHO) $(ECHO) Appending installation info to "$(DESTINSTALLARCHLIB)/perllocal.pod" + -$(NOECHO) $(MKPATH) "$(DESTINSTALLARCHLIB)" + -$(NOECHO) $(DOC_INSTALL) \ + "Module" "$(NAME)" \ + "installed into" "$(INSTALLVENDORLIB)" \ + LINKTYPE "$(LINKTYPE)" \ + VERSION "$(VERSION)" \ + EXE_FILES "$(EXE_FILES)" \ + >> "}.File::Spec->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{" + + } unless $self->{NO_PERLLOCAL}; + + push @m, q{ + uninstall :: uninstall_from_$(INSTALLDIRS)dirs + $(NOECHO) $(NOOP) + + uninstall_from_perldirs :: + $(NOECHO) $(UNINSTALL) "}.File::Spec->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').q{" + + uninstall_from_sitedirs :: + $(NOECHO) $(UNINSTALL) "}.File::Spec->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').q{" + + uninstall_from_vendordirs :: + $(NOECHO) $(UNINSTALL) "}.File::Spec->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').q{" + }; + + join("",@m); + } + + =item installbin (o) + + Defines targets to make and to install EXE_FILES. + + =cut + + sub installbin { + my($self) = shift; + + return "" unless $self->{EXE_FILES} && ref $self->{EXE_FILES} eq "ARRAY"; + my @exefiles = sort @{$self->{EXE_FILES}}; + return "" unless @exefiles; + + @exefiles = map vmsify($_), @exefiles if $Is{VMS}; + + my %fromto; + for my $from (@exefiles) { + my($path)= File::Spec->catfile('$(INST_SCRIPT)', basename($from)); + + local($_) = $path; # for backwards compatibility + my $to = $self->libscan($path); + print "libscan($from) => '$to'\n" if ($Verbose >=2); + + $to = vmsify($to) if $Is{VMS}; + $fromto{$from} = $to; + } + my @to = sort values %fromto; + + my @m; + push(@m, qq{ + EXE_FILES = @exefiles + + pure_all :: @to + \$(NOECHO) \$(NOOP) + + realclean :: + }); + + # realclean can get rather large. + push @m, map "\t$_\n", $self->split_command('$(RM_F)', @to); + push @m, "\n"; + + # A target for each exe file. + my @froms = sort keys %fromto; + for my $from (@froms) { + # 1 2 + push @m, _sprintf562 <<'MAKE', $from, $fromto{$from}; + %2$s : %1$s $(FIRST_MAKEFILE) $(INST_SCRIPT)$(DFSEP).exists $(INST_BIN)$(DFSEP).exists + $(NOECHO) $(RM_F) %2$s + $(CP) %1$s %2$s + $(FIXIN) %2$s + -$(NOECHO) $(CHMOD) $(PERM_RWX) %2$s + + MAKE + + } + + join "", @m; + } + + =item linkext (o) + + Defines the linkext target which in turn defines the LINKTYPE. + + =cut + + # LINKTYPE => static or dynamic or '' + sub linkext { + my($self, %attribs) = @_; + my $linktype = $attribs{LINKTYPE}; + $linktype = $self->{LINKTYPE} unless defined $linktype; + if (defined $linktype and $linktype eq '') { + warn "Warning: LINKTYPE set to '', no longer necessary\n"; + } + $linktype = '$(LINKTYPE)' unless defined $linktype; + " + linkext :: $linktype + \$(NOECHO) \$(NOOP) + "; + } + + =item lsdir + + Takes as arguments a directory name and a regular expression. Returns + all entries in the directory that match the regular expression. + + =cut + + sub lsdir { + my($self) = shift; + my($dir, $regex) = @_; + my(@ls); + my $dh = new DirHandle; + $dh->open($dir || ".") or return (); + @ls = $dh->read; + $dh->close; + @ls = grep(/$regex/, @ls) if $regex; + @ls; + } + + =item macro (o) + + Simple subroutine to insert the macros defined by the macro attribute + into the Makefile. + + =cut + + sub macro { + my($self,%attribs) = @_; + my(@m,$key,$val); + while (($key,$val) = each %attribs){ + last unless defined $key; + push @m, "$key = $val\n"; + } + join "", @m; + } + + =item makeaperl (o) + + Called by staticmake. Defines how to write the Makefile to produce a + static new perl. + + By default the Makefile produced includes all the static extensions in + the perl library. (Purified versions of library files, e.g., + DynaLoader_pure_p1_c0_032.a are automatically ignored to avoid link errors.) + + =cut + + sub makeaperl { + my($self, %attribs) = @_; + my($makefilename, $searchdirs, $static, $extra, $perlinc, $target, $tmp, $libperl) = + @attribs{qw(MAKE DIRS STAT EXTRA INCL TARGET TMP LIBPERL)}; + s/^(.*)/"-I$1"/ for @{$perlinc || []}; + my(@m); + push @m, " + # --- MakeMaker makeaperl section --- + MAP_TARGET = $target + FULLPERL = $self->{FULLPERL} + MAP_PERLINC = @{$perlinc || []} + "; + return join '', @m if $self->{PARENT}; + + my($dir) = join ":", @{$self->{DIR}}; + + unless ($self->{MAKEAPERL}) { + push @m, q{ + $(MAP_TARGET) :: $(MAKE_APERL_FILE) + $(MAKE) $(USEMAKEFILE) $(MAKE_APERL_FILE) $@ + + $(MAKE_APERL_FILE) : static $(FIRST_MAKEFILE) pm_to_blib + $(NOECHO) $(ECHO) Writing \"$(MAKE_APERL_FILE)\" for this $(MAP_TARGET) + $(NOECHO) $(PERLRUNINST) \ + Makefile.PL DIR="}, $dir, q{" \ + MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \ + MAKEAPERL=1 NORECURS=1 CCCDLFLAGS=}; + + foreach (@ARGV){ + if( /\s/ ){ + s/=(.*)/='$1'/; + } + push @m, " \\\n\t\t$_"; + } + # push @m, map( " \\\n\t\t$_", @ARGV ); + push @m, "\n"; + + return join '', @m; + } + + my $cccmd = $self->const_cccmd($libperl); + $cccmd =~ s/^CCCMD\s*=\s*//; + $cccmd =~ s/\$\(INC\)/ "-I$self->{PERL_INC}" /; + $cccmd .= " $Config{cccdlflags}" + if ($Config{useshrplib} eq 'true'); + $cccmd =~ s/\(CC\)/\(PERLMAINCC\)/; + + # The front matter of the linkcommand... + my $linkcmd = join ' ', "\$(CC)", + grep($_, @Config{qw(ldflags ccdlflags)}); + $linkcmd =~ s/\s+/ /g; + $linkcmd =~ s,(perl\.exp),\$(PERL_INC)/$1,; + + # Which *.a files could we make use of... + my %static; + require File::Find; + # don't use File::Spec here because on Win32 F::F still uses "/" + my $installed_version = join('/', + 'auto', $self->{FULLEXT}, "$self->{BASEEXT}$self->{LIB_EXT}" + ); + File::Find::find(sub { + return unless m/\Q$self->{LIB_EXT}\E$/; + + # Skip perl's libraries. + return if m/^libperl/ or m/^perl\Q$self->{LIB_EXT}\E$/; + + # Skip purified versions of libraries + # (e.g., DynaLoader_pure_p1_c0_032.a) + return if m/_pure_\w+_\w+_\w+\.\w+$/ and -f "$File::Find::dir/.pure"; + + if( exists $self->{INCLUDE_EXT} ){ + my $found = 0; + + (my $xx = $File::Find::name) =~ s,.*?/auto/,,s; + $xx =~ s,/?$_,,; + $xx =~ s,/,::,g; + + # Throw away anything not explicitly marked for inclusion. + # DynaLoader is implied. + foreach my $incl ((@{$self->{INCLUDE_EXT}},'DynaLoader')){ + if( $xx eq $incl ){ + $found++; + last; + } + } + return unless $found; + } + elsif( exists $self->{EXCLUDE_EXT} ){ + (my $xx = $File::Find::name) =~ s,.*?/auto/,,s; + $xx =~ s,/?$_,,; + $xx =~ s,/,::,g; + + # Throw away anything explicitly marked for exclusion + foreach my $excl (@{$self->{EXCLUDE_EXT}}){ + return if( $xx eq $excl ); + } + } + + # don't include the installed version of this extension. I + # leave this line here, although it is not necessary anymore: + # I patched minimod.PL instead, so that Miniperl.pm won't + # include duplicates + + # Once the patch to minimod.PL is in the distribution, I can + # drop it + return if $File::Find::name =~ m:\Q$installed_version\E\z:; + use Cwd 'cwd'; + $static{cwd() . "/" . $_}++; + }, grep( -d $_, @{$searchdirs || []}) ); + + # We trust that what has been handed in as argument, will be buildable + $static = [] unless $static; + @static{@{$static}} = (1) x @{$static}; + + $extra = [] unless $extra && ref $extra eq 'ARRAY'; + for (sort keys %static) { + next unless /\Q$self->{LIB_EXT}\E\z/; + $_ = dirname($_) . "/extralibs.ld"; + push @$extra, $_; + } + + s/^(.*)/"-I$1"/ for @{$perlinc || []}; + + $target ||= "perl"; + $tmp ||= "."; + + # MAP_STATIC doesn't look into subdirs yet. Once "all" is made and we + # regenerate the Makefiles, MAP_STATIC and the dependencies for + # extralibs.all are computed correctly + my @map_static = reverse sort keys %static; + push @m, " + MAP_LINKCMD = $linkcmd + MAP_STATIC = ", join(" \\\n\t", map { qq{"$_"} } @map_static), " + MAP_STATICDEP = ", join(' ', map { $self->quote_dep($_) } @map_static), " + + MAP_PRELIBS = $Config{perllibs} $Config{cryptlib} + "; + + my $lperl; + if (defined $libperl) { + ($lperl = $libperl) =~ s/\$\(A\)/$self->{LIB_EXT}/; + } + unless ($libperl && -f $lperl) { # Ilya's code... + my $dir = $self->{PERL_SRC} || "$self->{PERL_ARCHLIB}/CORE"; + $dir = "$self->{PERL_ARCHLIB}/.." if $self->{UNINSTALLED_PERL}; + $libperl ||= "libperl$self->{LIB_EXT}"; + $libperl = "$dir/$libperl"; + $lperl ||= "libperl$self->{LIB_EXT}"; + $lperl = "$dir/$lperl"; + + if (! -f $libperl and ! -f $lperl) { + # We did not find a static libperl. Maybe there is a shared one? + if ($Is{SunOS}) { + $lperl = $libperl = "$dir/$Config{libperl}"; + # SUNOS ld does not take the full path to a shared library + $libperl = '' if $Is{SunOS4}; + } + } + + print <{PERL_SRC}); + Warning: $libperl not found + If you're going to build a static perl binary, make sure perl is installed + otherwise ignore this warning + EOF + } + + # SUNOS ld does not take the full path to a shared library + my $llibperl = $libperl ? '$(MAP_LIBPERL)' : '-lperl'; + my $libperl_dep = $self->quote_dep($libperl); + + push @m, " + MAP_LIBPERL = $libperl + MAP_LIBPERLDEP = $libperl_dep + LLIBPERL = $llibperl + "; + + push @m, ' + $(INST_ARCHAUTODIR)/extralibs.all : $(INST_ARCHAUTODIR)$(DFSEP).exists '.join(" \\\n\t", @$extra).' + $(NOECHO) $(RM_F) $@ + $(NOECHO) $(TOUCH) $@ + '; + + foreach my $catfile (@$extra){ + push @m, "\tcat $catfile >> \$\@\n"; + } + + my $ldfrom = $self->{XSMULTI} ? '' : '$(LDFROM)'; + # 1 2 3 4 + push @m, _sprintf562 <<'EOF', $tmp, $self->xs_obj_opt('$@'), $ldfrom, $makefilename; + $(MAP_TARGET) :: %1$s/perlmain$(OBJ_EXT) $(MAP_LIBPERLDEP) $(MAP_STATICDEP) $(INST_ARCHAUTODIR)/extralibs.all + $(MAP_LINKCMD) %2$s $(OPTIMIZE) %1$s/perlmain$(OBJ_EXT) %3$s $(MAP_STATIC) "$(LLIBPERL)" `cat $(INST_ARCHAUTODIR)/extralibs.all` $(MAP_PRELIBS) + $(NOECHO) $(ECHO) "To install the new '$(MAP_TARGET)' binary, call" + $(NOECHO) $(ECHO) " $(MAKE) $(USEMAKEFILE) %4$s inst_perl MAP_TARGET=$(MAP_TARGET)" + $(NOECHO) $(ECHO) " $(MAKE) $(USEMAKEFILE) %4$s map_clean" + + %1$s/perlmain\$(OBJ_EXT): %1$s/perlmain.c + EOF + push @m, "\t".$self->cd($tmp, qq[$cccmd "-I\$(PERL_INC)" perlmain.c])."\n"; + + my $maybe_DynaLoader = $Config{usedl} ? 'q(DynaLoader)' : ''; + push @m, _sprintf562 <<'EOF', $tmp, $makefilename, $maybe_DynaLoader; + + %1$s/perlmain.c: %2$s + $(NOECHO) $(ECHO) Writing $@ + $(NOECHO) $(PERL) $(MAP_PERLINC) "-MExtUtils::Miniperl" \ + -e "writemain(grep(s#.*/auto/##s, @ARGV), %3$s)" $(MAP_STATIC) > $@t + $(MV) $@t $@ + + EOF + push @m, "\t", q{$(NOECHO) $(PERL) "$(INSTALLSCRIPT)/fixpmain" + } if (defined (&Dos::UseLFN) && Dos::UseLFN()==0); + + + push @m, q{ + doc_inst_perl : + $(NOECHO) $(ECHO) Appending installation info to "$(DESTINSTALLARCHLIB)/perllocal.pod" + -$(NOECHO) $(MKPATH) "$(DESTINSTALLARCHLIB)" + -$(NOECHO) $(DOC_INSTALL) \ + "Perl binary" "$(MAP_TARGET)" \ + MAP_STATIC "$(MAP_STATIC)" \ + MAP_EXTRA "`cat $(INST_ARCHAUTODIR)/extralibs.all`" \ + MAP_LIBPERL "$(MAP_LIBPERL)" \ + >> "}.File::Spec->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q{" + + }; + + push @m, q{ + inst_perl : pure_inst_perl doc_inst_perl + + pure_inst_perl : $(MAP_TARGET) + }.$self->{CP}.q{ $(MAP_TARGET) "}.File::Spec->catfile('$(DESTINSTALLBIN)','$(MAP_TARGET)').q{" + + clean :: map_clean + + map_clean : + }.$self->{RM_F}.qq{ $tmp/perlmain\$(OBJ_EXT) $tmp/perlmain.c \$(MAP_TARGET) $makefilename \$(INST_ARCHAUTODIR)/extralibs.all + }; + + join '', @m; + } + + =item makefile (o) + + Defines how to rewrite the Makefile. + + =cut + + sub makefile { + my($self) = shift; + my $m; + # We do not know what target was originally specified so we + # must force a manual rerun to be sure. But as it should only + # happen very rarely it is not a significant problem. + $m = ' + $(OBJECT) : $(FIRST_MAKEFILE) + + ' if $self->{OBJECT}; + + my $newer_than_target = $Is{VMS} ? '$(MMS$SOURCE_LIST)' : '$?'; + my $mpl_args = join " ", map qq["$_"], @ARGV; + my $cross = ''; + if (defined $::Cross::platform) { + # Inherited from win32/buildext.pl + $cross = "-MCross=$::Cross::platform "; + } + $m .= sprintf <<'MAKE_FRAG', $newer_than_target, $cross, $mpl_args; + # We take a very conservative approach here, but it's worth it. + # We move Makefile to Makefile.old here to avoid gnu make looping. + $(FIRST_MAKEFILE) : Makefile.PL $(CONFIGDEP) + $(NOECHO) $(ECHO) "Makefile out-of-date with respect to %s" + $(NOECHO) $(ECHO) "Cleaning current config before rebuilding Makefile..." + -$(NOECHO) $(RM_F) $(MAKEFILE_OLD) + -$(NOECHO) $(MV) $(FIRST_MAKEFILE) $(MAKEFILE_OLD) + - $(MAKE) $(USEMAKEFILE) $(MAKEFILE_OLD) clean $(DEV_NULL) + $(PERLRUN) %sMakefile.PL %s + $(NOECHO) $(ECHO) "==> Your Makefile has been rebuilt. <==" + $(NOECHO) $(ECHO) "==> Please rerun the $(MAKE) command. <==" + $(FALSE) + + MAKE_FRAG + + return $m; + } + + + =item maybe_command + + Returns true, if the argument is likely to be a command. + + =cut + + sub maybe_command { + my($self,$file) = @_; + return $file if -x $file && ! -d $file; + return; + } + + + =item needs_linking (o) + + Does this module need linking? Looks into subdirectory objects (see + also has_link_code()) + + =cut + + sub needs_linking { + my($self) = shift; + + my $caller = (caller(0))[3]; + confess("needs_linking called too early") if + $caller =~ /^ExtUtils::MakeMaker::/; + return $self->{NEEDS_LINKING} if defined $self->{NEEDS_LINKING}; + if ($self->has_link_code or $self->{MAKEAPERL}){ + $self->{NEEDS_LINKING} = 1; + return 1; + } + foreach my $child (keys %{$self->{CHILDREN}}) { + if ($self->{CHILDREN}->{$child}->needs_linking) { + $self->{NEEDS_LINKING} = 1; + return 1; + } + } + return $self->{NEEDS_LINKING} = 0; + } + + + =item parse_abstract + + parse a file and return what you think is the ABSTRACT + + =cut + + sub parse_abstract { + my($self,$parsefile) = @_; + my $result; + + local $/ = "\n"; + open(my $fh, '<', $parsefile) or die "Could not open '$parsefile': $!"; + binmode $fh; + my $inpod = 0; + my $pod_encoding; + my $package = $self->{DISTNAME}; + $package =~ s/-/::/g; + while (<$fh>) { + $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod; + next if !$inpod; + s#\r*\n\z##; # handle CRLF input + + if ( /^=encoding\s*(.*)$/i ) { + $pod_encoding = $1; + } + + if ( /^($package(?:\.pm)? \s+ -+ \s+)(.*)/x ) { + $result = $2; + next; + } + next unless $result; + + if ( $result && ( /^\s*$/ || /^\=/ ) ) { + last; + } + $result = join ' ', $result, $_; + } + close $fh; + + if ( $pod_encoding and !( $] < 5.008 or !$Config{useperlio} ) ) { + # Have to wrap in an eval{} for when running under PERL_CORE + # Encode isn't available during build phase and parsing + # ABSTRACT isn't important there + eval { + require Encode; + $result = Encode::decode($pod_encoding, $result); + } + } + + return $result; + } + + =item parse_version + + my $version = MM->parse_version($file); + + Parse a $file and return what $VERSION is set to by the first assignment. + It will return the string "undef" if it can't figure out what $VERSION + is. $VERSION should be for all to see, so C or plain $VERSION + are okay, but C is not. + + C<> is also checked for. The first version + declaration found is used, but this may change as it differs from how + Perl does it. + + parse_version() will try to C before checking for + C<$VERSION> so the following will work. + + $VERSION = qv(1.2.3); + + =cut + + sub parse_version { + my($self,$parsefile) = @_; + my $result; + + local $/ = "\n"; + local $_; + open(my $fh, '<', $parsefile) or die "Could not open '$parsefile': $!"; + my $inpod = 0; + while (<$fh>) { + $inpod = /^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod; + next if $inpod || /^\s*#/; + chop; + next if /^\s*(if|unless|elsif)/; + if ( m{^ \s* package \s+ \w[\w\:\']* \s+ (v?[0-9._]+) \s* ; }x ) { + local $^W = 0; + $result = $1; + } + elsif ( m{(?=!])\=[^=]}x ) { + $result = $self->get_version($parsefile, $1, $2); + } + else { + next; + } + last if defined $result; + } + close $fh; + + if ( defined $result && $result !~ /^v?[\d_\.]+$/ ) { + require version; + my $normal = eval { version->new( $result ) }; + $result = $normal if defined $normal; + } + $result = "undef" unless defined $result; + return $result; + } + + sub get_version { + my ($self, $parsefile, $sigil, $name) = @_; + my $line = $_; # from the while() loop in parse_version + { + package ExtUtils::MakeMaker::_version; + undef *version; # in case of unexpected version() sub + eval { + require version; + version::->import; + }; + no strict; + local *{$name}; + local $^W = 0; + $line = $1 if $line =~ m{^(.+)}s; + eval($line); ## no critic + return ${$name}; + } + } + + =item pasthru (o) + + Defines the string that is passed to recursive make calls in + subdirectories. The variables like C are used in each + level, and passed downwards on the command-line with e.g. the value of + that level's DEFINE. Example: + + # Level 0 has DEFINE = -Dfunky + # This code will define level 0's PASTHRU=PASTHRU_DEFINE="$(DEFINE) + # $(PASTHRU_DEFINE)" + # Level 0's $(CCCMD) will include macros $(DEFINE) and $(PASTHRU_DEFINE) + # So will level 1's, so when level 1 compiles, it will get right values + # And so ad infinitum + + =cut + + sub pasthru { + my($self) = shift; + my(@m); + + my(@pasthru); + my($sep) = $Is{VMS} ? ',' : ''; + $sep .= "\\\n\t"; + + foreach my $key (qw(LIB LIBPERL_A LINKTYPE OPTIMIZE + PREFIX INSTALL_BASE) + ) + { + next unless defined $self->{$key}; + push @pasthru, "$key=\"\$($key)\""; + } + + foreach my $key (qw(DEFINE INC)) { + # default to the make var + my $val = qq{\$($key)}; + # expand within perl if given since need to use quote_literal + # since INC might include space-protecting ""! + $val = $self->{$key} if defined $self->{$key}; + $val .= " \$(PASTHRU_$key)"; + my $quoted = $self->quote_literal($val); + push @pasthru, qq{PASTHRU_$key=$quoted}; + } + + push @m, "\nPASTHRU = ", join ($sep, @pasthru), "\n"; + join "", @m; + } + + =item perl_script + + Takes one argument, a file name, and returns the file name, if the + argument is likely to be a perl script. On MM_Unix this is true for + any ordinary, readable file. + + =cut + + sub perl_script { + my($self,$file) = @_; + return $file if -r $file && -f _; + return; + } + + =item perldepend (o) + + Defines the dependency from all *.h files that come with the perl + distribution. + + =cut + + sub perldepend { + my($self) = shift; + my(@m); + + my $make_config = $self->cd('$(PERL_SRC)', '$(MAKE) lib/Config.pm'); + + push @m, sprintf <<'MAKE_FRAG', $make_config if $self->{PERL_SRC}; + # Check for unpropogated config.sh changes. Should never happen. + # We do NOT just update config.h because that is not sufficient. + # An out of date config.h is not fatal but complains loudly! + $(PERL_INCDEP)/config.h: $(PERL_SRC)/config.sh + -$(NOECHO) $(ECHO) "Warning: $(PERL_INC)/config.h out of date with $(PERL_SRC)/config.sh"; $(FALSE) + + $(PERL_ARCHLIB)/Config.pm: $(PERL_SRC)/config.sh + $(NOECHO) $(ECHO) "Warning: $(PERL_ARCHLIB)/Config.pm may be out of date with $(PERL_SRC)/config.sh" + %s + MAKE_FRAG + + return join "", @m unless $self->needs_linking; + + if ($self->{OBJECT}) { + # Need to add an object file dependency on the perl headers. + # this is very important for XS modules in perl.git development. + push @m, $self->_perl_header_files_fragment("/"); # Directory separator between $(PERL_INC)/header.h + } + + push @m, join(" ", sort values %{$self->{XS}})." : \$(XSUBPPDEPS)\n" if %{$self->{XS}}; + + return join "\n", @m; + } + + + =item pm_to_blib + + Defines target that copies all files in the hash PM to their + destination and autosplits them. See L + + =cut + + sub pm_to_blib { + my $self = shift; + my($autodir) = File::Spec->catdir('$(INST_LIB)','auto'); + my $r = q{ + pm_to_blib : $(FIRST_MAKEFILE) $(TO_INST_PM) + }; + + # VMS will swallow '' and PM_FILTER is often empty. So use q[] + my $pm_to_blib = $self->oneliner(<split_command($pm_to_blib, + map { ($self->quote_literal($_) => $self->quote_literal($self->{PM}->{$_})) } sort keys %{$self->{PM}}); + + $r .= join '', map { "\t\$(NOECHO) $_\n" } @cmds; + $r .= qq{\t\$(NOECHO) \$(TOUCH) pm_to_blib\n}; + + return $r; + } + + # transform dot-separated version string into comma-separated quadruple + # examples: '1.2.3.4.5' => '1,2,3,4' + # '1.2.3' => '1,2,3,0' + sub _ppd_version { + my ($self, $string) = @_; + return join ',', ((split /\./, $string), (0) x 4)[0..3]; + } + + =item ppd + + Defines target that creates a PPD (Perl Package Description) file + for a binary distribution. + + =cut + + sub ppd { + my($self) = @_; + + my $abstract = $self->{ABSTRACT} || ''; + $abstract =~ s/\n/\\n/sg; + $abstract =~ s//>/g; + + my $author = join(', ',@{ ref $self->{AUTHOR} eq 'ARRAY' ? $self->{AUTHOR} : [ $self->{AUTHOR} || '']}); + $author =~ s//>/g; + + my $ppd_file = "$self->{DISTNAME}.ppd"; + + my @ppd_chunks = qq(\n); + + push @ppd_chunks, sprintf <<'PPD_HTML', $abstract, $author; + %s + %s + PPD_HTML + + push @ppd_chunks, " \n"; + if ( $self->{MIN_PERL_VERSION} ) { + my $min_perl_version = $self->_ppd_version($self->{MIN_PERL_VERSION}); + push @ppd_chunks, sprintf <<'PPD_PERLVERS', $min_perl_version; + + PPD_PERLVERS + + } + + # Don't add "perl" to requires. perl dependencies are + # handles by ARCHITECTURE. + my %prereqs = %{$self->{PREREQ_PM}}; + delete $prereqs{perl}; + + # Build up REQUIRE + foreach my $prereq (sort keys %prereqs) { + my $name = $prereq; + $name .= '::' unless $name =~ /::/; + my $version = $prereqs{$prereq}; + + my %attrs = ( NAME => $name ); + $attrs{VERSION} = $version if $version; + my $attrs = join " ", map { qq[$_="$attrs{$_}"] } sort keys %attrs; + push @ppd_chunks, qq( \n); + } + + my $archname = $Config{archname}; + if ($] >= 5.008) { + # archname did not change from 5.6 to 5.8, but those versions may + # not be not binary compatible so now we append the part of the + # version that changes when binary compatibility may change + $archname .= "-$Config{PERL_REVISION}.$Config{PERL_VERSION}"; + } + push @ppd_chunks, sprintf <<'PPD_OUT', $archname; + + PPD_OUT + + if ($self->{PPM_INSTALL_SCRIPT}) { + if ($self->{PPM_INSTALL_EXEC}) { + push @ppd_chunks, sprintf qq{ %s\n}, + $self->{PPM_INSTALL_EXEC}, $self->{PPM_INSTALL_SCRIPT}; + } + else { + push @ppd_chunks, sprintf qq{ %s\n}, + $self->{PPM_INSTALL_SCRIPT}; + } + } + + if ($self->{PPM_UNINSTALL_SCRIPT}) { + if ($self->{PPM_UNINSTALL_EXEC}) { + push @ppd_chunks, sprintf qq{ %s\n}, + $self->{PPM_UNINSTALL_EXEC}, $self->{PPM_UNINSTALL_SCRIPT}; + } + else { + push @ppd_chunks, sprintf qq{ %s\n}, + $self->{PPM_UNINSTALL_SCRIPT}; + } + } + + my ($bin_location) = $self->{BINARY_LOCATION} || ''; + $bin_location =~ s/\\/\\\\/g; + + push @ppd_chunks, sprintf <<'PPD_XML', $bin_location; + + + + PPD_XML + + my @ppd_cmds = $self->stashmeta(join('', @ppd_chunks), $ppd_file); + + return sprintf <<'PPD_OUT', join "\n\t", @ppd_cmds; + # Creates a PPD (Perl Package Description) for a binary distribution. + ppd : + %s + PPD_OUT + + } + + =item prefixify + + $MM->prefixify($var, $prefix, $new_prefix, $default); + + Using either $MM->{uc $var} || $Config{lc $var}, it will attempt to + replace it's $prefix with a $new_prefix. + + Should the $prefix fail to match I a PREFIX was given as an + argument to WriteMakefile() it will set it to the $new_prefix + + $default. This is for systems whose file layouts don't neatly fit into + our ideas of prefixes. + + This is for heuristics which attempt to create directory structures + that mirror those of the installed perl. + + For example: + + $MM->prefixify('installman1dir', '/usr', '/home/foo', 'man/man1'); + + this will attempt to remove '/usr' from the front of the + $MM->{INSTALLMAN1DIR} path (initializing it to $Config{installman1dir} + if necessary) and replace it with '/home/foo'. If this fails it will + simply use '/home/foo/man/man1'. + + =cut + + sub prefixify { + my($self,$var,$sprefix,$rprefix,$default) = @_; + + my $path = $self->{uc $var} || + $Config_Override{lc $var} || $Config{lc $var} || ''; + + $rprefix .= '/' if $sprefix =~ m|/$|; + + warn " prefixify $var => $path\n" if $Verbose >= 2; + warn " from $sprefix to $rprefix\n" if $Verbose >= 2; + + if( $self->{ARGS}{PREFIX} && + $path !~ s{^\Q$sprefix\E\b}{$rprefix}s ) + { + + warn " cannot prefix, using default.\n" if $Verbose >= 2; + warn " no default!\n" if !$default && $Verbose >= 2; + + $path = File::Spec->catdir($rprefix, $default) if $default; + } + + print " now $path\n" if $Verbose >= 2; + return $self->{uc $var} = $path; + } + + + =item processPL (o) + + Defines targets to run *.PL files. + + =cut + + sub processPL { + my $self = shift; + my $pl_files = $self->{PL_FILES}; + + return "" unless $pl_files; + + my $m = ''; + foreach my $plfile (sort keys %$pl_files) { + my $list = ref($pl_files->{$plfile}) + ? $pl_files->{$plfile} + : [$pl_files->{$plfile}]; + + foreach my $target (@$list) { + if( $Is{VMS} ) { + $plfile = vmsify($self->eliminate_macros($plfile)); + $target = vmsify($self->eliminate_macros($target)); + } + + # Normally a .PL file runs AFTER pm_to_blib so it can have + # blib in its @INC and load the just built modules. BUT if + # the generated module is something in $(TO_INST_PM) which + # pm_to_blib depends on then it can't depend on pm_to_blib + # else we have a dependency loop. + my $pm_dep; + my $perlrun; + if( defined $self->{PM}{$target} ) { + $pm_dep = ''; + $perlrun = 'PERLRUN'; + } + else { + $pm_dep = 'pm_to_blib'; + $perlrun = 'PERLRUNINST'; + } + + $m .= < in command line arguments. + Doesn't handle recursive Makefile C<$(...)> constructs, + but handles simple ones. + + =cut + + sub quote_paren { + my $arg = shift; + $arg =~ s{\$\((.+?)\)}{\$\\\\($1\\\\)}g; # protect $(...) + $arg =~ s{(?replace_manpage_separator($file_path); + + Takes the name of a package, which may be a nested package, in the + form 'Foo/Bar.pm' and replaces the slash with C<::> or something else + safe for a man page file name. Returns the replacement. + + =cut + + sub replace_manpage_separator { + my($self,$man) = @_; + + $man =~ s,/+,::,g; + return $man; + } + + + =item cd + + =cut + + sub cd { + my($self, $dir, @cmds) = @_; + + # No leading tab and no trailing newline makes for easier embedding + my $make_frag = join "\n\t", map { "cd $dir && $_" } @cmds; + + return $make_frag; + } + + =item oneliner + + =cut + + sub oneliner { + my($self, $cmd, $switches) = @_; + $switches = [] unless defined $switches; + + # Strip leading and trailing newlines + $cmd =~ s{^\n+}{}; + $cmd =~ s{\n+$}{}; + + my @cmds = split /\n/, $cmd; + $cmd = join " \n\t -e ", map $self->quote_literal($_), @cmds; + $cmd = $self->escape_newlines($cmd); + + $switches = join ' ', @$switches; + + return qq{\$(ABSPERLRUN) $switches -e $cmd --}; + } + + + =item quote_literal + + Quotes macro literal value suitable for being used on a command line so + that when expanded by make, will be received by command as given to + this method: + + my $quoted = $mm->quote_literal(q{it isn't}); + # returns: + # 'it isn'\''t' + print MAKEFILE "target:\n\techo $quoted\n"; + # when run "make target", will output: + # it isn't + + =cut + + sub quote_literal { + my($self, $text, $opts) = @_; + $opts->{allow_variables} = 1 unless defined $opts->{allow_variables}; + + # Quote single quotes + $text =~ s{'}{'\\''}g; + + $text = $opts->{allow_variables} + ? $self->escape_dollarsigns($text) : $self->escape_all_dollarsigns($text); + + return "'$text'"; + } + + + =item escape_newlines + + =cut + + sub escape_newlines { + my($self, $text) = @_; + + $text =~ s{\n}{\\\n}g; + + return $text; + } + + + =item max_exec_len + + Using POSIX::ARG_MAX. Otherwise falling back to 4096. + + =cut + + sub max_exec_len { + my $self = shift; + + if (!defined $self->{_MAX_EXEC_LEN}) { + if (my $arg_max = eval { require POSIX; &POSIX::ARG_MAX }) { + $self->{_MAX_EXEC_LEN} = $arg_max; + } + else { # POSIX minimum exec size + $self->{_MAX_EXEC_LEN} = 4096; + } + } + + return $self->{_MAX_EXEC_LEN}; + } + + + =item static (o) + + Defines the static target. + + =cut + + sub static { + # --- Static Loading Sections --- + + my($self) = shift; + ' + ## $(INST_PM) has been moved to the all: target. + ## It remains here for awhile to allow for old usage: "make static" + static :: $(FIRST_MAKEFILE) $(INST_STATIC) + $(NOECHO) $(NOOP) + '; + } + + sub static_lib { + my($self) = @_; + return '' unless $self->has_link_code; + my(@m); + my @libs; + if ($self->{XSMULTI}) { + for my $ext ($self->_xs_list_basenames) { + my ($v, $d, $f) = File::Spec->splitpath($ext); + my @d = File::Spec->splitdir($d); + shift @d if $d[0] eq 'lib'; + my $instdir = $self->catdir('$(INST_ARCHLIB)', 'auto', @d, $f); + my $instfile = $self->catfile($instdir, "$f\$(LIB_EXT)"); + my $objfile = "$ext\$(OBJ_EXT)"; + push @libs, [ $objfile, $instfile, $instdir ]; + } + } else { + @libs = ([ qw($(OBJECT) $(INST_STATIC) $(INST_ARCHAUTODIR)) ]); + } + push @m, map { $self->xs_make_static_lib(@$_); } @libs; + join "\n", @m; + } + + =item xs_make_static_lib + + Defines the recipes for the C section. + + =cut + + sub xs_make_static_lib { + my ($self, $from, $to, $todir) = @_; + my @m = sprintf '%s: %s $(MYEXTLIB) %s$(DFSEP).exists'."\n", $to, $from, $todir; + push @m, "\t\$(RM_F) \"\$\@\"\n"; + push @m, $self->static_lib_fixtures; + push @m, $self->static_lib_pure_cmd($from); + push @m, "\t\$(CHMOD) \$(PERM_RWX) \$\@\n"; + push @m, $self->static_lib_closures($todir); + join '', @m; + } + + =item static_lib_closures + + Records C<$(EXTRALIBS)> in F and F<$(PERL_SRC)/ext.libs>. + + =cut + + sub static_lib_closures { + my ($self, $todir) = @_; + my @m = sprintf <<'MAKE_FRAG', $todir; + $(NOECHO) $(ECHO) "$(EXTRALIBS)" > %s$(DFSEP)extralibs.ld + MAKE_FRAG + # Old mechanism - still available: + push @m, <<'MAKE_FRAG' if $self->{PERL_SRC} && $self->{EXTRALIBS}; + $(NOECHO) $(ECHO) "$(EXTRALIBS)" >> $(PERL_SRC)$(DFSEP)ext.libs + MAKE_FRAG + @m; + } + + =item static_lib_fixtures + + Handles copying C<$(MYEXTLIB)> as starter for final static library that + then gets added to. + + =cut + + sub static_lib_fixtures { + my ($self) = @_; + # If this extension has its own library (eg SDBM_File) + # then copy that to $(INST_STATIC) and add $(OBJECT) into it. + return unless $self->{MYEXTLIB}; + "\t\$(CP) \$(MYEXTLIB) \"\$\@\"\n"; + } + + =item static_lib_pure_cmd + + Defines how to run the archive utility. + + =cut + + sub static_lib_pure_cmd { + my ($self, $from) = @_; + my $ar; + if (exists $self->{FULL_AR} && -x $self->{FULL_AR}) { + # Prefer the absolute pathed ar if available so that PATH + # doesn't confuse us. Perl itself is built with the full_ar. + $ar = 'FULL_AR'; + } else { + $ar = 'AR'; + } + sprintf <<'MAKE_FRAG', $ar, $from; + $(%s) $(AR_STATIC_ARGS) "$@" %s + $(RANLIB) "$@" + MAKE_FRAG + } + + =item staticmake (o) + + Calls makeaperl. + + =cut + + sub staticmake { + my($self, %attribs) = @_; + my(@static); + + my(@searchdirs)=($self->{PERL_ARCHLIB}, $self->{SITEARCHEXP}, $self->{INST_ARCHLIB}); + + # And as it's not yet built, we add the current extension + # but only if it has some C code (or XS code, which implies C code) + if (@{$self->{C}}) { + @static = File::Spec->catfile($self->{INST_ARCHLIB}, + "auto", + $self->{FULLEXT}, + "$self->{BASEEXT}$self->{LIB_EXT}" + ); + } + + # Either we determine now, which libraries we will produce in the + # subdirectories or we do it at runtime of the make. + + # We could ask all subdir objects, but I cannot imagine, why it + # would be necessary. + + # Instead we determine all libraries for the new perl at + # runtime. + my(@perlinc) = ($self->{INST_ARCHLIB}, $self->{INST_LIB}, $self->{PERL_ARCHLIB}, $self->{PERL_LIB}); + + $self->makeaperl(MAKE => $self->{MAKEFILE}, + DIRS => \@searchdirs, + STAT => \@static, + INCL => \@perlinc, + TARGET => $self->{MAP_TARGET}, + TMP => "", + LIBPERL => $self->{LIBPERL_A} + ); + } + + =item subdir_x (o) + + Helper subroutine for subdirs + + =cut + + sub subdir_x { + my($self, $subdir) = @_; + + my $subdir_cmd = $self->cd($subdir, + '$(MAKE) $(USEMAKEFILE) $(FIRST_MAKEFILE) all $(PASTHRU)' + ); + return sprintf <<'EOT', $subdir_cmd; + + subdirs :: + $(NOECHO) %s + EOT + + } + + =item subdirs (o) + + Defines targets to process subdirectories. + + =cut + + sub subdirs { + # --- Sub-directory Sections --- + my($self) = shift; + my(@m); + # This method provides a mechanism to automatically deal with + # subdirectories containing further Makefile.PL scripts. + # It calls the subdir_x() method for each subdirectory. + foreach my $dir (@{$self->{DIR}}){ + push @m, $self->subdir_x($dir); + #### print "Including $dir subdirectory\n"; + } + if (@m){ + unshift @m, <<'EOF'; + + # The default clean, realclean and test targets in this Makefile + # have automatically been given entries for each subdir. + + EOF + } else { + push(@m, "\n# none") + } + join('',@m); + } + + =item test (o) + + Defines the test targets. + + =cut + + sub test { + my($self, %attribs) = @_; + my $tests = $attribs{TESTS} || ''; + if (!$tests && -d 't' && defined $attribs{RECURSIVE_TEST_FILES}) { + $tests = $self->find_tests_recursive; + } + elsif (!$tests && -d 't') { + $tests = $self->find_tests; + } + # have to do this because nmake is broken + $tests =~ s!/!\\!g if $self->is_make_type('nmake'); + # note: 'test.pl' name is also hardcoded in init_dirscan() + my @m; + my $default_testtype = $Config{usedl} ? 'dynamic' : 'static'; + push @m, <{DIR} }) { + my $test = $self->cd($dir, "\$(MAKE) test_$linktype \$(PASTHRU)"); + push @m, "\t\$(NOECHO) $test\n"; + } + push @m, "\n"; + if ($tests or -f "test.pl") { + for my $testspec ([ '', '' ], [ 'db', ' $(TESTDB_SW)' ]) { + my ($db, $switch) = @$testspec; + my ($command, $deps); + $deps = "subdirs-test_$linktype"; + if ($linktype eq 'static' and $self->needs_linking) { + my $target = File::Spec->rel2abs('$(MAP_TARGET)'); + $command = qq{"$target" \$(MAP_PERLINC)}; + $deps .= ' $(MAP_TARGET)'; + } else { + $command = '$(FULLPERLRUN)' . $switch; + } + push @m, "test${db}_$linktype :: $deps\n"; + push @m, $self->test_via_harness($command, '$(TEST_FILES)') + if $tests; + push @m, $self->test_via_script($command, '$(TEST_FILE)') + if -f "test.pl"; + push @m, "\n"; + } + } else { + push @m, _sprintf562 <<'EOF', $linktype; + testdb_%1$s test_%1$s :: subdirs-test_%1$s + $(NOECHO) $(ECHO) 'No tests defined for $(NAME) extension.' + + EOF + } + } + + join "", @m; + } + + =item test_via_harness (override) + + For some reason which I forget, Unix machines like to have + PERL_DL_NONLAZY set for tests. + + =cut + + sub test_via_harness { + my($self, $perl, $tests) = @_; + return $self->SUPER::test_via_harness("PERL_DL_NONLAZY=1 $perl", $tests); + } + + =item test_via_script (override) + + Again, the PERL_DL_NONLAZY thing. + + =cut + + sub test_via_script { + my($self, $perl, $script) = @_; + return $self->SUPER::test_via_script("PERL_DL_NONLAZY=1 $perl", $script); + } + + + =item tool_xsubpp (o) + + Determines typemaps, xsubpp version, prototype behaviour. + + =cut + + sub tool_xsubpp { + my($self) = shift; + return "" unless $self->needs_linking; + + my $xsdir; + my @xsubpp_dirs = @INC; + + # Make sure we pick up the new xsubpp if we're building perl. + unshift @xsubpp_dirs, $self->{PERL_LIB} if $self->{PERL_CORE}; + + my $foundxsubpp = 0; + foreach my $dir (@xsubpp_dirs) { + $xsdir = File::Spec->catdir($dir, 'ExtUtils'); + if( -r File::Spec->catfile($xsdir, "xsubpp") ) { + $foundxsubpp = 1; + last; + } + } + die "ExtUtils::MM_Unix::tool_xsubpp : Can't find xsubpp" if !$foundxsubpp; + + my $tmdir = File::Spec->catdir($self->{PERL_LIB},"ExtUtils"); + my(@tmdeps) = File::Spec->catfile($tmdir,'typemap'); + if( $self->{TYPEMAPS} ){ + foreach my $typemap (@{$self->{TYPEMAPS}}){ + if( ! -f $typemap ) { + warn "Typemap $typemap not found.\n"; + } + else { + push(@tmdeps, $typemap); + } + } + } + push(@tmdeps, "typemap") if -f "typemap"; + # absolutised because with deep-located typemaps, eg "lib/XS/typemap", + # if xsubpp is called from top level with + # $(XSUBPP) ... -typemap "lib/XS/typemap" "lib/XS/Test.xs" + # it says: + # Can't find lib/XS/type map in (fulldir)/lib/XS + # because ExtUtils::ParseXS::process_file chdir's to .xs file's + # location. This is the only way to get all specified typemaps used, + # wherever located. + my @tmargs = map { '-typemap '.$self->quote_literal(File::Spec->rel2abs($_)) } @tmdeps; + $_ = $self->quote_dep($_) for @tmdeps; + if( exists $self->{XSOPT} ){ + unshift( @tmargs, $self->{XSOPT} ); + } + + if ($Is{VMS} && + $Config{'ldflags'} && + $Config{'ldflags'} =~ m!/Debug!i && + (!exists($self->{XSOPT}) || $self->{XSOPT} !~ /linenumbers/) + ) + { + unshift(@tmargs,'-nolinenumbers'); + } + + + $self->{XSPROTOARG} = "" unless defined $self->{XSPROTOARG}; + my $xsdirdep = $self->quote_dep($xsdir); + # -dep for use when dependency not command + + return qq{ + XSUBPPDIR = $xsdir + XSUBPP = "\$(XSUBPPDIR)\$(DFSEP)xsubpp" + XSUBPPRUN = \$(PERLRUN) \$(XSUBPP) + XSPROTOARG = $self->{XSPROTOARG} + XSUBPPDEPS = @tmdeps $xsdirdep\$(DFSEP)xsubpp + XSUBPPARGS = @tmargs + XSUBPP_EXTRA_ARGS = + }; + } + + + =item all_target + + Build man pages, too + + =cut + + sub all_target { + my $self = shift; + + return <<'MAKE_EXT'; + all :: pure_all manifypods + $(NOECHO) $(NOOP) + MAKE_EXT + } + + =item top_targets (o) + + Defines the targets all, subdirs, config, and O_FILES + + =cut + + sub top_targets { + # --- Target Sections --- + + my($self) = shift; + my(@m); + + push @m, $self->all_target, "\n" unless $self->{SKIPHASH}{'all'}; + + push @m, sprintf <<'EOF'; + pure_all :: config pm_to_blib subdirs linkext + $(NOECHO) $(NOOP) + + $(NOECHO) $(NOOP) + + subdirs :: $(MYEXTLIB) + $(NOECHO) $(NOOP) + + config :: $(FIRST_MAKEFILE) blibdirs + $(NOECHO) $(NOOP) + EOF + + push @m, ' + $(O_FILES) : $(H_FILES) + ' if @{$self->{O_FILES} || []} && @{$self->{H} || []}; + + push @m, q{ + help : + perldoc ExtUtils::MakeMaker + }; + + join('',@m); + } + + =item writedoc + + Obsolete, deprecated method. Not used since Version 5.21. + + =cut + + sub writedoc { + # --- perllocal.pod section --- + my($self,$what,$name,@attribs)=@_; + my $time = localtime; + print "=head2 $time: $what C<$name>\n\n=over 4\n\n=item *\n\n"; + print join "\n\n=item *\n\n", map("C<$_>",@attribs); + print "\n\n=back\n\n"; + } + + =item xs_c (o) + + Defines the suffix rules to compile XS files to C. + + =cut + + sub xs_c { + my($self) = shift; + return '' unless $self->needs_linking(); + ' + .xs.c: + $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(XSUBPP_EXTRA_ARGS) $*.xs > $*.xsc + $(MV) $*.xsc $*.c + '; + } + + =item xs_cpp (o) + + Defines the suffix rules to compile XS files to C++. + + =cut + + sub xs_cpp { + my($self) = shift; + return '' unless $self->needs_linking(); + ' + .xs.cpp: + $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc + $(MV) $*.xsc $*.cpp + '; + } + + =item xs_o (o) + + Defines suffix rules to go from XS to object files directly. This was + originally only intended for broken make implementations, but is now + necessary for per-XS file under C, since each XS file might + have an individual C<$(VERSION)>. + + =cut + + sub xs_o { + my ($self) = @_; + return '' unless $self->needs_linking(); + my $minus_o = $self->xs_obj_opt('$*$(OBJ_EXT)'); + my $frag = ''; + # dmake makes noise about ambiguous rule + $frag .= sprintf <<'EOF', $minus_o unless $self->is_make_type('dmake'); + .xs$(OBJ_EXT) : + $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc + $(MV) $*.xsc $*.c + $(CCCMD) $(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) $(DEFINE) $*.c %s + EOF + if ($self->{XSMULTI}) { + for my $ext ($self->_xs_list_basenames) { + my $pmfile = "$ext.pm"; + croak "$ext.xs has no matching $pmfile: $!" unless -f $pmfile; + my $version = $self->parse_version($pmfile); + my $cccmd = $self->{CONST_CCCMD}; + $cccmd =~ s/^\s*CCCMD\s*=\s*//; + $cccmd =~ s/\$\(DEFINE_VERSION\)/-DVERSION=\\"$version\\"/; + $cccmd =~ s/\$\(XS_DEFINE_VERSION\)/-DXS_VERSION=\\"$version\\"/; + $self->_xsbuild_replace_macro($cccmd, 'xs', $ext, 'INC'); + my $define = '$(DEFINE)'; + $self->_xsbuild_replace_macro($define, 'xs', $ext, 'DEFINE'); + # 1 2 3 4 + $frag .= _sprintf562 <<'EOF', $ext, $cccmd, $minus_o, $define; + + %1$s$(OBJ_EXT): %1$s.xs + $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $*.xs > $*.xsc + $(MV) $*.xsc $*.c + %2$s $(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) %4$s $*.c %3$s + EOF + } + } + $frag; + } + + # param gets modified + sub _xsbuild_replace_macro { + my ($self, undef, $xstype, $ext, $varname) = @_; + my $value = $self->_xsbuild_value($xstype, $ext, $varname); + return unless defined $value; + $_[1] =~ s/\$\($varname\)/$value/; + } + + sub _xsbuild_value { + my ($self, $xstype, $ext, $varname) = @_; + return $self->{XSBUILD}{$xstype}{$ext}{$varname} + if $self->{XSBUILD}{$xstype}{$ext}{$varname}; + return $self->{XSBUILD}{$xstype}{all}{$varname} + if $self->{XSBUILD}{$xstype}{all}{$varname}; + (); + } + + 1; + + =back + + =head1 SEE ALSO + + L + + =cut + + __END__ +EXTUTILS_MM_UNIX + +$fatpacked{"ExtUtils/MM_VMS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_VMS'; + package ExtUtils::MM_VMS; + + use strict; + + use ExtUtils::MakeMaker::Config; + require Exporter; + + BEGIN { + # so we can compile the thing on non-VMS platforms. + if( $^O eq 'VMS' ) { + require VMS::Filespec; + VMS::Filespec->import; + } + } + + use File::Basename; + + our $VERSION = '7.06'; + $VERSION = eval $VERSION; + + require ExtUtils::MM_Any; + require ExtUtils::MM_Unix; + our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix ); + + use ExtUtils::MakeMaker qw($Verbose neatvalue _sprintf562); + our $Revision = $ExtUtils::MakeMaker::Revision; + + + =head1 NAME + + ExtUtils::MM_VMS - methods to override UN*X behaviour in ExtUtils::MakeMaker + + =head1 SYNOPSIS + + Do not use this directly. + Instead, use ExtUtils::MM and it will figure out which MM_* + class to use for you. + + =head1 DESCRIPTION + + See ExtUtils::MM_Unix for a documentation of the methods provided + there. This package overrides the implementation of these methods, not + the semantics. + + =head2 Methods always loaded + + =over 4 + + =item wraplist + + Converts a list into a string wrapped at approximately 80 columns. + + =cut + + sub wraplist { + my($self) = shift; + my($line,$hlen) = ('',0); + + foreach my $word (@_) { + # Perl bug -- seems to occasionally insert extra elements when + # traversing array (scalar(@array) doesn't show them, but + # foreach(@array) does) (5.00307) + next unless $word =~ /\w/; + $line .= ' ' if length($line); + if ($hlen > 80) { $line .= "\\\n\t"; $hlen = 0; } + $line .= $word; + $hlen += length($word) + 2; + } + $line; + } + + + # This isn't really an override. It's just here because ExtUtils::MM_VMS + # appears in @MM::ISA before ExtUtils::Liblist::Kid, so if there isn't an ext() + # in MM_VMS, then AUTOLOAD is called, and bad things happen. So, we just + # mimic inheritance here and hand off to ExtUtils::Liblist::Kid. + # XXX This hackery will die soon. --Schwern + sub ext { + require ExtUtils::Liblist::Kid; + goto &ExtUtils::Liblist::Kid::ext; + } + + =back + + =head2 Methods + + Those methods which override default MM_Unix methods are marked + "(override)", while methods unique to MM_VMS are marked "(specific)". + For overridden methods, documentation is limited to an explanation + of why this method overrides the MM_Unix method; see the ExtUtils::MM_Unix + documentation for more details. + + =over 4 + + =item guess_name (override) + + Try to determine name of extension being built. We begin with the name + of the current directory. Since VMS filenames are case-insensitive, + however, we look for a F<.pm> file whose name matches that of the current + directory (presumably the 'main' F<.pm> file for this extension), and try + to find a C statement from which to obtain the Mixed::Case + package name. + + =cut + + sub guess_name { + my($self) = @_; + my($defname,$defpm,@pm,%xs); + local *PM; + + $defname = basename(fileify($ENV{'DEFAULT'})); + $defname =~ s![\d\-_]*\.dir.*$!!; # Clip off .dir;1 suffix, and package version + $defpm = $defname; + # Fallback in case for some reason a user has copied the files for an + # extension into a working directory whose name doesn't reflect the + # extension's name. We'll use the name of a unique .pm file, or the + # first .pm file with a matching .xs file. + if (not -e "${defpm}.pm") { + @pm = glob('*.pm'); + s/.pm$// for @pm; + if (@pm == 1) { ($defpm = $pm[0]) =~ s/.pm$//; } + elsif (@pm) { + %xs = map { s/.xs$//; ($_,1) } glob('*.xs'); ## no critic + if (keys %xs) { + foreach my $pm (@pm) { + $defpm = $pm, last if exists $xs{$pm}; + } + } + } + } + if (open(my $pm, '<', "${defpm}.pm")){ + while (<$pm>) { + if (/^\s*package\s+([^;]+)/i) { + $defname = $1; + last; + } + } + print "Warning (non-fatal): Couldn't find package name in ${defpm}.pm;\n\t", + "defaulting package name to $defname\n" + if eof($pm); + close $pm; + } + else { + print "Warning (non-fatal): Couldn't find ${defpm}.pm;\n\t", + "defaulting package name to $defname\n"; + } + $defname =~ s#[\d.\-_]+$##; + $defname; + } + + =item find_perl (override) + + Use VMS file specification syntax and CLI commands to find and + invoke Perl images. + + =cut + + sub find_perl { + my($self, $ver, $names, $dirs, $trace) = @_; + my($vmsfile,@sdirs,@snames,@cand); + my($rslt); + my($inabs) = 0; + local *TCF; + + if( $self->{PERL_CORE} ) { + # Check in relative directories first, so we pick up the current + # version of Perl if we're running MakeMaker as part of the main build. + @sdirs = sort { my($absa) = $self->file_name_is_absolute($a); + my($absb) = $self->file_name_is_absolute($b); + if ($absa && $absb) { return $a cmp $b } + else { return $absa ? 1 : ($absb ? -1 : ($a cmp $b)); } + } @$dirs; + # Check miniperl before perl, and check names likely to contain + # version numbers before "generic" names, so we pick up an + # executable that's less likely to be from an old installation. + @snames = sort { my($ba) = $a =~ m!([^:>\]/]+)$!; # basename + my($bb) = $b =~ m!([^:>\]/]+)$!; + my($ahasdir) = (length($a) - length($ba) > 0); + my($bhasdir) = (length($b) - length($bb) > 0); + if ($ahasdir and not $bhasdir) { return 1; } + elsif ($bhasdir and not $ahasdir) { return -1; } + else { $bb =~ /\d/ <=> $ba =~ /\d/ + or substr($ba,0,1) cmp substr($bb,0,1) + or length($bb) <=> length($ba) } } @$names; + } + else { + @sdirs = @$dirs; + @snames = @$names; + } + + # Image names containing Perl version use '_' instead of '.' under VMS + s/\.(\d+)$/_$1/ for @snames; + if ($trace >= 2){ + print "Looking for perl $ver by these names:\n"; + print "\t@snames,\n"; + print "in these dirs:\n"; + print "\t@sdirs\n"; + } + foreach my $dir (@sdirs){ + next unless defined $dir; # $self->{PERL_SRC} may be undefined + $inabs++ if $self->file_name_is_absolute($dir); + if ($inabs == 1) { + # We've covered relative dirs; everything else is an absolute + # dir (probably an installed location). First, we'll try + # potential command names, to see whether we can avoid a long + # MCR expression. + foreach my $name (@snames) { + push(@cand,$name) if $name =~ /^[\w\-\$]+$/; + } + $inabs++; # Should happen above in next $dir, but just in case... + } + foreach my $name (@snames){ + push @cand, ($name !~ m![/:>\]]!) ? $self->catfile($dir,$name) + : $self->fixpath($name,0); + } + } + foreach my $name (@cand) { + print "Checking $name\n" if $trace >= 2; + # If it looks like a potential command, try it without the MCR + if ($name =~ /^[\w\-\$]+$/) { + open(my $tcf, ">", "temp_mmvms.com") + or die('unable to open temp file'); + print $tcf "\$ set message/nofacil/nosever/noident/notext\n"; + print $tcf "\$ $name -e \"require $ver; print \"\"VER_OK\\n\"\"\"\n"; + close $tcf; + $rslt = `\@temp_mmvms.com` ; + unlink('temp_mmvms.com'); + if ($rslt =~ /VER_OK/) { + print "Using PERL=$name\n" if $trace; + return $name; + } + } + next unless $vmsfile = $self->maybe_command($name); + $vmsfile =~ s/;[\d\-]*$//; # Clip off version number; we can use a newer version as well + print "Executing $vmsfile\n" if ($trace >= 2); + open(my $tcf, '>', "temp_mmvms.com") + or die('unable to open temp file'); + print $tcf "\$ set message/nofacil/nosever/noident/notext\n"; + print $tcf "\$ mcr $vmsfile -e \"require $ver; print \"\"VER_OK\\n\"\"\" \n"; + close $tcf; + $rslt = `\@temp_mmvms.com`; + unlink('temp_mmvms.com'); + if ($rslt =~ /VER_OK/) { + print "Using PERL=MCR $vmsfile\n" if $trace; + return "MCR $vmsfile"; + } + } + print "Unable to find a perl $ver (by these names: @$names, in these dirs: @$dirs)\n"; + 0; # false and not empty + } + + =item _fixin_replace_shebang (override) + + Helper routine for MM->fixin(), overridden because there's no such thing as an + actual shebang line that will be interpreted by the shell, so we just prepend + $Config{startperl} and preserve the shebang line argument for any switches it + may contain. + + =cut + + sub _fixin_replace_shebang { + my ( $self, $file, $line ) = @_; + + my ( undef, $arg ) = split ' ', $line, 2; + + return $Config{startperl} . "\n" . $Config{sharpbang} . "perl $arg\n"; + } + + =item maybe_command (override) + + Follows VMS naming conventions for executable files. + If the name passed in doesn't exactly match an executable file, + appends F<.Exe> (or equivalent) to check for executable image, and F<.Com> + to check for DCL procedure. If this fails, checks directories in DCL$PATH + and finally F for an executable file having the name specified, + with or without the F<.Exe>-equivalent suffix. + + =cut + + sub maybe_command { + my($self,$file) = @_; + return $file if -x $file && ! -d _; + my(@dirs) = (''); + my(@exts) = ('',$Config{'exe_ext'},'.exe','.com'); + + if ($file !~ m![/:>\]]!) { + for (my $i = 0; defined $ENV{"DCL\$PATH;$i"}; $i++) { + my $dir = $ENV{"DCL\$PATH;$i"}; + $dir .= ':' unless $dir =~ m%[\]:]$%; + push(@dirs,$dir); + } + push(@dirs,'Sys$System:'); + foreach my $dir (@dirs) { + my $sysfile = "$dir$file"; + foreach my $ext (@exts) { + return $file if -x "$sysfile$ext" && ! -d _; + } + } + } + return 0; + } + + + =item pasthru (override) + + VMS has $(MMSQUALIFIERS) which is a listing of all the original command line + options. This is used in every invocation of make in the VMS Makefile so + PASTHRU should not be necessary. Using PASTHRU tends to blow commands past + the 256 character limit. + + =cut + + sub pasthru { + return "PASTHRU=\n"; + } + + + =item pm_to_blib (override) + + VMS wants a dot in every file so we can't have one called 'pm_to_blib', + it becomes 'pm_to_blib.' and MMS/K isn't smart enough to know that when + you have a target called 'pm_to_blib' it should look for 'pm_to_blib.'. + + So in VMS its pm_to_blib.ts. + + =cut + + sub pm_to_blib { + my $self = shift; + + my $make = $self->SUPER::pm_to_blib; + + $make =~ s{^pm_to_blib :}{pm_to_blib.ts :}m; + $make =~ s{\$\(TOUCH\) pm_to_blib}{\$(TOUCH) pm_to_blib.ts}; + + $make = <<'MAKE' . $make; + # Dummy target to match Unix target name; we use pm_to_blib.ts as + # timestamp file to avoid repeated invocations under VMS + pm_to_blib : pm_to_blib.ts + $(NOECHO) $(NOOP) + + MAKE + + return $make; + } + + + =item perl_script (override) + + If name passed in doesn't specify a readable file, appends F<.com> or + F<.pl> and tries again, since it's customary to have file types on all files + under VMS. + + =cut + + sub perl_script { + my($self,$file) = @_; + return $file if -r $file && ! -d _; + return "$file.com" if -r "$file.com"; + return "$file.pl" if -r "$file.pl"; + return ''; + } + + + =item replace_manpage_separator + + Use as separator a character which is legal in a VMS-syntax file name. + + =cut + + sub replace_manpage_separator { + my($self,$man) = @_; + $man = unixify($man); + $man =~ s#/+#__#g; + $man; + } + + =item init_DEST + + (override) Because of the difficulty concatenating VMS filepaths we + must pre-expand the DEST* variables. + + =cut + + sub init_DEST { + my $self = shift; + + $self->SUPER::init_DEST; + + # Expand DEST variables. + foreach my $var ($self->installvars) { + my $destvar = 'DESTINSTALL'.$var; + $self->{$destvar} = $self->eliminate_macros($self->{$destvar}); + } + } + + + =item init_DIRFILESEP + + No separator between a directory path and a filename on VMS. + + =cut + + sub init_DIRFILESEP { + my($self) = shift; + + $self->{DIRFILESEP} = ''; + return 1; + } + + + =item init_main (override) + + + =cut + + sub init_main { + my($self) = shift; + + $self->SUPER::init_main; + + $self->{DEFINE} ||= ''; + if ($self->{DEFINE} ne '') { + my(@terms) = split(/\s+/,$self->{DEFINE}); + my(@defs,@udefs); + foreach my $def (@terms) { + next unless $def; + my $targ = \@defs; + if ($def =~ s/^-([DU])//) { # If it was a Unix-style definition + $targ = \@udefs if $1 eq 'U'; + $def =~ s/='(.*)'$/=$1/; # then remove shell-protection '' + $def =~ s/^'(.*)'$/$1/; # from entire term or argument + } + if ($def =~ /=/) { + $def =~ s/"/""/g; # Protect existing " from DCL + $def = qq["$def"]; # and quote to prevent parsing of = + } + push @$targ, $def; + } + + $self->{DEFINE} = ''; + if (@defs) { + $self->{DEFINE} = '/Define=(' . join(',',@defs) . ')'; + } + if (@udefs) { + $self->{DEFINE} .= '/Undef=(' . join(',',@udefs) . ')'; + } + } + } + + =item init_tools (override) + + Provide VMS-specific forms of various utility commands. + + Sets DEV_NULL to nothing because I don't know how to do it on VMS. + + Changes EQUALIZE_TIMESTAMP to set revision date of target file to + one second later than source file, since MMK interprets precisely + equal revision dates for a source and target file as a sign that the + target needs to be updated. + + =cut + + sub init_tools { + my($self) = @_; + + $self->{NOOP} = 'Continue'; + $self->{NOECHO} ||= '@ '; + + $self->{MAKEFILE} ||= $self->{FIRST_MAKEFILE} || 'Descrip.MMS'; + $self->{FIRST_MAKEFILE} ||= $self->{MAKEFILE}; + $self->{MAKE_APERL_FILE} ||= 'Makeaperl.MMS'; + $self->{MAKEFILE_OLD} ||= $self->eliminate_macros('$(FIRST_MAKEFILE)_old'); + # + # If an extension is not specified, then MMS/MMK assumes an + # an extension of .MMS. If there really is no extension, + # then a trailing "." needs to be appended to specify a + # a null extension. + # + $self->{MAKEFILE} .= '.' unless $self->{MAKEFILE} =~ m/\./; + $self->{FIRST_MAKEFILE} .= '.' unless $self->{FIRST_MAKEFILE} =~ m/\./; + $self->{MAKE_APERL_FILE} .= '.' unless $self->{MAKE_APERL_FILE} =~ m/\./; + $self->{MAKEFILE_OLD} .= '.' unless $self->{MAKEFILE_OLD} =~ m/\./; + + $self->{MACROSTART} ||= '/Macro=('; + $self->{MACROEND} ||= ')'; + $self->{USEMAKEFILE} ||= '/Descrip='; + + $self->{EQUALIZE_TIMESTAMP} ||= '$(ABSPERLRUN) -we "open F,qq{>>$ARGV[1]};close F;utime(0,(stat($ARGV[0]))[9]+1,$ARGV[1])"'; + + $self->{MOD_INSTALL} ||= + $self->oneliner(<<'CODE', ['-MExtUtils::Install']); + install([ from_to => {split('\|', )}, verbose => '$(VERBINST)', uninstall_shadows => '$(UNINST)', dir_mode => '$(PERM_DIR)' ]); + CODE + + $self->{UMASK_NULL} = '! '; + + $self->SUPER::init_tools; + + # Use the default shell + $self->{SHELL} ||= 'Posix'; + + # Redirection on VMS goes before the command, not after as on Unix. + # $(DEV_NULL) is used once and its not worth going nuts over making + # it work. However, Unix's DEV_NULL is quite wrong for VMS. + $self->{DEV_NULL} = ''; + + return; + } + + =item init_platform (override) + + Add PERL_VMS, MM_VMS_REVISION and MM_VMS_VERSION. + + MM_VMS_REVISION is for backwards compatibility before MM_VMS had a + $VERSION. + + =cut + + sub init_platform { + my($self) = shift; + + $self->{MM_VMS_REVISION} = $Revision; + $self->{MM_VMS_VERSION} = $VERSION; + $self->{PERL_VMS} = $self->catdir($self->{PERL_SRC}, 'VMS') + if $self->{PERL_SRC}; + } + + + =item platform_constants + + =cut + + sub platform_constants { + my($self) = shift; + my $make_frag = ''; + + foreach my $macro (qw(PERL_VMS MM_VMS_REVISION MM_VMS_VERSION)) + { + next unless defined $self->{$macro}; + $make_frag .= "$macro = $self->{$macro}\n"; + } + + return $make_frag; + } + + + =item init_VERSION (override) + + Override the *DEFINE_VERSION macros with VMS semantics. Translate the + MAKEMAKER filepath to VMS style. + + =cut + + sub init_VERSION { + my $self = shift; + + $self->SUPER::init_VERSION; + + $self->{DEFINE_VERSION} = '"$(VERSION_MACRO)=""$(VERSION)"""'; + $self->{XS_DEFINE_VERSION} = '"$(XS_VERSION_MACRO)=""$(XS_VERSION)"""'; + $self->{MAKEMAKER} = vmsify($INC{'ExtUtils/MakeMaker.pm'}); + } + + + =item constants (override) + + Fixes up numerous file and directory macros to insure VMS syntax + regardless of input syntax. Also makes lists of files + comma-separated. + + =cut + + sub constants { + my($self) = @_; + + # Be kind about case for pollution + for (@ARGV) { $_ = uc($_) if /POLLUTE/i; } + + # Cleanup paths for directories in MMS macros. + foreach my $macro ( qw [ + INST_BIN INST_SCRIPT INST_LIB INST_ARCHLIB + PERL_LIB PERL_ARCHLIB + PERL_INC PERL_SRC ], + (map { 'INSTALL'.$_ } $self->installvars) + ) + { + next unless defined $self->{$macro}; + next if $macro =~ /MAN/ && $self->{$macro} eq 'none'; + $self->{$macro} = $self->fixpath($self->{$macro},1); + } + + # Cleanup paths for files in MMS macros. + foreach my $macro ( qw[LIBPERL_A FIRST_MAKEFILE MAKEFILE_OLD + MAKE_APERL_FILE MYEXTLIB] ) + { + next unless defined $self->{$macro}; + $self->{$macro} = $self->fixpath($self->{$macro},0); + } + + # Fixup files for MMS macros + # XXX is this list complete? + for my $macro (qw/ + FULLEXT VERSION_FROM + / ) { + next unless defined $self->{$macro}; + $self->{$macro} = $self->fixpath($self->{$macro},0); + } + + + for my $macro (qw/ + OBJECT LDFROM + / ) { + next unless defined $self->{$macro}; + + # Must expand macros before splitting on unescaped whitespace. + $self->{$macro} = $self->eliminate_macros($self->{$macro}); + if ($self->{$macro} =~ /(?{$macro} =~ s/(\\)?\n+\s+/ /g; + $self->{$macro} = $self->wraplist( + map $self->fixpath($_,0), split /,?(?{$macro} + ); + } + else { + $self->{$macro} = $self->fixpath($self->{$macro},0); + } + } + + for my $macro (qw/ XS MAN1PODS MAN3PODS PM /) { + # Where is the space coming from? --jhi + next unless $self ne " " && defined $self->{$macro}; + my %tmp = (); + for my $key (keys %{$self->{$macro}}) { + $tmp{$self->fixpath($key,0)} = + $self->fixpath($self->{$macro}{$key},0); + } + $self->{$macro} = \%tmp; + } + + for my $macro (qw/ C O_FILES H /) { + next unless defined $self->{$macro}; + my @tmp = (); + for my $val (@{$self->{$macro}}) { + push(@tmp,$self->fixpath($val,0)); + } + $self->{$macro} = \@tmp; + } + + # mms/k does not define a $(MAKE) macro. + $self->{MAKE} = '$(MMS)$(MMSQUALIFIERS)'; + + return $self->SUPER::constants; + } + + + =item special_targets + + Clear the default .SUFFIXES and put in our own list. + + =cut + + sub special_targets { + my $self = shift; + + my $make_frag .= <<'MAKE_FRAG'; + .SUFFIXES : + .SUFFIXES : $(OBJ_EXT) .c .cpp .cxx .xs + + MAKE_FRAG + + return $make_frag; + } + + =item cflags (override) + + Bypass shell script and produce qualifiers for CC directly (but warn + user if a shell script for this extension exists). Fold multiple + /Defines into one, since some C compilers pay attention to only one + instance of this qualifier on the command line. + + =cut + + sub cflags { + my($self,$libperl) = @_; + my($quals) = $self->{CCFLAGS} || $Config{'ccflags'}; + my($definestr,$undefstr,$flagoptstr) = ('','',''); + my($incstr) = '/Include=($(PERL_INC)'; + my($name,$sys,@m); + + ( $name = $self->{NAME} . "_cflags" ) =~ s/:/_/g ; + print "Unix shell script ".$Config{"$self->{'BASEEXT'}_cflags"}. + " required to modify CC command for $self->{'BASEEXT'}\n" + if ($Config{$name}); + + if ($quals =~ / -[DIUOg]/) { + while ($quals =~ / -([Og])(\d*)\b/) { + my($type,$lvl) = ($1,$2); + $quals =~ s/ -$type$lvl\b\s*//; + if ($type eq 'g') { $flagoptstr = '/NoOptimize'; } + else { $flagoptstr = '/Optimize' . (defined($lvl) ? "=$lvl" : ''); } + } + while ($quals =~ / -([DIU])(\S+)/) { + my($type,$def) = ($1,$2); + $quals =~ s/ -$type$def\s*//; + $def =~ s/"/""/g; + if ($type eq 'D') { $definestr .= qq["$def",]; } + elsif ($type eq 'I') { $incstr .= ',' . $self->fixpath($def,1); } + else { $undefstr .= qq["$def",]; } + } + } + if (length $quals and $quals !~ m!/!) { + warn "MM_VMS: Ignoring unrecognized CCFLAGS elements \"$quals\"\n"; + $quals = ''; + } + $definestr .= q["PERL_POLLUTE",] if $self->{POLLUTE}; + if (length $definestr) { chop($definestr); $quals .= "/Define=($definestr)"; } + if (length $undefstr) { chop($undefstr); $quals .= "/Undef=($undefstr)"; } + # Deal with $self->{DEFINE} here since some C compilers pay attention + # to only one /Define clause on command line, so we have to + # conflate the ones from $Config{'ccflags'} and $self->{DEFINE} + # ($self->{DEFINE} has already been VMSified in constants() above) + if ($self->{DEFINE}) { $quals .= $self->{DEFINE}; } + for my $type (qw(Def Undef)) { + my(@terms); + while ($quals =~ m:/${type}i?n?e?=([^/]+):ig) { + my $term = $1; + $term =~ s:^\((.+)\)$:$1:; + push @terms, $term; + } + if ($type eq 'Def') { + push @terms, qw[ $(DEFINE_VERSION) $(XS_DEFINE_VERSION) ]; + } + if (@terms) { + $quals =~ s:/${type}i?n?e?=[^/]+::ig; + $quals .= "/${type}ine=(" . join(',',@terms) . ')'; + } + } + + $libperl or $libperl = $self->{LIBPERL_A} || "libperl.olb"; + + # Likewise with $self->{INC} and /Include + if ($self->{'INC'}) { + my(@includes) = split(/\s+/,$self->{INC}); + foreach (@includes) { + s/^-I//; + $incstr .= ','.$self->fixpath($_,1); + } + } + $quals .= "$incstr)"; + # $quals =~ s/,,/,/g; $quals =~ s/\(,/(/g; + $self->{CCFLAGS} = $quals; + + $self->{PERLTYPE} ||= ''; + + $self->{OPTIMIZE} ||= $flagoptstr || $Config{'optimize'}; + if ($self->{OPTIMIZE} !~ m!/!) { + if ($self->{OPTIMIZE} =~ m!-g!) { $self->{OPTIMIZE} = '/Debug/NoOptimize' } + elsif ($self->{OPTIMIZE} =~ /-O(\d*)/) { + $self->{OPTIMIZE} = '/Optimize' . (defined($1) ? "=$1" : ''); + } + else { + warn "MM_VMS: Can't parse OPTIMIZE \"$self->{OPTIMIZE}\"; using default\n" if length $self->{OPTIMIZE}; + $self->{OPTIMIZE} = '/Optimize'; + } + } + + return $self->{CFLAGS} = qq{ + CCFLAGS = $self->{CCFLAGS} + OPTIMIZE = $self->{OPTIMIZE} + PERLTYPE = $self->{PERLTYPE} + }; + } + + =item const_cccmd (override) + + Adds directives to point C preprocessor to the right place when + handling #include Esys/foo.hE directives. Also constructs CC + command line a bit differently than MM_Unix method. + + =cut + + sub const_cccmd { + my($self,$libperl) = @_; + my(@m); + + return $self->{CONST_CCCMD} if $self->{CONST_CCCMD}; + return '' unless $self->needs_linking(); + if ($Config{'vms_cc_type'} eq 'gcc') { + push @m,' + .FIRST + ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" Then Define/NoLog SYS GNU_CC_Include:[VMS]'; + } + elsif ($Config{'vms_cc_type'} eq 'vaxc') { + push @m,' + .FIRST + ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("VAXC$Include").eqs."" Then Define/NoLog SYS Sys$Library + ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("VAXC$Include").nes."" Then Define/NoLog SYS VAXC$Include'; + } + else { + push @m,' + .FIRST + ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("DECC$System_Include").eqs."" Then Define/NoLog SYS ', + ($Config{'archname'} eq 'VMS_AXP' ? 'Sys$Library' : 'DECC$Library_Include'),' + ',$self->{NOECHO},'If F$TrnLnm("Sys").eqs."" .and. F$TrnLnm("DECC$System_Include").nes."" Then Define/NoLog SYS DECC$System_Include'; + } + + push(@m, "\n\nCCCMD = $Config{'cc'} \$(CCFLAGS)\$(OPTIMIZE)\n"); + + $self->{CONST_CCCMD} = join('',@m); + } + + + =item tools_other (override) + + Throw in some dubious extra macros for Makefile args. + + Also keep around the old $(SAY) macro in case somebody's using it. + + =cut + + sub tools_other { + my($self) = @_; + + # XXX Are these necessary? Does anyone override them? They're longer + # than just typing the literal string. + my $extra_tools = <<'EXTRA_TOOLS'; + + # Just in case anyone is using the old macro. + USEMACROS = $(MACROSTART) + SAY = $(ECHO) + + EXTRA_TOOLS + + return $self->SUPER::tools_other . $extra_tools; + } + + =item init_dist (override) + + VMSish defaults for some values. + + macro description default + + ZIPFLAGS flags to pass to ZIP -Vu + + COMPRESS compression command to gzip + use for tarfiles + SUFFIX suffix to put on -gz + compressed files + + SHAR shar command to use vms_share + + DIST_DEFAULT default target to use to tardist + create a distribution + + DISTVNAME Use VERSION_SYM instead of $(DISTNAME)-$(VERSION_SYM) + VERSION for the name + + =cut + + sub init_dist { + my($self) = @_; + $self->{ZIPFLAGS} ||= '-Vu'; + $self->{COMPRESS} ||= 'gzip'; + $self->{SUFFIX} ||= '-gz'; + $self->{SHAR} ||= 'vms_share'; + $self->{DIST_DEFAULT} ||= 'zipdist'; + + $self->SUPER::init_dist; + + $self->{DISTVNAME} = "$self->{DISTNAME}-$self->{VERSION_SYM}" + unless $self->{ARGS}{DISTVNAME}; + + return; + } + + =item c_o (override) + + Use VMS syntax on command line. In particular, $(DEFINE) and + $(PERL_INC) have been pulled into $(CCCMD). Also use MM[SK] macros. + + =cut + + sub c_o { + my($self) = @_; + return '' unless $self->needs_linking(); + ' + .c$(OBJ_EXT) : + $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT) + + .cpp$(OBJ_EXT) : + $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).cpp /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT) + + .cxx$(OBJ_EXT) : + $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).cxx /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT) + + '; + } + + =item xs_c (override) + + Use MM[SK] macros. + + =cut + + sub xs_c { + my($self) = @_; + return '' unless $self->needs_linking(); + ' + .xs.c : + $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs >$(MMS$TARGET_NAME).xsc + $(MV) $(MMS$TARGET_NAME).xsc $(MMS$TARGET_NAME).c + '; + } + + =item xs_o (override) + + Use MM[SK] macros, and VMS command line for C compiler. + + =cut + + sub xs_o { + my ($self) = @_; + return '' unless $self->needs_linking(); + my $frag = ' + .xs$(OBJ_EXT) : + $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs >$(MMS$TARGET_NAME).xsc + $(MV) $(MMS$TARGET_NAME).xsc $(MMS$TARGET_NAME).c + $(CCCMD) $(CCCDLFLAGS) $(MMS$TARGET_NAME).c /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT) + '; + if ($self->{XSMULTI}) { + for my $ext ($self->_xs_list_basenames) { + my $version = $self->parse_version("$ext.pm"); + my $cccmd = $self->{CONST_CCCMD}; + $cccmd =~ m/^\s*CCCMD\s*=\s*(.*)\n/m; + $cccmd = $1; + $cccmd =~ s/\b(VERSION=)[^,\)]*/$1\\"$version\\"/; + $cccmd =~ s/\b(XS_VERSION=)[^,\)]*/$1\\"$version\\"/; + # 1 2 + $frag .= _sprintf562 <<'EOF', $ext, $cccmd; + + %1$s$(OBJ_EXT) : %1$s.xs + $(XSUBPPRUN) $(XSPROTOARG) $(XSUBPPARGS) $(MMS$TARGET_NAME).xs > $(MMS$TARGET_NAME).xsc + $(MV) $(MMS$TARGET_NAME).xsc $(MMS$TARGET_NAME).c + %2$s $(CCCDLFLAGS) $(MMS$TARGET_NAME).c /OBJECT=$(MMS$TARGET_NAME)$(OBJ_EXT) + EOF + } + } + $frag; + } + + + sub xs_dlsyms_ext { + '.opt'; + } + + =item dlsyms (override) + + Create VMS linker options files specifying universal symbols for this + extension's shareable image, and listing other shareable images or + libraries to which it should be linked. + + =cut + + sub dlsyms { + my ($self, %attribs) = @_; + return '' unless $self->needs_linking; + $self->xs_dlsyms_iterator; + } + + sub xs_make_dlsyms { + my ($self, $attribs, $target, $dep, $name, $dlbase, $funcs, $funclist, $imports, $vars, $extra) = @_; + my @m; + if ($self->{XSMULTI}) { + my ($v, $d, $f) = File::Spec->splitpath($target); + my @d = File::Spec->splitdir($d); + shift @d if $d[0] eq 'lib'; + my $instloc = $self->catfile('$(INST_ARCHLIB)', 'auto', @d, $f); + push @m,"\ndynamic :: $instloc\n\t\$(NOECHO) \$(NOOP)\n" + unless $self->{SKIPHASH}{'dynamic'}; + push @m,"\nstatic :: $instloc\n\t\$(NOECHO) \$(NOOP)\n" + unless $self->{SKIPHASH}{'static'}; + push @m, sprintf <<'EOF', $instloc, $target; + %s : %s + $(CP) $(MMS$SOURCE) $(MMS$TARGET) + EOF + } else { + push @m,"\ndynamic :: \$(INST_ARCHAUTODIR)$self->{BASEEXT}.opt\n\t\$(NOECHO) \$(NOOP)\n" + unless $self->{SKIPHASH}{'dynamic'}; + push @m,"\nstatic :: \$(INST_ARCHAUTODIR)$self->{BASEEXT}.opt\n\t\$(NOECHO) \$(NOOP)\n" + unless $self->{SKIPHASH}{'static'}; + push @m, sprintf <<'EOF', $target; + $(INST_ARCHAUTODIR)$(BASEEXT).opt : %s + $(CP) $(MMS$SOURCE) $(MMS$TARGET) + EOF + } + push @m, + "\n$target : $dep\n\t", + q!$(PERLRUN) -MExtUtils::Mksymlists -e "Mksymlists('NAME'=>'!, $name, + q!', 'DLBASE' => '!,$dlbase, + q!', 'DL_FUNCS' => !,neatvalue($funcs), + q!, 'FUNCLIST' => !,neatvalue($funclist), + q!, 'IMPORTS' => !,neatvalue($imports), + q!, 'DL_VARS' => !, neatvalue($vars); + push @m, $extra if defined $extra; + push @m, qq!);"\n\t!; + push @m, ' $(PERL) -e "print ""$(INST_STATIC)/Include='; + if ($self->{XSMULTI}) { + push @m, uc($dlbase); # the "DLBASE" - is this right? + } elsif ($self->{OBJECT} =~ /\bBASEEXT\b/ or + $self->{OBJECT} =~ /\b$self->{BASEEXT}\b/i) { + push @m, ($Config{d_vms_case_sensitive_symbols} + ? uc($self->{BASEEXT}) :'$(BASEEXT)'); + } else { # We don't have a "main" object file, so pull 'em all in + # Upcase module names if linker is being case-sensitive + my($upcase) = $Config{d_vms_case_sensitive_symbols}; + my(@omods) = split ' ', $self->eliminate_macros($self->{OBJECT}); + for (@omods) { + s/\.[^.]*$//; # Trim off file type + s[\$\(\w+_EXT\)][]; # even as a macro + s/.*[:>\/\]]//; # Trim off dir spec + $_ = uc if $upcase; + }; + my(@lines); + my $tmp = shift @omods; + foreach my $elt (@omods) { + $tmp .= ",$elt"; + if (length($tmp) > 80) { push @lines, $tmp; $tmp = ''; } + } + push @lines, $tmp; + push @m, '(', join( qq[, -\\n\\t"";" >>\$(MMS\$TARGET)\n\t\$(PERL) -e "print ""], @lines),')'; + } + push @m, '\n$(INST_STATIC)/Library\n"";" >>$(MMS$TARGET)',"\n"; + if (length $self->{LDLOADLIBS}) { + my($line) = ''; + foreach my $lib (split ' ', $self->{LDLOADLIBS}) { + $lib =~ s%\$%\\\$%g; # Escape '$' in VMS filespecs + if (length($line) + length($lib) > 160) { + push @m, "\t\$(PERL) -e \"print qq{$line}\" >>\$(MMS\$TARGET)\n"; + $line = $lib . '\n'; + } + else { $line .= $lib . '\n'; } + } + push @m, "\t\$(PERL) -e \"print qq{$line}\" >>\$(MMS\$TARGET)\n" if $line; + } + join '', @m; + } + + + =item xs_obj_opt + + Override to fixup -o flags. + + =cut + + sub xs_obj_opt { + my ($self, $output_file) = @_; + "/OBJECT=$output_file"; + } + + =item dynamic_lib (override) + + Use VMS Link command. + + =cut + + sub xs_dynamic_lib_macros { + my ($self, $attribs) = @_; + my $otherldflags = $attribs->{OTHERLDFLAGS} || ""; + my $inst_dynamic_dep = $attribs->{INST_DYNAMIC_DEP} || ""; + sprintf <<'EOF', $otherldflags, $inst_dynamic_dep; + # This section creates the dynamically loadable objects from relevant + # objects and possibly $(MYEXTLIB). + OTHERLDFLAGS = %s + INST_DYNAMIC_DEP = %s + EOF + } + + sub xs_make_dynamic_lib { + my ($self, $attribs, $from, $to, $todir, $ldfrom, $exportlist) = @_; + my $shr = $Config{'dbgprefix'} . 'PerlShr'; + $exportlist =~ s/.def$/.opt/; # it's a linker options file + # 1 2 3 4 5 + _sprintf562 <<'EOF', $to, $todir, $exportlist, $shr, "$shr Sys\$Share:$shr.$Config{'dlext'}"; + %1$s : $(INST_STATIC) $(PERL_INC)perlshr_attr.opt %2$s$(DFSEP).exists %3$s $(PERL_ARCHIVE) $(INST_DYNAMIC_DEP) + If F$TrnLNm("%4$s").eqs."" Then Define/NoLog/User %5$s + Link $(LDFLAGS) /Shareable=$(MMS$TARGET)$(OTHERLDFLAGS) %3$s/Option,$(PERL_INC)perlshr_attr.opt/Option + EOF + } + + + =item static_lib (override) + + Use VMS commands to manipulate object library. + + =cut + + sub static_lib { + my($self) = @_; + return '' unless $self->needs_linking(); + + return ' + $(INST_STATIC) : + $(NOECHO) $(NOOP) + ' unless ($self->{OBJECT} or @{$self->{C} || []} or $self->{MYEXTLIB}); + + my(@m); + push @m,' + # Rely on suffix rule for update action + $(OBJECT) : $(INST_ARCHAUTODIR)$(DFSEP).exists + + $(INST_STATIC) : $(OBJECT) $(MYEXTLIB) + '; + # If this extension has its own library (eg SDBM_File) + # then copy that to $(INST_STATIC) and add $(OBJECT) into it. + push(@m, "\t",'$(CP) $(MYEXTLIB) $(MMS$TARGET)',"\n") if $self->{MYEXTLIB}; + + push(@m,"\t",'If F$Search("$(MMS$TARGET)").eqs."" Then Library/Object/Create $(MMS$TARGET)',"\n"); + + # if there was a library to copy, then we can't use MMS$SOURCE_LIST, + # 'cause it's a library and you can't stick them in other libraries. + # In that case, we use $OBJECT instead and hope for the best + if ($self->{MYEXTLIB}) { + push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) $(OBJECT)',"\n"); + } else { + push(@m,"\t",'Library/Object/Replace $(MMS$TARGET) $(MMS$SOURCE_LIST)',"\n"); + } + + push @m, "\t\$(NOECHO) \$(PERL) -e 1 >\$(INST_ARCHAUTODIR)extralibs.ld\n"; + foreach my $lib (split ' ', $self->{EXTRALIBS}) { + push(@m,"\t",'$(NOECHO) $(PERL) -e "print qq{',$lib,'\n}" >>$(INST_ARCHAUTODIR)extralibs.ld',"\n"); + } + join('',@m); + } + + + =item extra_clean_files + + Clean up some OS specific files. Plus the temp file used to shorten + a lot of commands. And the name mangler database. + + =cut + + sub extra_clean_files { + return qw( + *.Map *.Dmp *.Lis *.cpp *.$(DLEXT) *.Opt $(BASEEXT).bso + .MM_Tmp cxx_repository + ); + } + + + =item zipfile_target + + =item tarfile_target + + =item shdist_target + + Syntax for invoking shar, tar and zip differs from that for Unix. + + =cut + + sub zipfile_target { + my($self) = shift; + + return <<'MAKE_FRAG'; + $(DISTVNAME).zip : distdir + $(PREOP) + $(ZIP) "$(ZIPFLAGS)" $(MMS$TARGET) [.$(DISTVNAME)...]*.*; + $(RM_RF) $(DISTVNAME) + $(POSTOP) + MAKE_FRAG + } + + sub tarfile_target { + my($self) = shift; + + return <<'MAKE_FRAG'; + $(DISTVNAME).tar$(SUFFIX) : distdir + $(PREOP) + $(TO_UNIX) + $(TAR) "$(TARFLAGS)" $(DISTVNAME).tar [.$(DISTVNAME)...] + $(RM_RF) $(DISTVNAME) + $(COMPRESS) $(DISTVNAME).tar + $(POSTOP) + MAKE_FRAG + } + + sub shdist_target { + my($self) = shift; + + return <<'MAKE_FRAG'; + shdist : distdir + $(PREOP) + $(SHAR) [.$(DISTVNAME)...]*.*; $(DISTVNAME).share + $(RM_RF) $(DISTVNAME) + $(POSTOP) + MAKE_FRAG + } + + + # --- Test and Installation Sections --- + + =item install (override) + + Work around DCL's 255 character limit several times,and use + VMS-style command line quoting in a few cases. + + =cut + + sub install { + my($self, %attribs) = @_; + my(@m); + + push @m, q[ + install :: all pure_install doc_install + $(NOECHO) $(NOOP) + + install_perl :: all pure_perl_install doc_perl_install + $(NOECHO) $(NOOP) + + install_site :: all pure_site_install doc_site_install + $(NOECHO) $(NOOP) + + install_vendor :: all pure_vendor_install doc_vendor_install + $(NOECHO) $(NOOP) + + pure_install :: pure_$(INSTALLDIRS)_install + $(NOECHO) $(NOOP) + + doc_install :: doc_$(INSTALLDIRS)_install + $(NOECHO) $(NOOP) + + pure__install : pure_site_install + $(NOECHO) $(ECHO) "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site" + + doc__install : doc_site_install + $(NOECHO) $(ECHO) "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site" + + # This hack brought to you by DCL's 255-character command line limit + pure_perl_install :: + ]; + push @m, + q[ $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read|'.File::Spec->catfile('$(PERL_ARCHLIB)','auto','$(FULLEXT)','.packlist').'|'" >.MM_tmp + $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write|'.File::Spec->catfile('$(DESTINSTALLARCHLIB)','auto','$(FULLEXT)','.packlist').'|'" >>.MM_tmp + ] unless $self->{NO_PACKLIST}; + + push @m, + q[ $(NOECHO) $(ECHO_N) "$(INST_LIB)|$(DESTINSTALLPRIVLIB)|" >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_ARCHLIB)|$(DESTINSTALLARCHLIB)|" >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_BIN)|$(DESTINSTALLBIN)|" >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_SCRIPT)|$(DESTINSTALLSCRIPT)|" >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_MAN1DIR) $(DESTINSTALLMAN1DIR) " >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_MAN3DIR)|$(DESTINSTALLMAN3DIR)" >>.MM_tmp + $(NOECHO) $(MOD_INSTALL) <.MM_tmp + $(NOECHO) $(RM_F) .MM_tmp + $(NOECHO) $(WARN_IF_OLD_PACKLIST) "].$self->catfile($self->{SITEARCHEXP},'auto',$self->{FULLEXT},'.packlist').q[" + + # Likewise + pure_site_install :: + ]; + push @m, + q[ $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read|'.File::Spec->catfile('$(SITEARCHEXP)','auto','$(FULLEXT)','.packlist').'|'" >.MM_tmp + $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write|'.File::Spec->catfile('$(DESTINSTALLSITEARCH)','auto','$(FULLEXT)','.packlist').'|'" >>.MM_tmp + ] unless $self->{NO_PACKLIST}; + + push @m, + q[ $(NOECHO) $(ECHO_N) "$(INST_LIB)|$(DESTINSTALLSITELIB)|" >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_ARCHLIB)|$(DESTINSTALLSITEARCH)|" >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_BIN)|$(DESTINSTALLSITEBIN)|" >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_SCRIPT)|$(DESTINSTALLSCRIPT)|" >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_MAN1DIR)|$(DESTINSTALLSITEMAN1DIR)|" >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_MAN3DIR)|$(DESTINSTALLSITEMAN3DIR)" >>.MM_tmp + $(NOECHO) $(MOD_INSTALL) <.MM_tmp + $(NOECHO) $(RM_F) .MM_tmp + $(NOECHO) $(WARN_IF_OLD_PACKLIST) "].$self->catfile($self->{PERL_ARCHLIB},'auto',$self->{FULLEXT},'.packlist').q[" + + pure_vendor_install :: + ]; + push @m, + q[ $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'read|'.File::Spec->catfile('$(VENDORARCHEXP)','auto','$(FULLEXT)','.packlist').'|'" >.MM_tmp + $(NOECHO) $(PERLRUN) "-MFile::Spec" -e "print 'write|'.File::Spec->catfile('$(DESTINSTALLVENDORARCH)','auto','$(FULLEXT)','.packlist').'|'" >>.MM_tmp + ] unless $self->{NO_PACKLIST}; + + push @m, + q[ $(NOECHO) $(ECHO_N) "$(INST_LIB)|$(DESTINSTALLVENDORLIB)|" >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_ARCHLIB)|$(DESTINSTALLVENDORARCH)|" >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_BIN)|$(DESTINSTALLVENDORBIN)|" >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_SCRIPT)|$(DESTINSTALLSCRIPT)|" >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_MAN1DIR)|$(DESTINSTALLVENDORMAN1DIR)|" >>.MM_tmp + $(NOECHO) $(ECHO_N) "$(INST_MAN3DIR)|$(DESTINSTALLVENDORMAN3DIR)" >>.MM_tmp + $(NOECHO) $(MOD_INSTALL) <.MM_tmp + $(NOECHO) $(RM_F) .MM_tmp + + ]; + + push @m, q[ + # Ditto + doc_perl_install :: + $(NOECHO) $(NOOP) + + # And again + doc_site_install :: + $(NOECHO) $(NOOP) + + doc_vendor_install :: + $(NOECHO) $(NOOP) + + ] if $self->{NO_PERLLOCAL}; + + push @m, q[ + # Ditto + doc_perl_install :: + $(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{DESTINSTALLARCHLIB}, 'perllocal.pod').q[" + $(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB) + $(NOECHO) $(ECHO_N) "installed into|$(INSTALLPRIVLIB)|" >.MM_tmp + $(NOECHO) $(ECHO_N) "LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES) " >>.MM_tmp + $(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{DESTINSTALLARCHLIB},'perllocal.pod').q[ + $(NOECHO) $(RM_F) .MM_tmp + + # And again + doc_site_install :: + $(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{DESTINSTALLARCHLIB}, 'perllocal.pod').q[" + $(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB) + $(NOECHO) $(ECHO_N) "installed into|$(INSTALLSITELIB)|" >.MM_tmp + $(NOECHO) $(ECHO_N) "LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES) " >>.MM_tmp + $(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{DESTINSTALLARCHLIB},'perllocal.pod').q[ + $(NOECHO) $(RM_F) .MM_tmp + + doc_vendor_install :: + $(NOECHO) $(ECHO) "Appending installation info to ].$self->catfile($self->{DESTINSTALLARCHLIB}, 'perllocal.pod').q[" + $(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB) + $(NOECHO) $(ECHO_N) "installed into|$(INSTALLVENDORLIB)|" >.MM_tmp + $(NOECHO) $(ECHO_N) "LINKTYPE|$(LINKTYPE)|VERSION|$(VERSION)|EXE_FILES|$(EXE_FILES) " >>.MM_tmp + $(NOECHO) $(DOC_INSTALL) "Module" "$(NAME)" <.MM_tmp >>].$self->catfile($self->{DESTINSTALLARCHLIB},'perllocal.pod').q[ + $(NOECHO) $(RM_F) .MM_tmp + + ] unless $self->{NO_PERLLOCAL}; + + push @m, q[ + uninstall :: uninstall_from_$(INSTALLDIRS)dirs + $(NOECHO) $(NOOP) + + uninstall_from_perldirs :: + $(NOECHO) $(UNINSTALL) ].$self->catfile($self->{PERL_ARCHLIB},'auto',$self->{FULLEXT},'.packlist').q[ + + uninstall_from_sitedirs :: + $(NOECHO) $(UNINSTALL) ].$self->catfile($self->{SITEARCHEXP},'auto',$self->{FULLEXT},'.packlist').q[ + + uninstall_from_vendordirs :: + $(NOECHO) $(UNINSTALL) ].$self->catfile($self->{VENDORARCHEXP},'auto',$self->{FULLEXT},'.packlist').q[ + ]; + + join('',@m); + } + + =item perldepend (override) + + Use VMS-style syntax for files; it's cheaper to just do it directly here + than to have the MM_Unix method call C repeatedly. Also, if + we have to rebuild Config.pm, use MM[SK] to do it. + + =cut + + sub perldepend { + my($self) = @_; + my(@m); + + if ($self->{OBJECT}) { + # Need to add an object file dependency on the perl headers. + # this is very important for XS modules in perl.git development. + + push @m, $self->_perl_header_files_fragment(""); # empty separator on VMS as its in the $(PERL_INC) + } + + if ($self->{PERL_SRC}) { + my(@macros); + my($mmsquals) = '$(USEMAKEFILE)[.vms]$(FIRST_MAKEFILE)'; + push(@macros,'__AXP__=1') if $Config{'archname'} eq 'VMS_AXP'; + push(@macros,'DECC=1') if $Config{'vms_cc_type'} eq 'decc'; + push(@macros,'GNUC=1') if $Config{'vms_cc_type'} eq 'gcc'; + push(@macros,'SOCKET=1') if $Config{'d_has_sockets'}; + push(@macros,qq["CC=$Config{'cc'}"]) if $Config{'cc'} =~ m!/!; + $mmsquals .= '$(USEMACROS)' . join(',',@macros) . '$(MACROEND)' if @macros; + push(@m,q[ + # Check for unpropagated config.sh changes. Should never happen. + # We do NOT just update config.h because that is not sufficient. + # An out of date config.h is not fatal but complains loudly! + $(PERL_INC)config.h : $(PERL_SRC)config.sh + $(NOOP) + + $(PERL_ARCHLIB)Config.pm : $(PERL_SRC)config.sh + $(NOECHO) Write Sys$Error "$(PERL_ARCHLIB)Config.pm may be out of date with config.h or genconfig.pl" + olddef = F$Environment("Default") + Set Default $(PERL_SRC) + $(MMS)],$mmsquals,); + if ($self->{PERL_ARCHLIB} =~ m|\[-| && $self->{PERL_SRC} =~ m|(\[-+)|) { + my($prefix,$target) = ($1,$self->fixpath('$(PERL_ARCHLIB)Config.pm',0)); + $target =~ s/\Q$prefix/[/; + push(@m," $target"); + } + else { push(@m,' $(MMS$TARGET)'); } + push(@m,q[ + Set Default 'olddef' + ]); + } + + push(@m, join(" ", map($self->fixpath($_,0),values %{$self->{XS}}))." : \$(XSUBPPDEPS)\n") + if %{$self->{XS}}; + + join('',@m); + } + + + =item makeaperl (override) + + Undertake to build a new set of Perl images using VMS commands. Since + VMS does dynamic loading, it's not necessary to statically link each + extension into the Perl image, so this isn't the normal build path. + Consequently, it hasn't really been tested, and may well be incomplete. + + =cut + + our %olbs; # needs to be localized + + sub makeaperl { + my($self, %attribs) = @_; + my($makefilename, $searchdirs, $static, $extra, $perlinc, $target, $tmpdir, $libperl) = + @attribs{qw(MAKE DIRS STAT EXTRA INCL TARGET TMP LIBPERL)}; + my(@m); + push @m, " + # --- MakeMaker makeaperl section --- + MAP_TARGET = $target + "; + return join '', @m if $self->{PARENT}; + + my($dir) = join ":", @{$self->{DIR}}; + + unless ($self->{MAKEAPERL}) { + push @m, q{ + $(MAKE_APERL_FILE) : $(FIRST_MAKEFILE) + $(NOECHO) $(ECHO) "Writing ""$(MMS$TARGET)"" for this $(MAP_TARGET)" + $(NOECHO) $(PERLRUNINST) \ + Makefile.PL DIR=}, $dir, q{ \ + FIRST_MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \ + MAKEAPERL=1 NORECURS=1 }; + + push @m, map(q[ \\\n\t\t"$_"], @ARGV),q{ + + $(MAP_TARGET) :: $(MAKE_APERL_FILE) + $(MAKE)$(USEMAKEFILE)$(MAKE_APERL_FILE) static $(MMS$TARGET) + }; + push @m, "\n"; + + return join '', @m; + } + + + my($linkcmd,@optlibs,@staticpkgs,$extralist,$targdir,$libperldir,%libseen); + local($_); + + # The front matter of the linkcommand... + $linkcmd = join ' ', $Config{'ld'}, + grep($_, @Config{qw(large split ldflags ccdlflags)}); + $linkcmd =~ s/\s+/ /g; + + # Which *.olb files could we make use of... + local(%olbs); # XXX can this be lexical? + $olbs{$self->{INST_ARCHAUTODIR}} = "$self->{BASEEXT}\$(LIB_EXT)"; + require File::Find; + File::Find::find(sub { + return unless m/\Q$self->{LIB_EXT}\E$/; + return if m/^libperl/; + + if( exists $self->{INCLUDE_EXT} ){ + my $found = 0; + + (my $xx = $File::Find::name) =~ s,.*?/auto/,,; + $xx =~ s,/?$_,,; + $xx =~ s,/,::,g; + + # Throw away anything not explicitly marked for inclusion. + # DynaLoader is implied. + foreach my $incl ((@{$self->{INCLUDE_EXT}},'DynaLoader')){ + if( $xx eq $incl ){ + $found++; + last; + } + } + return unless $found; + } + elsif( exists $self->{EXCLUDE_EXT} ){ + (my $xx = $File::Find::name) =~ s,.*?/auto/,,; + $xx =~ s,/?$_,,; + $xx =~ s,/,::,g; + + # Throw away anything explicitly marked for exclusion + foreach my $excl (@{$self->{EXCLUDE_EXT}}){ + return if( $xx eq $excl ); + } + } + + $olbs{$ENV{DEFAULT}} = $_; + }, grep( -d $_, @{$searchdirs || []})); + + # We trust that what has been handed in as argument will be buildable + $static = [] unless $static; + @olbs{@{$static}} = (1) x @{$static}; + + $extra = [] unless $extra && ref $extra eq 'ARRAY'; + # Sort the object libraries in inverse order of + # filespec length to try to insure that dependent extensions + # will appear before their parents, so the linker will + # search the parent library to resolve references. + # (e.g. Intuit::DWIM will precede Intuit, so unresolved + # references from [.intuit.dwim]dwim.obj can be found + # in [.intuit]intuit.olb). + for (sort { length($a) <=> length($b) } keys %olbs) { + next unless $olbs{$_} =~ /\Q$self->{LIB_EXT}\E$/; + my($dir) = $self->fixpath($_,1); + my($extralibs) = $dir . "extralibs.ld"; + my($extopt) = $dir . $olbs{$_}; + $extopt =~ s/$self->{LIB_EXT}$/.opt/; + push @optlibs, "$dir$olbs{$_}"; + # Get external libraries this extension will need + if (-f $extralibs ) { + my %seenthis; + open my $list, "<", $extralibs or warn $!,next; + while (<$list>) { + chomp; + # Include a library in the link only once, unless it's mentioned + # multiple times within a single extension's options file, in which + # case we assume the builder needed to search it again later in the + # link. + my $skip = exists($libseen{$_}) && !exists($seenthis{$_}); + $libseen{$_}++; $seenthis{$_}++; + next if $skip; + push @$extra,$_; + } + } + # Get full name of extension for ExtUtils::Miniperl + if (-f $extopt) { + open my $opt, '<', $extopt or die $!; + while (<$opt>) { + next unless /(?:UNIVERSAL|VECTOR)=boot_([\w_]+)/; + my $pkg = $1; + $pkg =~ s#__*#::#g; + push @staticpkgs,$pkg; + } + } + } + # Place all of the external libraries after all of the Perl extension + # libraries in the final link, in order to maximize the opportunity + # for XS code from multiple extensions to resolve symbols against the + # same external library while only including that library once. + push @optlibs, @$extra; + + $target = "Perl$Config{'exe_ext'}" unless $target; + my $shrtarget; + ($shrtarget,$targdir) = fileparse($target); + $shrtarget =~ s/^([^.]*)/$1Shr/; + $shrtarget = $targdir . $shrtarget; + $target = "Perlshr.$Config{'dlext'}" unless $target; + $tmpdir = "[]" unless $tmpdir; + $tmpdir = $self->fixpath($tmpdir,1); + if (@optlibs) { $extralist = join(' ',@optlibs); } + else { $extralist = ''; } + # Let ExtUtils::Liblist find the necessary libs for us (but skip PerlShr) + # that's what we're building here). + push @optlibs, grep { !/PerlShr/i } split ' ', +($self->ext())[2]; + if ($libperl) { + unless (-f $libperl || -f ($libperl = $self->catfile($Config{'installarchlib'},'CORE',$libperl))) { + print "Warning: $libperl not found\n"; + undef $libperl; + } + } + unless ($libperl) { + if (defined $self->{PERL_SRC}) { + $libperl = $self->catfile($self->{PERL_SRC},"libperl$self->{LIB_EXT}"); + } elsif (-f ($libperl = $self->catfile($Config{'installarchlib'},'CORE',"libperl$self->{LIB_EXT}")) ) { + } else { + print "Warning: $libperl not found + If you're going to build a static perl binary, make sure perl is installed + otherwise ignore this warning\n"; + } + } + $libperldir = $self->fixpath((fileparse($libperl))[1],1); + + push @m, ' + # Fill in the target you want to produce if it\'s not perl + MAP_TARGET = ',$self->fixpath($target,0),' + MAP_SHRTARGET = ',$self->fixpath($shrtarget,0)," + MAP_LINKCMD = $linkcmd + MAP_PERLINC = ", $perlinc ? map('"$_" ',@{$perlinc}) : ''," + MAP_EXTRA = $extralist + MAP_LIBPERL = ",$self->fixpath($libperl,0),' + '; + + + push @m,"\n${tmpdir}Makeaperl.Opt : \$(MAP_EXTRA)\n"; + foreach (@optlibs) { + push @m,' $(NOECHO) $(PERL) -e "print q{',$_,'}" >>$(MMS$TARGET)',"\n"; + } + push @m,"\n${tmpdir}PerlShr.Opt :\n\t"; + push @m,'$(NOECHO) $(PERL) -e "print q{$(MAP_SHRTARGET)}" >$(MMS$TARGET)',"\n"; + + push @m,' + $(MAP_SHRTARGET) : $(MAP_LIBPERL) Makeaperl.Opt ',"${libperldir}Perlshr_Attr.Opt",' + $(MAP_LINKCMD)/Shareable=$(MMS$TARGET) $(MAP_LIBPERL), Makeaperl.Opt/Option ',"${libperldir}Perlshr_Attr.Opt/Option",' + $(MAP_TARGET) : $(MAP_SHRTARGET) ',"${tmpdir}perlmain\$(OBJ_EXT) ${tmpdir}PerlShr.Opt",' + $(MAP_LINKCMD) ',"${tmpdir}perlmain\$(OBJ_EXT)",', PerlShr.Opt/Option + $(NOECHO) $(ECHO) "To install the new ""$(MAP_TARGET)"" binary, say" + $(NOECHO) $(ECHO) " $(MAKE)$(USEMAKEFILE)$(FIRST_MAKEFILE) inst_perl $(USEMACROS)MAP_TARGET=$(MAP_TARGET)$(ENDMACRO)" + $(NOECHO) $(ECHO) "To remove the intermediate files, say + $(NOECHO) $(ECHO) " $(MAKE)$(USEMAKEFILE)$(FIRST_MAKEFILE) map_clean" + '; + push @m,"\n${tmpdir}perlmain.c : \$(FIRST_MAKEFILE)\n\t\$(NOECHO) \$(PERL) -e 1 >${tmpdir}Writemain.tmp\n"; + push @m, "# More from the 255-char line length limit\n"; + foreach (@staticpkgs) { + push @m,' $(NOECHO) $(PERL) -e "print q{',$_,qq[}" >>${tmpdir}Writemain.tmp\n]; + } + + push @m, sprintf <<'MAKE_FRAG', $tmpdir, $tmpdir; + $(NOECHO) $(PERL) $(MAP_PERLINC) -ane "use ExtUtils::Miniperl; writemain(@F)" %sWritemain.tmp >$(MMS$TARGET) + $(NOECHO) $(RM_F) %sWritemain.tmp + MAKE_FRAG + + push @m, q[ + # Still more from the 255-char line length limit + doc_inst_perl : + $(NOECHO) $(MKPATH) $(DESTINSTALLARCHLIB) + $(NOECHO) $(ECHO) "Perl binary $(MAP_TARGET)|" >.MM_tmp + $(NOECHO) $(ECHO) "MAP_STATIC|$(MAP_STATIC)|" >>.MM_tmp + $(NOECHO) $(PERL) -pl040 -e " " ].$self->catfile('$(INST_ARCHAUTODIR)','extralibs.all'),q[ >>.MM_tmp + $(NOECHO) $(ECHO) -e "MAP_LIBPERL|$(MAP_LIBPERL)|" >>.MM_tmp + $(NOECHO) $(DOC_INSTALL) <.MM_tmp >>].$self->catfile('$(DESTINSTALLARCHLIB)','perllocal.pod').q[ + $(NOECHO) $(RM_F) .MM_tmp + ]; + + push @m, " + inst_perl : pure_inst_perl doc_inst_perl + \$(NOECHO) \$(NOOP) + + pure_inst_perl : \$(MAP_TARGET) + $self->{CP} \$(MAP_SHRTARGET) ",$self->fixpath($Config{'installbin'},1)," + $self->{CP} \$(MAP_TARGET) ",$self->fixpath($Config{'installbin'},1)," + + clean :: map_clean + \$(NOECHO) \$(NOOP) + + map_clean : + \$(RM_F) ${tmpdir}perlmain\$(OBJ_EXT) ${tmpdir}perlmain.c \$(FIRST_MAKEFILE) + \$(RM_F) ${tmpdir}Makeaperl.Opt ${tmpdir}PerlShr.Opt \$(MAP_TARGET) + "; + + join '', @m; + } + + + # --- Output postprocessing section --- + + =item maketext_filter (override) + + Ensure that colons marking targets are preceded by space, in order + to distinguish the target delimiter from a colon appearing as + part of a filespec. + + =cut + + sub maketext_filter { + my($self, $text) = @_; + + $text =~ s/^([^\s:=]+)(:+\s)/$1 $2/mg; + return $text; + } + + =item prefixify (override) + + prefixifying on VMS is simple. Each should simply be: + + perl_root:[some.dir] + + which can just be converted to: + + volume:[your.prefix.some.dir] + + otherwise you get the default layout. + + In effect, your search prefix is ignored and $Config{vms_prefix} is + used instead. + + =cut + + sub prefixify { + my($self, $var, $sprefix, $rprefix, $default) = @_; + + # Translate $(PERLPREFIX) to a real path. + $rprefix = $self->eliminate_macros($rprefix); + $rprefix = vmspath($rprefix) if $rprefix; + $sprefix = vmspath($sprefix) if $sprefix; + + $default = vmsify($default) + unless $default =~ /\[.*\]/; + + (my $var_no_install = $var) =~ s/^install//; + my $path = $self->{uc $var} || + $ExtUtils::MM_Unix::Config_Override{lc $var} || + $Config{lc $var} || $Config{lc $var_no_install}; + + if( !$path ) { + warn " no Config found for $var.\n" if $Verbose >= 2; + $path = $self->_prefixify_default($rprefix, $default); + } + elsif( !$self->{ARGS}{PREFIX} || !$self->file_name_is_absolute($path) ) { + # do nothing if there's no prefix or if its relative + } + elsif( $sprefix eq $rprefix ) { + warn " no new prefix.\n" if $Verbose >= 2; + } + else { + + warn " prefixify $var => $path\n" if $Verbose >= 2; + warn " from $sprefix to $rprefix\n" if $Verbose >= 2; + + my($path_vol, $path_dirs) = $self->splitpath( $path ); + if( $path_vol eq $Config{vms_prefix}.':' ) { + warn " $Config{vms_prefix}: seen\n" if $Verbose >= 2; + + $path_dirs =~ s{^\[}{\[.} unless $path_dirs =~ m{^\[\.}; + $path = $self->_catprefix($rprefix, $path_dirs); + } + else { + $path = $self->_prefixify_default($rprefix, $default); + } + } + + print " now $path\n" if $Verbose >= 2; + return $self->{uc $var} = $path; + } + + + sub _prefixify_default { + my($self, $rprefix, $default) = @_; + + warn " cannot prefix, using default.\n" if $Verbose >= 2; + + if( !$default ) { + warn "No default!\n" if $Verbose >= 1; + return; + } + if( !$rprefix ) { + warn "No replacement prefix!\n" if $Verbose >= 1; + return ''; + } + + return $self->_catprefix($rprefix, $default); + } + + sub _catprefix { + my($self, $rprefix, $default) = @_; + + my($rvol, $rdirs) = $self->splitpath($rprefix); + if( $rvol ) { + return $self->catpath($rvol, + $self->catdir($rdirs, $default), + '' + ) + } + else { + return $self->catdir($rdirs, $default); + } + } + + + =item cd + + =cut + + sub cd { + my($self, $dir, @cmds) = @_; + + $dir = vmspath($dir); + + my $cmd = join "\n\t", map "$_", @cmds; + + # No leading tab makes it look right when embedded + my $make_frag = sprintf <<'MAKE_FRAG', $dir, $cmd; + startdir = F$Environment("Default") + Set Default %s + %s + Set Default 'startdir' + MAKE_FRAG + + # No trailing newline makes this easier to embed + chomp $make_frag; + + return $make_frag; + } + + + =item oneliner + + =cut + + sub oneliner { + my($self, $cmd, $switches) = @_; + $switches = [] unless defined $switches; + + # Strip leading and trailing newlines + $cmd =~ s{^\n+}{}; + $cmd =~ s{\n+$}{}; + + $cmd = $self->quote_literal($cmd); + $cmd = $self->escape_newlines($cmd); + + # Switches must be quoted else they will be lowercased. + $switches = join ' ', map { qq{"$_"} } @$switches; + + return qq{\$(ABSPERLRUN) $switches -e $cmd "--"}; + } + + + =item B + + perl trips up on "" thinking it's an input redirect. So we use the + native Write command instead. Besides, it's faster. + + =cut + + sub echo { + my($self, $text, $file, $opts) = @_; + + # Compatibility with old options + if( !ref $opts ) { + my $append = $opts; + $opts = { append => $append || 0 }; + } + my $opencmd = $opts->{append} ? 'Open/Append' : 'Open/Write'; + + $opts->{allow_variables} = 0 unless defined $opts->{allow_variables}; + + my $ql_opts = { allow_variables => $opts->{allow_variables} }; + + my @cmds = ("\$(NOECHO) $opencmd MMECHOFILE $file "); + push @cmds, map { '$(NOECHO) Write MMECHOFILE '.$self->quote_literal($_, $ql_opts) } + split /\n/, $text; + push @cmds, '$(NOECHO) Close MMECHOFILE'; + return @cmds; + } + + + =item quote_literal + + =cut + + sub quote_literal { + my($self, $text, $opts) = @_; + $opts->{allow_variables} = 1 unless defined $opts->{allow_variables}; + + # I believe this is all we should need. + $text =~ s{"}{""}g; + + $text = $opts->{allow_variables} + ? $self->escape_dollarsigns($text) : $self->escape_all_dollarsigns($text); + + return qq{"$text"}; + } + + =item escape_dollarsigns + + Quote, don't escape. + + =cut + + sub escape_dollarsigns { + my($self, $text) = @_; + + # Quote dollar signs which are not starting a variable + $text =~ s{\$ (?!\() }{"\$"}gx; + + return $text; + } + + + =item escape_all_dollarsigns + + Quote, don't escape. + + =cut + + sub escape_all_dollarsigns { + my($self, $text) = @_; + + # Quote dollar signs + $text =~ s{\$}{"\$\"}gx; + + return $text; + } + + =item escape_newlines + + =cut + + sub escape_newlines { + my($self, $text) = @_; + + $text =~ s{\n}{-\n}g; + + return $text; + } + + =item max_exec_len + + 256 characters. + + =cut + + sub max_exec_len { + my $self = shift; + + return $self->{_MAX_EXEC_LEN} ||= 256; + } + + =item init_linker + + =cut + + sub init_linker { + my $self = shift; + $self->{EXPORT_LIST} ||= '$(BASEEXT).opt'; + + my $shr = $Config{dbgprefix} . 'PERLSHR'; + if ($self->{PERL_SRC}) { + $self->{PERL_ARCHIVE} ||= + $self->catfile($self->{PERL_SRC}, "$shr.$Config{'dlext'}"); + } + else { + $self->{PERL_ARCHIVE} ||= + $ENV{$shr} ? $ENV{$shr} : "Sys\$Share:$shr.$Config{'dlext'}"; + } + + $self->{PERL_ARCHIVEDEP} ||= ''; + $self->{PERL_ARCHIVE_AFTER} ||= ''; + } + + + =item catdir (override) + + =item catfile (override) + + Eliminate the macros in the output to the MMS/MMK file. + + (File::Spec::VMS used to do this for us, but it's being removed) + + =cut + + sub catdir { + my $self = shift; + + # Process the macros on VMS MMS/MMK + my @args = map { m{\$\(} ? $self->eliminate_macros($_) : $_ } @_; + + my $dir = $self->SUPER::catdir(@args); + + # Fix up the directory and force it to VMS format. + $dir = $self->fixpath($dir, 1); + + return $dir; + } + + sub catfile { + my $self = shift; + + # Process the macros on VMS MMS/MMK + my @args = map { m{\$\(} ? $self->eliminate_macros($_) : $_ } @_; + + my $file = $self->SUPER::catfile(@args); + + $file = vmsify($file); + + return $file + } + + + =item eliminate_macros + + Expands MM[KS]/Make macros in a text string, using the contents of + identically named elements of C<%$self>, and returns the result + as a file specification in Unix syntax. + + NOTE: This is the canonical version of the method. The version in + File::Spec::VMS is deprecated. + + =cut + + sub eliminate_macros { + my($self,$path) = @_; + return '' unless $path; + $self = {} unless ref $self; + + my($npath) = unixify($path); + # sometimes unixify will return a string with an off-by-one trailing null + $npath =~ s{\0$}{}; + + my($complex) = 0; + my($head,$macro,$tail); + + # perform m##g in scalar context so it acts as an iterator + while ($npath =~ m#(.*?)\$\((\S+?)\)(.*)#gs) { + if (defined $self->{$2}) { + ($head,$macro,$tail) = ($1,$2,$3); + if (ref $self->{$macro}) { + if (ref $self->{$macro} eq 'ARRAY') { + $macro = join ' ', @{$self->{$macro}}; + } + else { + print "Note: can't expand macro \$($macro) containing ",ref($self->{$macro}), + "\n\t(using MMK-specific deferred substitutuon; MMS will break)\n"; + $macro = "\cB$macro\cB"; + $complex = 1; + } + } + else { ($macro = unixify($self->{$macro})) =~ s#/\Z(?!\n)##; } + $npath = "$head$macro$tail"; + } + } + if ($complex) { $npath =~ s#\cB(.*?)\cB#\${$1}#gs; } + $npath; + } + + =item fixpath + + my $path = $mm->fixpath($path); + my $path = $mm->fixpath($path, $is_dir); + + Catchall routine to clean up problem MM[SK]/Make macros. Expands macros + in any directory specification, in order to avoid juxtaposing two + VMS-syntax directories when MM[SK] is run. Also expands expressions which + are all macro, so that we can tell how long the expansion is, and avoid + overrunning DCL's command buffer when MM[KS] is running. + + fixpath() checks to see whether the result matches the name of a + directory in the current default directory and returns a directory or + file specification accordingly. C<$is_dir> can be set to true to + force fixpath() to consider the path to be a directory or false to force + it to be a file. + + NOTE: This is the canonical version of the method. The version in + File::Spec::VMS is deprecated. + + =cut + + sub fixpath { + my($self,$path,$force_path) = @_; + return '' unless $path; + $self = bless {}, $self unless ref $self; + my($fixedpath,$prefix,$name); + + if ($path =~ m#^\$\([^\)]+\)\Z(?!\n)#s || $path =~ m#[/:>\]]#) { + if ($force_path or $path =~ /(?:DIR\)|\])\Z(?!\n)/) { + $fixedpath = vmspath($self->eliminate_macros($path)); + } + else { + $fixedpath = vmsify($self->eliminate_macros($path)); + } + } + elsif ((($prefix,$name) = ($path =~ m#^\$\(([^\)]+)\)(.+)#s)) && $self->{$prefix}) { + my($vmspre) = $self->eliminate_macros("\$($prefix)"); + # is it a dir or just a name? + $vmspre = ($vmspre =~ m|/| or $prefix =~ /DIR\Z(?!\n)/) ? vmspath($vmspre) : ''; + $fixedpath = ($vmspre ? $vmspre : $self->{$prefix}) . $name; + $fixedpath = vmspath($fixedpath) if $force_path; + } + else { + $fixedpath = $path; + $fixedpath = vmspath($fixedpath) if $force_path; + } + # No hints, so we try to guess + if (!defined($force_path) and $fixedpath !~ /[:>(.\]]/) { + $fixedpath = vmspath($fixedpath) if -d $fixedpath; + } + + # Trim off root dirname if it's had other dirs inserted in front of it. + $fixedpath =~ s/\.000000([\]>])/$1/; + # Special case for VMS absolute directory specs: these will have had device + # prepended during trip through Unix syntax in eliminate_macros(), since + # Unix syntax has no way to express "absolute from the top of this device's + # directory tree". + if ($path =~ /^[\[>][^.\-]/) { $fixedpath =~ s/^[^\[<]+//; } + + return $fixedpath; + } + + + =item os_flavor + + VMS is VMS. + + =cut + + sub os_flavor { + return('VMS'); + } + + + =item is_make_type (override) + + None of the make types being checked for is viable on VMS, + plus our $self->{MAKE} is an unexpanded (and unexpandable) + macro whose value is known only to the make utility itself. + + =cut + + sub is_make_type { + my($self, $type) = @_; + return 0; + } + + + =item make_type (override) + + Returns a suitable string describing the type of makefile being written. + + =cut + + sub make_type { "$Config{make}-style"; } + + + =back + + + =head1 AUTHOR + + Original author Charles Bailey F + + Maintained by Michael G Schwern F + + See L for patching and contact information. + + + =cut + + 1; + +EXTUTILS_MM_VMS + +$fatpacked{"ExtUtils/MM_VOS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_VOS'; + package ExtUtils::MM_VOS; + + use strict; + our $VERSION = '7.06'; + $VERSION = eval $VERSION; + + require ExtUtils::MM_Unix; + our @ISA = qw(ExtUtils::MM_Unix); + + + =head1 NAME + + ExtUtils::MM_VOS - VOS specific subclass of ExtUtils::MM_Unix + + =head1 SYNOPSIS + + Don't use this module directly. + Use ExtUtils::MM and let it choose. + + =head1 DESCRIPTION + + This is a subclass of ExtUtils::MM_Unix which contains functionality for + VOS. + + Unless otherwise stated it works just like ExtUtils::MM_Unix + + =head2 Overridden methods + + =head3 extra_clean_files + + Cleanup VOS core files + + =cut + + sub extra_clean_files { + return qw(*.kp); + } + + + =head1 AUTHOR + + Michael G Schwern with code from ExtUtils::MM_Unix + + =head1 SEE ALSO + + L + + =cut + + + 1; +EXTUTILS_MM_VOS + +$fatpacked{"ExtUtils/MM_Win32.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_WIN32'; + package ExtUtils::MM_Win32; + + use strict; + + + =head1 NAME + + ExtUtils::MM_Win32 - methods to override UN*X behaviour in ExtUtils::MakeMaker + + =head1 SYNOPSIS + + use ExtUtils::MM_Win32; # Done internally by ExtUtils::MakeMaker if needed + + =head1 DESCRIPTION + + See ExtUtils::MM_Unix for a documentation of the methods provided + there. This package overrides the implementation of these methods, not + the semantics. + + =cut + + use ExtUtils::MakeMaker::Config; + use File::Basename; + use File::Spec; + use ExtUtils::MakeMaker qw(neatvalue _sprintf562); + + require ExtUtils::MM_Any; + require ExtUtils::MM_Unix; + our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix ); + our $VERSION = '7.06'; + $VERSION = eval $VERSION; + + $ENV{EMXSHELL} = 'sh'; # to run `commands` + + my ( $BORLAND, $GCC, $MSVC, $DLLTOOL ) = _identify_compiler_environment( \%Config ); + + sub _identify_compiler_environment { + my ( $config ) = @_; + + my $BORLAND = $config->{cc} =~ /\bbcc/i ? 1 : 0; + my $GCC = $config->{cc} =~ /\bgcc\b/i ? 1 : 0; + my $MSVC = $config->{cc} =~ /\b(?:cl|icl)/i ? 1 : 0; # MSVC can come as clarm.exe, icl=Intel C + my $DLLTOOL = $config->{dlltool} || 'dlltool'; + + return ( $BORLAND, $GCC, $MSVC, $DLLTOOL ); + } + + + =head2 Overridden methods + + =over 4 + + =item B + + =cut + + sub dlsyms { + my($self,%attribs) = @_; + return '' if $self->{SKIPHASH}{'dynamic'}; + $self->xs_dlsyms_iterator(\%attribs); + } + + =item xs_dlsyms_ext + + On Win32, is C<.def>. + + =cut + + sub xs_dlsyms_ext { + '.def'; + } + + =item replace_manpage_separator + + Changes the path separator with . + + =cut + + sub replace_manpage_separator { + my($self,$man) = @_; + $man =~ s,/+,.,g; + $man; + } + + + =item B + + Since Windows has nothing as simple as an executable bit, we check the + file extension. + + The PATHEXT env variable will be used to get a list of extensions that + might indicate a command, otherwise .com, .exe, .bat and .cmd will be + used by default. + + =cut + + sub maybe_command { + my($self,$file) = @_; + my @e = exists($ENV{'PATHEXT'}) + ? split(/;/, $ENV{PATHEXT}) + : qw(.com .exe .bat .cmd); + my $e = ''; + for (@e) { $e .= "\Q$_\E|" } + chop $e; + # see if file ends in one of the known extensions + if ($file =~ /($e)$/i) { + return $file if -e $file; + } + else { + for (@e) { + return "$file$_" if -e "$file$_"; + } + } + return; + } + + + =item B + + Using \ for Windows, except for "gmake" where it is /. + + =cut + + sub init_DIRFILESEP { + my($self) = shift; + + # The ^ makes sure its not interpreted as an escape in nmake + $self->{DIRFILESEP} = $self->is_make_type('nmake') ? '^\\' : + $self->is_make_type('dmake') ? '\\\\' : + $self->is_make_type('gmake') ? '/' + : '\\'; + } + + =item init_tools + + Override some of the slower, portable commands with Windows specific ones. + + =cut + + sub init_tools { + my ($self) = @_; + + $self->{NOOP} ||= 'rem'; + $self->{DEV_NULL} ||= '> NUL'; + + $self->{FIXIN} ||= $self->{PERL_CORE} ? + "\$(PERLRUN) $self->{PERL_SRC}\\win32\\bin\\pl2bat.pl" : + 'pl2bat.bat'; + + $self->SUPER::init_tools; + + # Setting SHELL from $Config{sh} can break dmake. Its ok without it. + delete $self->{SHELL}; + + return; + } + + + =item init_others + + Override the default link and compile tools. + + LDLOADLIBS's default is changed to $Config{libs}. + + Adjustments are made for Borland's quirks needing -L to come first. + + =cut + + sub init_others { + my $self = shift; + + $self->{LD} ||= 'link'; + $self->{AR} ||= 'lib'; + + $self->SUPER::init_others; + + $self->{LDLOADLIBS} ||= $Config{libs}; + # -Lfoo must come first for Borland, so we put it in LDDLFLAGS + if ($BORLAND) { + my $libs = $self->{LDLOADLIBS}; + my $libpath = ''; + while ($libs =~ s/(?:^|\s)(("?)-L.+?\2)(?:\s|$)/ /) { + $libpath .= ' ' if length $libpath; + $libpath .= $1; + } + $self->{LDLOADLIBS} = $libs; + $self->{LDDLFLAGS} ||= $Config{lddlflags}; + $self->{LDDLFLAGS} .= " $libpath"; + } + + return; + } + + + =item init_platform + + Add MM_Win32_VERSION. + + =item platform_constants + + =cut + + sub init_platform { + my($self) = shift; + + $self->{MM_Win32_VERSION} = $VERSION; + + return; + } + + sub platform_constants { + my($self) = shift; + my $make_frag = ''; + + foreach my $macro (qw(MM_Win32_VERSION)) + { + next unless defined $self->{$macro}; + $make_frag .= "$macro = $self->{$macro}\n"; + } + + return $make_frag; + } + + =item specify_shell + + Set SHELL to $ENV{COMSPEC} only if make is type 'gmake'. + + =cut + + sub specify_shell { + my $self = shift; + return '' unless $self->is_make_type('gmake'); + "\nSHELL = $ENV{COMSPEC}\n"; + } + + =item constants + + Add MAXLINELENGTH for dmake before all the constants are output. + + =cut + + sub constants { + my $self = shift; + + my $make_text = $self->SUPER::constants; + return $make_text unless $self->is_make_type('dmake'); + + # dmake won't read any single "line" (even those with escaped newlines) + # larger than a certain size which can be as small as 8k. PM_TO_BLIB + # on large modules like DateTime::TimeZone can create lines over 32k. + # So we'll crank it up to a WHOPPING 64k. + # + # This has to come here before all the constants and not in + # platform_constants which is after constants. + my $size = $self->{MAXLINELENGTH} || 800000; + my $prefix = qq{ + # Get dmake to read long commands like PM_TO_BLIB + MAXLINELENGTH = $size + + }; + + return $prefix . $make_text; + } + + + =item special_targets + + Add .USESHELL target for dmake. + + =cut + + sub special_targets { + my($self) = @_; + + my $make_frag = $self->SUPER::special_targets; + + $make_frag .= <<'MAKE_FRAG' if $self->is_make_type('dmake'); + .USESHELL : + MAKE_FRAG + + return $make_frag; + } + + =item static_lib_pure_cmd + + Defines how to run the archive utility + + =cut + + sub static_lib_pure_cmd { + my ($self, $from) = @_; + $from =~ s/(\$\(\w+)(\))/$1:^"+"$2/g if $BORLAND; + sprintf qq{\t\$(AR) %s\n}, ($BORLAND ? '$@ ' . $from + : ($GCC ? '-ru $@ ' . $from + : '-out:$@ ' . $from)); + } + + =item dynamic_lib + + Methods are overridden here: not dynamic_lib itself, but the utility + ones that do the OS-specific work. + + =cut + + sub xs_make_dynamic_lib { + my ($self, $attribs, $from, $to, $todir, $ldfrom, $exportlist) = @_; + my @m = sprintf '%s : %s $(MYEXTLIB) %s$(DFSEP).exists %s $(PERL_ARCHIVEDEP) $(INST_DYNAMIC_DEP)'."\n", $to, $from, $todir, $exportlist; + if ($GCC) { + # per https://rt.cpan.org/Ticket/Display.html?id=78395 no longer + # uses dlltool - relies on post 2002 MinGW + # 1 2 + push @m, _sprintf562 <<'EOF', $exportlist, $ldfrom; + $(LD) %1$s -o $@ $(LDDLFLAGS) %2$s $(OTHERLDFLAGS) $(MYEXTLIB) "$(PERL_ARCHIVE)" $(LDLOADLIBS) -Wl,--enable-auto-image-base + EOF + } elsif ($BORLAND) { + my $ldargs = $self->is_make_type('dmake') + ? q{"$(PERL_ARCHIVE:s,/,\,)" $(LDLOADLIBS:s,/,\,) $(MYEXTLIB:s,/,\,),} + : q{"$(subst /,\,$(PERL_ARCHIVE))" $(subst /,\,$(LDLOADLIBS)) $(subst /,\,$(MYEXTLIB)),}; + my $subbed; + if ($exportlist eq '$(EXPORT_LIST)') { + $subbed = $self->is_make_type('dmake') + ? q{$(EXPORT_LIST:s,/,\,)} + : q{$(subst /,\,$(EXPORT_LIST))}; + } else { + # in XSMULTI, exportlist is per-XS, so have to sub in perl not make + ($subbed = $exportlist) =~ s#/#\\#g; + } + push @m, sprintf <<'EOF', $ldfrom, $ldargs . $subbed; + $(LD) $(LDDLFLAGS) $(OTHERLDFLAGS) %s,$@,,%s,$(RESFILES) + EOF + } else { # VC + push @m, sprintf <<'EOF', $ldfrom, $exportlist; + $(LD) -out:$@ $(LDDLFLAGS) %s $(OTHERLDFLAGS) $(MYEXTLIB) "$(PERL_ARCHIVE)" $(LDLOADLIBS) -def:%s + EOF + # Embed the manifest file if it exists + push(@m, q{ if exist $@.manifest mt -nologo -manifest $@.manifest -outputresource:$@;2 + if exist $@.manifest del $@.manifest}); + } + push @m, "\n\t\$(CHMOD) \$(PERM_RWX) \$\@\n"; + + join '', @m; + } + + sub xs_dynamic_lib_macros { + my ($self, $attribs) = @_; + my $otherldflags = $attribs->{OTHERLDFLAGS} || ($BORLAND ? 'c0d32.obj': ''); + my $inst_dynamic_dep = $attribs->{INST_DYNAMIC_DEP} || ""; + sprintf <<'EOF', $otherldflags, $inst_dynamic_dep; + # This section creates the dynamically loadable objects from relevant + # objects and possibly $(MYEXTLIB). + OTHERLDFLAGS = %s + INST_DYNAMIC_DEP = %s + EOF + } + + =item extra_clean_files + + Clean out some extra dll.{base,exp} files which might be generated by + gcc. Otherwise, take out all *.pdb files. + + =cut + + sub extra_clean_files { + my $self = shift; + + return $GCC ? (qw(dll.base dll.exp)) : ('*.pdb'); + } + + =item init_linker + + =cut + + sub init_linker { + my $self = shift; + + $self->{PERL_ARCHIVE} = "\$(PERL_INC)\\$Config{libperl}"; + $self->{PERL_ARCHIVEDEP} = "\$(PERL_INCDEP)\\$Config{libperl}"; + $self->{PERL_ARCHIVE_AFTER} = ''; + $self->{EXPORT_LIST} = '$(BASEEXT).def'; + } + + + =item perl_script + + Checks for the perl program under several common perl extensions. + + =cut + + sub perl_script { + my($self,$file) = @_; + return $file if -r $file && -f _; + return "$file.pl" if -r "$file.pl" && -f _; + return "$file.plx" if -r "$file.plx" && -f _; + return "$file.bat" if -r "$file.bat" && -f _; + return; + } + + sub can_dep_space { + my $self = shift; + 1; # with Win32::GetShortPathName + } + + =item quote_dep + + =cut + + sub quote_dep { + my ($self, $arg) = @_; + if ($arg =~ / / and not $self->is_make_type('gmake')) { + require Win32; + $arg = Win32::GetShortPathName($arg); + die <SUPER::quote_dep($arg); + } + + + =item xs_obj_opt + + Override to fixup -o flags for MSVC. + + =cut + + sub xs_obj_opt { + my ($self, $output_file) = @_; + ($MSVC ? "/Fo" : "-o ") . $output_file; + } + + + =item pasthru + + All we send is -nologo to nmake to prevent it from printing its damned + banner. + + =cut + + sub pasthru { + my($self) = shift; + my $old = $self->SUPER::pasthru; + return $old unless $self->is_make_type('nmake'); + $old =~ s/(PASTHRU\s*=\s*)/$1 -nologo /; + $old; + } + + + =item arch_check (override) + + Normalize all arguments for consistency of comparison. + + =cut + + sub arch_check { + my $self = shift; + + # Win32 is an XS module, minperl won't have it. + # arch_check() is not critical, so just fake it. + return 1 unless $self->can_load_xs; + return $self->SUPER::arch_check( map { $self->_normalize_path_name($_) } @_); + } + + sub _normalize_path_name { + my $self = shift; + my $file = shift; + + require Win32; + my $short = Win32::GetShortPathName($file); + return defined $short ? lc $short : lc $file; + } + + + =item oneliner + + These are based on what command.com does on Win98. They may be wrong + for other Windows shells, I don't know. + + =cut + + sub oneliner { + my($self, $cmd, $switches) = @_; + $switches = [] unless defined $switches; + + # Strip leading and trailing newlines + $cmd =~ s{^\n+}{}; + $cmd =~ s{\n+$}{}; + + $cmd = $self->quote_literal($cmd); + $cmd = $self->escape_newlines($cmd); + + $switches = join ' ', @$switches; + + return qq{\$(ABSPERLRUN) $switches -e $cmd --}; + } + + + sub quote_literal { + my($self, $text, $opts) = @_; + $opts->{allow_variables} = 1 unless defined $opts->{allow_variables}; + + # See: http://www.autohotkey.net/~deleyd/parameters/parameters.htm#CPP + + # Apply the Microsoft C/C++ parsing rules + $text =~ s{\\\\"}{\\\\\\\\\\"}g; # \\" -> \\\\\" + $text =~ s{(? \\\" + $text =~ s{(? \" + $text = qq{"$text"} if $text =~ /[ \t]/; + + # Apply the Command Prompt parsing rules (cmd.exe) + my @text = split /("[^"]*")/, $text; + # We should also escape parentheses, but it breaks one-liners containing + # $(MACRO)s in makefiles. + s{([<>|&^@!])}{^$1}g foreach grep { !/^"[^"]*"$/ } @text; + $text = join('', @text); + + # dmake expands {{ to { and }} to }. + if( $self->is_make_type('dmake') ) { + $text =~ s/{/{{/g; + $text =~ s/}/}}/g; + } + + $text = $opts->{allow_variables} + ? $self->escape_dollarsigns($text) : $self->escape_all_dollarsigns($text); + + return $text; + } + + + sub escape_newlines { + my($self, $text) = @_; + + # Escape newlines + $text =~ s{\n}{\\\n}g; + + return $text; + } + + + =item cd + + dmake can handle Unix style cd'ing but nmake (at least 1.5) cannot. It + wants: + + cd dir1\dir2 + command + another_command + cd ..\.. + + =cut + + sub cd { + my($self, $dir, @cmds) = @_; + + return $self->SUPER::cd($dir, @cmds) unless $self->is_make_type('nmake'); + + my $cmd = join "\n\t", map "$_", @cmds; + + my $updirs = $self->catdir(map { $self->updir } $self->splitdir($dir)); + + # No leading tab and no trailing newline makes for easier embedding. + my $make_frag = sprintf <<'MAKE_FRAG', $dir, $cmd, $updirs; + cd %s + %s + cd %s + MAKE_FRAG + + chomp $make_frag; + + return $make_frag; + } + + + =item max_exec_len + + nmake 1.50 limits command length to 2048 characters. + + =cut + + sub max_exec_len { + my $self = shift; + + return $self->{_MAX_EXEC_LEN} ||= 2 * 1024; + } + + + =item os_flavor + + Windows is Win32. + + =cut + + sub os_flavor { + return('Win32'); + } + + + =item cflags + + Defines the PERLDLL symbol if we are configured for static building since all + code destined for the perl5xx.dll must be compiled with the PERLDLL symbol + defined. + + =cut + + sub cflags { + my($self,$libperl)=@_; + return $self->{CFLAGS} if $self->{CFLAGS}; + return '' unless $self->needs_linking(); + + my $base = $self->SUPER::cflags($libperl); + foreach (split /\n/, $base) { + /^(\S*)\s*=\s*(\S*)$/ and $self->{$1} = $2; + }; + $self->{CCFLAGS} .= " -DPERLDLL" if ($self->{LINKTYPE} eq 'static'); + + return $self->{CFLAGS} = qq{ + CCFLAGS = $self->{CCFLAGS} + OPTIMIZE = $self->{OPTIMIZE} + PERLTYPE = $self->{PERLTYPE} + }; + + } + + =item make_type + + Returns a suitable string describing the type of makefile being written. + + =cut + + sub make_type { + my ($self) = @_; + my $make = $self->make; + $make = +( File::Spec->splitpath( $make ) )[-1]; + $make =~ s!\.exe$!!i; + if ( $make =~ m![^A-Z0-9]!i ) { + ($make) = grep { m!make!i } split m![^A-Z0-9]!i, $make; + } + return "$make-style"; + } + + 1; + __END__ + + =back +EXTUTILS_MM_WIN32 + +$fatpacked{"ExtUtils/MM_Win95.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MM_WIN95'; + package ExtUtils::MM_Win95; + + use strict; + + our $VERSION = '7.06'; + $VERSION = eval $VERSION; + + require ExtUtils::MM_Win32; + our @ISA = qw(ExtUtils::MM_Win32); + + use ExtUtils::MakeMaker::Config; + + + =head1 NAME + + ExtUtils::MM_Win95 - method to customize MakeMaker for Win9X + + =head1 SYNOPSIS + + You should not be using this module directly. + + =head1 DESCRIPTION + + This is a subclass of ExtUtils::MM_Win32 containing changes necessary + to get MakeMaker playing nice with command.com and other Win9Xisms. + + =head2 Overridden methods + + Most of these make up for limitations in the Win9x/nmake command shell. + + =over 4 + + + =item max_exec_len + + Win98 chokes on things like Encode if we set the max length to nmake's max + of 2K. So we go for a more conservative value of 1K. + + =cut + + sub max_exec_len { + my $self = shift; + + return $self->{_MAX_EXEC_LEN} ||= 1024; + } + + + =item os_flavor + + Win95 and Win98 and WinME are collectively Win9x and Win32 + + =cut + + sub os_flavor { + my $self = shift; + return ($self->SUPER::os_flavor, 'Win9x'); + } + + + =back + + + =head1 AUTHOR + + Code originally inside MM_Win32. Original author unknown. + + Currently maintained by Michael G Schwern C. + + Send patches and ideas to C. + + See https://metacpan.org/release/ExtUtils-MakeMaker. + + =cut + + + 1; +EXTUTILS_MM_WIN95 + +$fatpacked{"ExtUtils/MY.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MY'; + package ExtUtils::MY; + + use strict; + require ExtUtils::MM; + + our $VERSION = '7.06'; + $VERSION = eval $VERSION; + our @ISA = qw(ExtUtils::MM); + + { + package MY; + our @ISA = qw(ExtUtils::MY); + } + + sub DESTROY {} + + + =head1 NAME + + ExtUtils::MY - ExtUtils::MakeMaker subclass for customization + + =head1 SYNOPSIS + + # in your Makefile.PL + sub MY::whatever { + ... + } + + =head1 DESCRIPTION + + B + + ExtUtils::MY is a subclass of ExtUtils::MM. Its provided in your + Makefile.PL for you to add and override MakeMaker functionality. + + It also provides a convenient alias via the MY class. + + ExtUtils::MY might turn out to be a temporary solution, but MY won't + go away. + + =cut +EXTUTILS_MY + +$fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MAKEMAKER'; + # $Id$ + package ExtUtils::MakeMaker; + + use strict; + + BEGIN {require 5.006;} + + require Exporter; + use ExtUtils::MakeMaker::Config; + use ExtUtils::MakeMaker::version; # ensure we always have our fake version.pm + use Carp; + use File::Path; + my $CAN_DECODE = eval { require ExtUtils::MakeMaker::Locale; }; # 2 birds, 1 stone + eval { ExtUtils::MakeMaker::Locale::reinit('UTF-8') } + if $CAN_DECODE and $ExtUtils::MakeMaker::Locale::ENCODING_LOCALE eq 'US-ASCII'; + + our $Verbose = 0; # exported + our @Parent; # needs to be localized + our @Get_from_Config; # referenced by MM_Unix + our @MM_Sections; + our @Overridable; + my @Prepend_parent; + my %Recognized_Att_Keys; + our %macro_fsentity; # whether a macro is a filesystem name + our %macro_dep; # whether a macro is a dependency + + our $VERSION = '7.06'; + $VERSION = eval $VERSION; ## no critic [BuiltinFunctions::ProhibitStringyEval] + + # Emulate something resembling CVS $Revision$ + (our $Revision = $VERSION) =~ s{_}{}; + $Revision = int $Revision * 10000; + + our $Filename = __FILE__; # referenced outside MakeMaker + + our @ISA = qw(Exporter); + our @EXPORT = qw(&WriteMakefile $Verbose &prompt); + our @EXPORT_OK = qw($VERSION &neatvalue &mkbootstrap &mksymlists + &WriteEmptyMakefile &open_for_writing &write_file_via_tmp + &_sprintf562); + + # These will go away once the last of the Win32 & VMS specific code is + # purged. + my $Is_VMS = $^O eq 'VMS'; + my $Is_Win32 = $^O eq 'MSWin32'; + my $UNDER_CORE = $ENV{PERL_CORE}; + + full_setup(); + + require ExtUtils::MM; # Things like CPAN assume loading ExtUtils::MakeMaker + # will give them MM. + + require ExtUtils::MY; # XXX pre-5.8 versions of ExtUtils::Embed expect + # loading ExtUtils::MakeMaker will give them MY. + # This will go when Embed is its own CPAN module. + + + # 5.6.2 can't do sprintf "%1$s" - this can only do %s + sub _sprintf562 { + my ($format, @args) = @_; + for (my $i = 1; $i <= @args; $i++) { + $format =~ s#%$i\$s#$args[$i-1]#g; + } + $format; + } + + sub WriteMakefile { + croak "WriteMakefile: Need even number of args" if @_ % 2; + + require ExtUtils::MY; + my %att = @_; + + _convert_compat_attrs(\%att); + + _verify_att(\%att); + + my $mm = MM->new(\%att); + $mm->flush; + + return $mm; + } + + + # Basic signatures of the attributes WriteMakefile takes. Each is the + # reference type. Empty value indicate it takes a non-reference + # scalar. + my %Att_Sigs; + my %Special_Sigs = ( + AUTHOR => 'ARRAY', + C => 'ARRAY', + CONFIG => 'ARRAY', + CONFIGURE => 'CODE', + DIR => 'ARRAY', + DL_FUNCS => 'HASH', + DL_VARS => 'ARRAY', + EXCLUDE_EXT => 'ARRAY', + EXE_FILES => 'ARRAY', + FUNCLIST => 'ARRAY', + H => 'ARRAY', + IMPORTS => 'HASH', + INCLUDE_EXT => 'ARRAY', + LIBS => ['ARRAY',''], + MAN1PODS => 'HASH', + MAN3PODS => 'HASH', + META_ADD => 'HASH', + META_MERGE => 'HASH', + OBJECT => ['ARRAY', ''], + PL_FILES => 'HASH', + PM => 'HASH', + PMLIBDIRS => 'ARRAY', + PMLIBPARENTDIRS => 'ARRAY', + PREREQ_PM => 'HASH', + BUILD_REQUIRES => 'HASH', + CONFIGURE_REQUIRES => 'HASH', + TEST_REQUIRES => 'HASH', + SKIP => 'ARRAY', + TYPEMAPS => 'ARRAY', + XS => 'HASH', + XSBUILD => 'HASH', + VERSION => ['version',''], + _KEEP_AFTER_FLUSH => '', + + clean => 'HASH', + depend => 'HASH', + dist => 'HASH', + dynamic_lib=> 'HASH', + linkext => 'HASH', + macro => 'HASH', + postamble => 'HASH', + realclean => 'HASH', + test => 'HASH', + tool_autosplit => 'HASH', + ); + + @Att_Sigs{keys %Recognized_Att_Keys} = ('') x keys %Recognized_Att_Keys; + @Att_Sigs{keys %Special_Sigs} = values %Special_Sigs; + + sub _convert_compat_attrs { #result of running several times should be same + my($att) = @_; + if (exists $att->{AUTHOR}) { + if ($att->{AUTHOR}) { + if (!ref($att->{AUTHOR})) { + my $t = $att->{AUTHOR}; + $att->{AUTHOR} = [$t]; + } + } else { + $att->{AUTHOR} = []; + } + } + } + + sub _verify_att { + my($att) = @_; + + while( my($key, $val) = each %$att ) { + my $sig = $Att_Sigs{$key}; + unless( defined $sig ) { + warn "WARNING: $key is not a known parameter.\n"; + next; + } + + my @sigs = ref $sig ? @$sig : $sig; + my $given = ref $val; + unless( grep { _is_of_type($val, $_) } @sigs ) { + my $takes = join " or ", map { _format_att($_) } @sigs; + + my $has = _format_att($given); + warn "WARNING: $key takes a $takes not a $has.\n". + " Please inform the author.\n"; + } + } + } + + + # Check if a given thing is a reference or instance of $type + sub _is_of_type { + my($thing, $type) = @_; + + return 1 if ref $thing eq $type; + + local $SIG{__DIE__}; + return 1 if eval{ $thing->isa($type) }; + + return 0; + } + + + sub _format_att { + my $given = shift; + + return $given eq '' ? "string/number" + : uc $given eq $given ? "$given reference" + : "$given object" + ; + } + + + sub prompt ($;$) { ## no critic + my($mess, $def) = @_; + confess("prompt function called without an argument") + unless defined $mess; + + my $isa_tty = -t STDIN && (-t STDOUT || !(-f STDOUT || -c STDOUT)) ; + + my $dispdef = defined $def ? "[$def] " : " "; + $def = defined $def ? $def : ""; + + local $|=1; + local $\; + print "$mess $dispdef"; + + my $ans; + if ($ENV{PERL_MM_USE_DEFAULT} || (!$isa_tty && eof STDIN)) { + print "$def\n"; + } + else { + $ans = ; + if( defined $ans ) { + $ans =~ s{\015?\012$}{}; + } + else { # user hit ctrl-D + print "\n"; + } + } + + return (!defined $ans || $ans eq '') ? $def : $ans; + } + + sub eval_in_subdirs { + my($self) = @_; + use Cwd qw(cwd abs_path); + my $pwd = cwd() || die "Can't figure out your cwd!"; + + local @INC = map eval {abs_path($_) if -e} || $_, @INC; + push @INC, '.'; # '.' has to always be at the end of @INC + + foreach my $dir (@{$self->{DIR}}){ + my($abs) = $self->catdir($pwd,$dir); + eval { $self->eval_in_x($abs); }; + last if $@; + } + chdir $pwd; + die $@ if $@; + } + + sub eval_in_x { + my($self,$dir) = @_; + chdir $dir or carp("Couldn't change to directory $dir: $!"); + + { + package main; + do './Makefile.PL'; + }; + if ($@) { + # if ($@ =~ /prerequisites/) { + # die "MakeMaker WARNING: $@"; + # } else { + # warn "WARNING from evaluation of $dir/Makefile.PL: $@"; + # } + die "ERROR from evaluation of $dir/Makefile.PL: $@"; + } + } + + + # package name for the classes into which the first object will be blessed + my $PACKNAME = 'PACK000'; + + sub full_setup { + $Verbose ||= 0; + + my @dep_macros = qw/ + PERL_INCDEP PERL_ARCHLIBDEP PERL_ARCHIVEDEP + /; + + my @fs_macros = qw/ + FULLPERL XSUBPPDIR + + INST_ARCHLIB INST_SCRIPT INST_BIN INST_LIB INST_MAN1DIR INST_MAN3DIR + INSTALLDIRS + DESTDIR PREFIX INSTALL_BASE + PERLPREFIX SITEPREFIX VENDORPREFIX + INSTALLPRIVLIB INSTALLSITELIB INSTALLVENDORLIB + INSTALLARCHLIB INSTALLSITEARCH INSTALLVENDORARCH + INSTALLBIN INSTALLSITEBIN INSTALLVENDORBIN + INSTALLMAN1DIR INSTALLMAN3DIR + INSTALLSITEMAN1DIR INSTALLSITEMAN3DIR + INSTALLVENDORMAN1DIR INSTALLVENDORMAN3DIR + INSTALLSCRIPT INSTALLSITESCRIPT INSTALLVENDORSCRIPT + PERL_LIB PERL_ARCHLIB + SITELIBEXP SITEARCHEXP + + MAKE LIBPERL_A LIB PERL_SRC PERL_INC + PPM_INSTALL_EXEC PPM_UNINSTALL_EXEC + PPM_INSTALL_SCRIPT PPM_UNINSTALL_SCRIPT + /; + + my @attrib_help = qw/ + + AUTHOR ABSTRACT ABSTRACT_FROM BINARY_LOCATION + C CAPI CCFLAGS CONFIG CONFIGURE DEFINE DIR DISTNAME DISTVNAME + DL_FUNCS DL_VARS + EXCLUDE_EXT EXE_FILES FIRST_MAKEFILE + FULLPERLRUN FULLPERLRUNINST + FUNCLIST H IMPORTS + + INC INCLUDE_EXT LDFROM LIBS LICENSE + LINKTYPE MAKEAPERL MAKEFILE MAKEFILE_OLD MAN1PODS MAN3PODS MAP_TARGET + META_ADD META_MERGE MIN_PERL_VERSION BUILD_REQUIRES CONFIGURE_REQUIRES + MYEXTLIB NAME NEEDS_LINKING NOECHO NO_META NO_MYMETA NO_PACKLIST NO_PERLLOCAL + NORECURS NO_VC OBJECT OPTIMIZE PERL_MALLOC_OK PERL PERLMAINCC PERLRUN + PERLRUNINST PERL_CORE + PERM_DIR PERM_RW PERM_RWX MAGICXS + PL_FILES PM PM_FILTER PMLIBDIRS PMLIBPARENTDIRS POLLUTE + PREREQ_FATAL PREREQ_PM PREREQ_PRINT PRINT_PREREQ + SIGN SKIP TEST_REQUIRES TYPEMAPS UNINST VERSION VERSION_FROM XS + XSBUILD XSMULTI XSOPT XSPROTOARG XS_VERSION + clean depend dist dynamic_lib linkext macro realclean tool_autosplit + + MAN1EXT MAN3EXT + + MACPERL_SRC MACPERL_LIB MACLIBS_68K MACLIBS_PPC MACLIBS_SC MACLIBS_MRC + MACLIBS_ALL_68K MACLIBS_ALL_PPC MACLIBS_SHARED + /; + push @attrib_help, @fs_macros; + @macro_fsentity{@fs_macros, @dep_macros} = (1) x (@fs_macros+@dep_macros); + @macro_dep{@dep_macros} = (1) x @dep_macros; + + # IMPORTS is used under OS/2 and Win32 + + # @Overridable is close to @MM_Sections but not identical. The + # order is important. Many subroutines declare macros. These + # depend on each other. Let's try to collect the macros up front, + # then pasthru, then the rules. + + # MM_Sections are the sections we have to call explicitly + # in Overridable we have subroutines that are used indirectly + + + @MM_Sections = + qw( + + post_initialize const_config constants platform_constants + tool_autosplit tool_xsubpp tools_other + + makemakerdflt + + dist macro depend cflags const_loadlibs const_cccmd + post_constants + + pasthru + + special_targets + c_o xs_c xs_o + top_targets blibdirs linkext dlsyms dynamic_bs dynamic + dynamic_lib static static_lib manifypods processPL + installbin subdirs + clean_subdirs clean realclean_subdirs realclean + metafile signature + dist_basics dist_core distdir dist_test dist_ci distmeta distsignature + install force perldepend makefile staticmake test ppd + + ); # loses section ordering + + @Overridable = @MM_Sections; + push @Overridable, qw[ + + libscan makeaperl needs_linking + subdir_x test_via_harness test_via_script + + init_VERSION init_dist init_INST init_INSTALL init_DEST init_dirscan + init_PM init_MANPODS init_xs init_PERL init_DIRFILESEP init_linker + ]; + + push @MM_Sections, qw[ + + pm_to_blib selfdocument + + ]; + + # Postamble needs to be the last that was always the case + push @MM_Sections, "postamble"; + push @Overridable, "postamble"; + + # All sections are valid keys. + @Recognized_Att_Keys{@MM_Sections} = (1) x @MM_Sections; + + # we will use all these variables in the Makefile + @Get_from_Config = + qw( + ar cc cccdlflags ccdlflags dlext dlsrc exe_ext full_ar ld + lddlflags ldflags libc lib_ext obj_ext osname osvers ranlib + sitelibexp sitearchexp so + ); + + # 5.5.3 doesn't have any concept of vendor libs + push @Get_from_Config, qw( vendorarchexp vendorlibexp ) if $] >= 5.006; + + foreach my $item (@attrib_help){ + $Recognized_Att_Keys{$item} = 1; + } + foreach my $item (@Get_from_Config) { + $Recognized_Att_Keys{uc $item} = $Config{$item}; + print "Attribute '\U$item\E' => '$Config{$item}'\n" + if ($Verbose >= 2); + } + + # + # When we eval a Makefile.PL in a subdirectory, that one will ask + # us (the parent) for the values and will prepend "..", so that + # all files to be installed end up below OUR ./blib + # + @Prepend_parent = qw( + INST_BIN INST_LIB INST_ARCHLIB INST_SCRIPT + MAP_TARGET INST_MAN1DIR INST_MAN3DIR PERL_SRC + PERL FULLPERL + ); + } + + sub _has_cpan_meta_requirements { + return eval { + require CPAN::Meta::Requirements; + CPAN::Meta::Requirements->VERSION(2.130); + require B; # CMR requires this, for core we have to too. + }; + } + + sub new { + my($class,$self) = @_; + my($key); + + _convert_compat_attrs($self) if defined $self && $self; + + # Store the original args passed to WriteMakefile() + foreach my $k (keys %$self) { + $self->{ARGS}{$k} = $self->{$k}; + } + + $self = {} unless defined $self; + + # Temporarily bless it into MM so it can be used as an + # object. It will be blessed into a temp package later. + bless $self, "MM"; + + # Cleanup all the module requirement bits + my %key2cmr; + for my $key (qw(PREREQ_PM BUILD_REQUIRES CONFIGURE_REQUIRES TEST_REQUIRES)) { + $self->{$key} ||= {}; + if (_has_cpan_meta_requirements) { + my $cmr = CPAN::Meta::Requirements->from_string_hash( + $self->{$key}, + { + bad_version_hook => sub { + carp "Unparsable version '$_[0]' for prerequisite $_[1] treated as 0"; + version->new(0); + }, + }, + ); + $self->{$key} = $cmr->as_string_hash; + $key2cmr{$key} = $cmr; + } else { + for my $module (sort keys %{ $self->{$key} }) { + my $version = $self->{$key}->{$module}; + if (!defined($version) or !length($version)) { + carp "Undefined requirement for $module treated as '0' (CPAN::Meta::Requirements not available)"; + } else { + next if $version =~ /^\d+(?:\.\d+(?:_\d+)*)?$/; + carp "Unparsable version '$version' for prerequisite $module treated as 0 (CPAN::Meta::Requirements not available)"; + } + $self->{$key}->{$module} = 0; + } + } + } + + if ("@ARGV" =~ /\bPREREQ_PRINT\b/) { + $self->_PREREQ_PRINT; + } + + # PRINT_PREREQ is RedHatism. + if ("@ARGV" =~ /\bPRINT_PREREQ\b/) { + $self->_PRINT_PREREQ; + } + + print "MakeMaker (v$VERSION)\n" if $Verbose; + if (-f "MANIFEST" && ! -f "Makefile" && ! $ENV{PERL_CORE}){ + check_manifest(); + } + + check_hints($self); + + if ( defined $self->{MIN_PERL_VERSION} + && $self->{MIN_PERL_VERSION} !~ /^v?[\d_\.]+$/ ) { + require version; + my $normal = eval { + local $SIG{__WARN__} = sub { + # simulate "use warnings FATAL => 'all'" for vintage perls + die @_; + }; + version->new( $self->{MIN_PERL_VERSION} ) + }; + $self->{MIN_PERL_VERSION} = $normal if defined $normal && !$@; + } + + # Translate X.Y.Z to X.00Y00Z + if( defined $self->{MIN_PERL_VERSION} ) { + $self->{MIN_PERL_VERSION} =~ s{ ^v? (\d+) \. (\d+) \. (\d+) $ } + {sprintf "%d.%03d%03d", $1, $2, $3}ex; + } + + my $perl_version_ok = eval { + local $SIG{__WARN__} = sub { + # simulate "use warnings FATAL => 'all'" for vintage perls + die @_; + }; + !$self->{MIN_PERL_VERSION} or $self->{MIN_PERL_VERSION} <= $] + }; + if (!$perl_version_ok) { + if (!defined $perl_version_ok) { + die <<'END'; + Warning: MIN_PERL_VERSION is not in a recognized format. + Recommended is a quoted numerical value like '5.005' or '5.008001'. + END + } + elsif ($self->{PREREQ_FATAL}) { + die sprintf <<"END", $self->{MIN_PERL_VERSION}, $]; + MakeMaker FATAL: perl version too low for this distribution. + Required is %s. We run %s. + END + } + else { + warn sprintf + "Warning: Perl version %s or higher required. We run %s.\n", + $self->{MIN_PERL_VERSION}, $]; + } + } + + my %configure_att; # record &{$self->{CONFIGURE}} attributes + my(%initial_att) = %$self; # record initial attributes + + my(%unsatisfied) = (); + my %prereq2version; + my $cmr; + if (_has_cpan_meta_requirements) { + $cmr = CPAN::Meta::Requirements->new; + for my $key (qw(PREREQ_PM BUILD_REQUIRES CONFIGURE_REQUIRES TEST_REQUIRES)) { + $cmr->add_requirements($key2cmr{$key}) if $key2cmr{$key}; + } + foreach my $prereq ($cmr->required_modules) { + $prereq2version{$prereq} = $cmr->requirements_for_module($prereq); + } + } else { + for my $key (qw(PREREQ_PM BUILD_REQUIRES CONFIGURE_REQUIRES TEST_REQUIRES)) { + next unless my $module2version = $self->{$key}; + $prereq2version{$_} = $module2version->{$_} for keys %$module2version; + } + } + foreach my $prereq (sort keys %prereq2version) { + my $required_version = $prereq2version{$prereq}; + + my $pr_version = 0; + my $installed_file; + + if ( $prereq eq 'perl' ) { + if ( defined $required_version && $required_version =~ /^v?[\d_\.]+$/ + || $required_version !~ /^v?[\d_\.]+$/ ) { + require version; + my $normal = eval { version->new( $required_version ) }; + $required_version = $normal if defined $normal; + } + $installed_file = $prereq; + $pr_version = $]; + } + else { + $installed_file = MM->_installed_file_for_module($prereq); + $pr_version = MM->parse_version($installed_file) if $installed_file; + $pr_version = 0 if $pr_version eq 'undef'; + } + + # convert X.Y_Z alpha version #s to X.YZ for easier comparisons + $pr_version =~ s/(\d+)\.(\d+)_(\d+)/$1.$2$3/; + + if (!$installed_file) { + warn sprintf "Warning: prerequisite %s %s not found.\n", + $prereq, $required_version + unless $self->{PREREQ_FATAL} + or $ENV{PERL_CORE}; + + $unsatisfied{$prereq} = 'not installed'; + } + elsif ( + $cmr + ? !$cmr->accepts_module($prereq, $pr_version) + : $required_version > $pr_version + ) { + warn sprintf "Warning: prerequisite %s %s not found. We have %s.\n", + $prereq, $required_version, ($pr_version || 'unknown version') + unless $self->{PREREQ_FATAL} + or $ENV{PERL_CORE}; + + $unsatisfied{$prereq} = $required_version || 'unknown version' ; + } + } + + if (%unsatisfied && $self->{PREREQ_FATAL}){ + my $failedprereqs = join "\n", map {" $_ $unsatisfied{$_}"} + sort { $a cmp $b } keys %unsatisfied; + die <<"END"; + MakeMaker FATAL: prerequisites not found. + $failedprereqs + + Please install these modules first and rerun 'perl Makefile.PL'. + END + } + + if (defined $self->{CONFIGURE}) { + if (ref $self->{CONFIGURE} eq 'CODE') { + %configure_att = %{&{$self->{CONFIGURE}}}; + _convert_compat_attrs(\%configure_att); + $self = { %$self, %configure_att }; + } else { + croak "Attribute 'CONFIGURE' to WriteMakefile() not a code reference\n"; + } + } + + # This is for old Makefiles written pre 5.00, will go away + if ( Carp::longmess("") =~ /runsubdirpl/s ){ + carp("WARNING: Please rerun 'perl Makefile.PL' to regenerate your Makefiles\n"); + } + + my $newclass = ++$PACKNAME; + local @Parent = @Parent; # Protect against non-local exits + { + print "Blessing Object into class [$newclass]\n" if $Verbose>=2; + mv_all_methods("MY",$newclass); + bless $self, $newclass; + push @Parent, $self; + require ExtUtils::MY; + + no strict 'refs'; ## no critic; + @{"$newclass\:\:ISA"} = 'MM'; + } + + if (defined $Parent[-2]){ + $self->{PARENT} = $Parent[-2]; + for my $key (@Prepend_parent) { + next unless defined $self->{PARENT}{$key}; + + # Don't stomp on WriteMakefile() args. + next if defined $self->{ARGS}{$key} and + $self->{ARGS}{$key} eq $self->{$key}; + + $self->{$key} = $self->{PARENT}{$key}; + + if ($Is_VMS && $key =~ /PERL$/) { + # PERL or FULLPERL will be a command verb or even a + # command with an argument instead of a full file + # specification under VMS. So, don't turn the command + # into a filespec, but do add a level to the path of + # the argument if not already absolute. + my @cmd = split /\s+/, $self->{$key}; + $cmd[1] = $self->catfile('[-]',$cmd[1]) + unless (@cmd < 2) || $self->file_name_is_absolute($cmd[1]); + $self->{$key} = join(' ', @cmd); + } else { + my $value = $self->{$key}; + # not going to test in FS so only stripping start + $value =~ s/^"// if $key =~ /PERL$/; + $value = $self->catdir("..", $value) + unless $self->file_name_is_absolute($value); + $value = qq{"$value} if $key =~ /PERL$/; + $self->{$key} = $value; + } + } + if ($self->{PARENT}) { + $self->{PARENT}->{CHILDREN}->{$newclass} = $self; + foreach my $opt (qw(POLLUTE PERL_CORE LINKTYPE LD OPTIMIZE)) { + if (exists $self->{PARENT}->{$opt} + and not exists $self->{$opt}) + { + # inherit, but only if already unspecified + $self->{$opt} = $self->{PARENT}->{$opt}; + } + } + } + my @fm = grep /^FIRST_MAKEFILE=/, @ARGV; + parse_args($self,@fm) if @fm; + } + else { + parse_args($self, _shellwords($ENV{PERL_MM_OPT} || ''),@ARGV); + } + + # RT#91540 PREREQ_FATAL not recognized on command line + if (%unsatisfied && $self->{PREREQ_FATAL}){ + my $failedprereqs = join "\n", map {" $_ $unsatisfied{$_}"} + sort { $a cmp $b } keys %unsatisfied; + die <<"END"; + MakeMaker FATAL: prerequisites not found. + $failedprereqs + + Please install these modules first and rerun 'perl Makefile.PL'. + END + } + + $self->{NAME} ||= $self->guess_name; + + warn "Warning: NAME must be a package name\n" + unless $self->{NAME} =~ m!^[A-Z_a-z][0-9A-Z_a-z]*(?:::[0-9A-Z_a-z]+)*$!; + + ($self->{NAME_SYM} = $self->{NAME}) =~ s/\W+/_/g; + + $self->init_MAKE; + $self->init_main; + $self->init_VERSION; + $self->init_dist; + $self->init_INST; + $self->init_INSTALL; + $self->init_DEST; + $self->init_dirscan; + $self->init_PM; + $self->init_MANPODS; + $self->init_xs; + $self->init_PERL; + $self->init_DIRFILESEP; + $self->init_linker; + $self->init_ABSTRACT; + + $self->arch_check( + $INC{'Config.pm'}, + $self->catfile($Config{'archlibexp'}, "Config.pm") + ); + + $self->init_tools(); + $self->init_others(); + $self->init_platform(); + $self->init_PERM(); + my @args = @ARGV; + @args = map { Encode::decode(locale => $_) } @args if $CAN_DECODE; + my($argv) = neatvalue(\@args); + $argv =~ s/^\[/(/; + $argv =~ s/\]$/)/; + + push @{$self->{RESULT}}, <{NAME} extension to perl. + # + # It was generated automatically by MakeMaker version + # $VERSION (Revision: $Revision) from the contents of + # Makefile.PL. Don't edit this file, edit Makefile.PL instead. + # + # ANY CHANGES MADE HERE WILL BE LOST! + # + # MakeMaker ARGV: $argv + # + END + + push @{$self->{RESULT}}, $self->_MakeMaker_Parameters_section(\%initial_att); + + if (defined $self->{CONFIGURE}) { + push @{$self->{RESULT}}, < 0) { + foreach my $key (sort keys %configure_att){ + next if $key eq 'ARGS'; + my($v) = neatvalue($configure_att{$key}); + $v =~ s/(CODE|HASH|ARRAY|SCALAR)\([\dxa-f]+\)/$1\(...\)/; + $v =~ tr/\n/ /s; + push @{$self->{RESULT}}, "# $key => $v"; + } + } + else + { + push @{$self->{RESULT}}, "# no values returned"; + } + undef %configure_att; # free memory + } + + # turn the SKIP array into a SKIPHASH hash + for my $skip (@{$self->{SKIP} || []}) { + $self->{SKIPHASH}{$skip} = 1; + } + delete $self->{SKIP}; # free memory + + if ($self->{PARENT}) { + for (qw/install dist dist_basics dist_core distdir dist_test dist_ci/) { + $self->{SKIPHASH}{$_} = 1; + } + } + + # We run all the subdirectories now. They don't have much to query + # from the parent, but the parent has to query them: if they need linking! + unless ($self->{NORECURS}) { + $self->eval_in_subdirs if @{$self->{DIR}}; + } + + foreach my $section ( @MM_Sections ){ + # Support for new foo_target() methods. + my $method = $section; + $method .= '_target' unless $self->can($method); + + print "Processing Makefile '$section' section\n" if ($Verbose >= 2); + my($skipit) = $self->skipcheck($section); + if ($skipit){ + push @{$self->{RESULT}}, "\n# --- MakeMaker $section section $skipit."; + } else { + my(%a) = %{$self->{$section} || {}}; + push @{$self->{RESULT}}, "\n# --- MakeMaker $section section:"; + push @{$self->{RESULT}}, "# " . join ", ", %a if $Verbose && %a; + push @{$self->{RESULT}}, $self->maketext_filter( + $self->$method( %a ) + ); + } + } + + push @{$self->{RESULT}}, "\n# End."; + + $self; + } + + sub WriteEmptyMakefile { + croak "WriteEmptyMakefile: Need an even number of args" if @_ % 2; + + my %att = @_; + $att{NAME} = 'Dummy' unless $att{NAME}; # eliminate pointless warnings + $att{DIR} = [] unless $att{DIR}; # don't recurse by default + my $self = MM->new(\%att); + require File::Path; + require File::Spec; + File::Path::rmtree( File::Spec->catdir(qw[blib _eumm]) ); # because MM->new does too much stuff + + my $new = $self->{MAKEFILE}; + my $old = $self->{MAKEFILE_OLD}; + if (-f $old) { + _unlink($old) or warn "unlink $old: $!"; + } + if ( -f $new ) { + _rename($new, $old) or warn "rename $new => $old: $!" + } + open my $mfh, '>', $new or die "open $new for write: $!"; + printf $mfh <<'EOP', $self->{RM_F}, $self->{MAKEFILE}; + all : + + manifypods : + + subdirs : + + dynamic : + + static : + + realclean : clean + + clean : + %s %s + + install : + + makemakerdflt : + + test : + + test_dynamic : + + test_static : + + EOP + close $mfh or die "close $new for write: $!"; + } + + + =begin private + + =head3 _installed_file_for_module + + my $file = MM->_installed_file_for_module($module); + + Return the first installed .pm $file associated with the $module. The + one which will show up when you C. + + $module is something like "strict" or "Test::More". + + =end private + + =cut + + sub _installed_file_for_module { + my $class = shift; + my $prereq = shift; + + my $file = "$prereq.pm"; + $file =~ s{::}{/}g; + + my $path; + for my $dir (@INC) { + my $tmp = File::Spec->catfile($dir, $file); + if ( -r $tmp ) { + $path = $tmp; + last; + } + } + + return $path; + } + + + # Extracted from MakeMaker->new so we can test it + sub _MakeMaker_Parameters_section { + my $self = shift; + my $att = shift; + + my @result = <<'END'; + # MakeMaker Parameters: + END + + foreach my $key (sort keys %$att){ + next if $key eq 'ARGS'; + my $v; + if ($key eq 'PREREQ_PM') { + # CPAN.pm takes prereqs from this field in 'Makefile' + # and does not know about BUILD_REQUIRES + $v = neatvalue({ + %{ $att->{PREREQ_PM} || {} }, + %{ $att->{BUILD_REQUIRES} || {} }, + %{ $att->{TEST_REQUIRES} || {} }, + }); + } else { + $v = neatvalue($att->{$key}); + } + + $v =~ s/(CODE|HASH|ARRAY|SCALAR)\([\dxa-f]+\)/$1\(...\)/; + $v =~ tr/\n/ /s; + push @result, "# $key => $v"; + } + + return @result; + } + + # _shellwords and _parseline borrowed from Text::ParseWords + sub _shellwords { + my (@lines) = @_; + my @allwords; + + foreach my $line (@lines) { + $line =~ s/^\s+//; + my @words = _parse_line('\s+', 0, $line); + pop @words if (@words and !defined $words[-1]); + return() unless (@words || !length($line)); + push(@allwords, @words); + } + return(@allwords); + } + + sub _parse_line { + my($delimiter, $keep, $line) = @_; + my($word, @pieces); + + no warnings 'uninitialized'; # we will be testing undef strings + + while (length($line)) { + # This pattern is optimised to be stack conservative on older perls. + # Do not refactor without being careful and testing it on very long strings. + # See Perl bug #42980 for an example of a stack busting input. + $line =~ s/^ + (?: + # double quoted string + (") # $quote + ((?>[^\\"]*(?:\\.[^\\"]*)*))" # $quoted + | # --OR-- + # singe quoted string + (') # $quote + ((?>[^\\']*(?:\\.[^\\']*)*))' # $quoted + | # --OR-- + # unquoted string + ( # $unquoted + (?:\\.|[^\\"'])*? + ) + # followed by + ( # $delim + \Z(?!\n) # EOL + | # --OR-- + (?-x:$delimiter) # delimiter + | # --OR-- + (?!^)(?=["']) # a quote + ) + )//xs or return; # extended layout + my ($quote, $quoted, $unquoted, $delim) = (($1 ? ($1,$2) : ($3,$4)), $5, $6); + + + return() unless( defined($quote) || length($unquoted) || length($delim)); + + if ($keep) { + $quoted = "$quote$quoted$quote"; + } + else { + $unquoted =~ s/\\(.)/$1/sg; + if (defined $quote) { + $quoted =~ s/\\(.)/$1/sg if ($quote eq '"'); + #$quoted =~ s/\\([\\'])/$1/g if ( $PERL_SINGLE_QUOTE && $quote eq "'"); + } + } + $word .= substr($line, 0, 0); # leave results tainted + $word .= defined $quote ? $quoted : $unquoted; + + if (length($delim)) { + push(@pieces, $word); + push(@pieces, $delim) if ($keep eq 'delimiters'); + undef $word; + } + if (!length($line)) { + push(@pieces, $word); + } + } + return(@pieces); + } + + sub check_manifest { + print "Checking if your kit is complete...\n"; + require ExtUtils::Manifest; + # avoid warning + $ExtUtils::Manifest::Quiet = $ExtUtils::Manifest::Quiet = 1; + my(@missed) = ExtUtils::Manifest::manicheck(); + if (@missed) { + print "Warning: the following files are missing in your kit:\n"; + print "\t", join "\n\t", @missed; + print "\n"; + print "Please inform the author.\n"; + } else { + print "Looks good\n"; + } + } + + sub parse_args{ + my($self, @args) = @_; + @args = map { Encode::decode(locale => $_) } @args if $CAN_DECODE; + foreach (@args) { + unless (m/(.*?)=(.*)/) { + ++$Verbose if m/^verb/; + next; + } + my($name, $value) = ($1, $2); + if ($value =~ m/^~(\w+)?/) { # tilde with optional username + $value =~ s [^~(\w*)] + [$1 ? + ((getpwnam($1))[7] || "~$1") : + (getpwuid($>))[7] + ]ex; + } + + # Remember the original args passed it. It will be useful later. + $self->{ARGS}{uc $name} = $self->{uc $name} = $value; + } + + # catch old-style 'potential_libs' and inform user how to 'upgrade' + if (defined $self->{potential_libs}){ + my($msg)="'potential_libs' => '$self->{potential_libs}' should be"; + if ($self->{potential_libs}){ + print "$msg changed to:\n\t'LIBS' => ['$self->{potential_libs}']\n"; + } else { + print "$msg deleted.\n"; + } + $self->{LIBS} = [$self->{potential_libs}]; + delete $self->{potential_libs}; + } + # catch old-style 'ARMAYBE' and inform user how to 'upgrade' + if (defined $self->{ARMAYBE}){ + my($armaybe) = $self->{ARMAYBE}; + print "ARMAYBE => '$armaybe' should be changed to:\n", + "\t'dynamic_lib' => {ARMAYBE => '$armaybe'}\n"; + my(%dl) = %{$self->{dynamic_lib} || {}}; + $self->{dynamic_lib} = { %dl, ARMAYBE => $armaybe}; + delete $self->{ARMAYBE}; + } + if (defined $self->{LDTARGET}){ + print "LDTARGET should be changed to LDFROM\n"; + $self->{LDFROM} = $self->{LDTARGET}; + delete $self->{LDTARGET}; + } + # Turn a DIR argument on the command line into an array + if (defined $self->{DIR} && ref \$self->{DIR} eq 'SCALAR') { + # So they can choose from the command line, which extensions they want + # the grep enables them to have some colons too much in case they + # have to build a list with the shell + $self->{DIR} = [grep $_, split ":", $self->{DIR}]; + } + # Turn a INCLUDE_EXT argument on the command line into an array + if (defined $self->{INCLUDE_EXT} && ref \$self->{INCLUDE_EXT} eq 'SCALAR') { + $self->{INCLUDE_EXT} = [grep $_, split '\s+', $self->{INCLUDE_EXT}]; + } + # Turn a EXCLUDE_EXT argument on the command line into an array + if (defined $self->{EXCLUDE_EXT} && ref \$self->{EXCLUDE_EXT} eq 'SCALAR') { + $self->{EXCLUDE_EXT} = [grep $_, split '\s+', $self->{EXCLUDE_EXT}]; + } + + foreach my $mmkey (sort keys %$self){ + next if $mmkey eq 'ARGS'; + print " $mmkey => ", neatvalue($self->{$mmkey}), "\n" if $Verbose; + print "'$mmkey' is not a known MakeMaker parameter name.\n" + unless exists $Recognized_Att_Keys{$mmkey}; + } + $| = 1 if $Verbose; + } + + sub check_hints { + my($self) = @_; + # We allow extension-specific hints files. + + require File::Spec; + my $curdir = File::Spec->curdir; + + my $hint_dir = File::Spec->catdir($curdir, "hints"); + return unless -d $hint_dir; + + # First we look for the best hintsfile we have + my($hint)="${^O}_$Config{osvers}"; + $hint =~ s/\./_/g; + $hint =~ s/_$//; + return unless $hint; + + # Also try without trailing minor version numbers. + while (1) { + last if -f File::Spec->catfile($hint_dir, "$hint.pl"); # found + } continue { + last unless $hint =~ s/_[^_]*$//; # nothing to cut off + } + my $hint_file = File::Spec->catfile($hint_dir, "$hint.pl"); + + return unless -f $hint_file; # really there + + _run_hintfile($self, $hint_file); + } + + sub _run_hintfile { + our $self; + local($self) = shift; # make $self available to the hint file. + my($hint_file) = shift; + + local($@, $!); + print "Processing hints file $hint_file\n" if $Verbose; + + # Just in case the ./ isn't on the hint file, which File::Spec can + # often strip off, we bung the curdir into @INC + local @INC = (File::Spec->curdir, @INC); + my $ret = do $hint_file; + if( !defined $ret ) { + my $error = $@ || $!; + warn $error; + } + } + + sub mv_all_methods { + my($from,$to) = @_; + local $SIG{__WARN__} = sub { + # can't use 'no warnings redefined', 5.6 only + warn @_ unless $_[0] =~ /^Subroutine .* redefined/ + }; + foreach my $method (@Overridable) { + next unless defined &{"${from}::$method"}; + no strict 'refs'; ## no critic + *{"${to}::$method"} = \&{"${from}::$method"}; + + # If we delete a method, then it will be undefined and cannot + # be called. But as long as we have Makefile.PLs that rely on + # %MY:: being intact, we have to fill the hole with an + # inheriting method: + + { + package MY; + my $super = "SUPER::".$method; + *{$method} = sub { + shift->$super(@_); + }; + } + } + } + + sub skipcheck { + my($self) = shift; + my($section) = @_; + if ($section eq 'dynamic') { + print "Warning (non-fatal): Target 'dynamic' depends on targets ", + "in skipped section 'dynamic_bs'\n" + if $self->{SKIPHASH}{dynamic_bs} && $Verbose; + print "Warning (non-fatal): Target 'dynamic' depends on targets ", + "in skipped section 'dynamic_lib'\n" + if $self->{SKIPHASH}{dynamic_lib} && $Verbose; + } + if ($section eq 'dynamic_lib') { + print "Warning (non-fatal): Target '\$(INST_DYNAMIC)' depends on ", + "targets in skipped section 'dynamic_bs'\n" + if $self->{SKIPHASH}{dynamic_bs} && $Verbose; + } + if ($section eq 'static') { + print "Warning (non-fatal): Target 'static' depends on targets ", + "in skipped section 'static_lib'\n" + if $self->{SKIPHASH}{static_lib} && $Verbose; + } + return 'skipped' if $self->{SKIPHASH}{$section}; + return ''; + } + + # returns filehandle, dies on fail. :raw so no :crlf + sub open_for_writing { + my ($file) = @_; + open my $fh ,">", $file or die "Unable to open $file: $!"; + my @layers = ':raw'; + push @layers, join ' ', ':encoding(locale)' if $CAN_DECODE; + binmode $fh, join ' ', @layers; + $fh; + } + + sub flush { + my $self = shift; + + my $finalname = $self->{MAKEFILE}; + printf "Generating a %s %s\n", $self->make_type, $finalname; + print "Writing $finalname for $self->{NAME}\n"; + + unlink($finalname, "MakeMaker.tmp", $Is_VMS ? 'Descrip.MMS' : ()); + + write_file_via_tmp($finalname, $self->{RESULT}); + + # Write MYMETA.yml to communicate metadata up to the CPAN clients + print "Writing MYMETA.yml and MYMETA.json\n" + if !$self->{NO_MYMETA} and $self->write_mymeta( $self->mymeta ); + + # save memory + if ($self->{PARENT} && !$self->{_KEEP_AFTER_FLUSH}) { + my %keep = map { ($_ => 1) } qw(NEEDS_LINKING HAS_LINK_CODE); + delete $self->{$_} for grep !$keep{$_}, keys %$self; + } + + system("$Config::Config{eunicefix} $finalname") + if $Config::Config{eunicefix} ne ":"; + + return; + } + + sub write_file_via_tmp { + my ($finalname, $contents) = @_; + my $fh = open_for_writing("MakeMaker.tmp"); + die "write_file_via_tmp: 2nd arg must be ref" unless ref $contents; + for my $chunk (@$contents) { + my $to_write = $chunk; + utf8::encode $to_write if !$CAN_DECODE && $] > 5.008; + print $fh "$to_write\n" or die "Can't write to MakeMaker.tmp: $!"; + } + close $fh or die "Can't write to MakeMaker.tmp: $!"; + _rename("MakeMaker.tmp", $finalname) or + warn "rename MakeMaker.tmp => $finalname: $!"; + chmod 0644, $finalname if !$Is_VMS; + return; + } + + # This is a rename for OS's where the target must be unlinked first. + sub _rename { + my($src, $dest) = @_; + _unlink($dest); + return rename $src, $dest; + } + + # This is an unlink for OS's where the target must be writable first. + sub _unlink { + my @files = @_; + chmod 0666, @files; + return unlink @files; + } + + + # The following mkbootstrap() is only for installations that are calling + # the pre-4.1 mkbootstrap() from their old Makefiles. This MakeMaker + # writes Makefiles, that use ExtUtils::Mkbootstrap directly. + sub mkbootstrap { + die <".neatvalue($v->{$key}); + } + return "{ ".join(', ',@m)." }"; + } + + sub _find_magic_vstring { + my $value = shift; + return $value if $UNDER_CORE; + my $tvalue = ''; + require B; + my $sv = B::svref_2object(\$value); + my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef; + while ( $magic ) { + if ( $magic->TYPE eq 'V' ) { + $tvalue = $magic->PTR; + $tvalue =~ s/^v?(.+)$/v$1/; + last; + } + else { + $magic = $magic->MOREMAGIC; + } + } + return $tvalue; + } + + sub selfdocument { + my($self) = @_; + my(@m); + if ($Verbose){ + push @m, "\n# Full list of MakeMaker attribute values:"; + foreach my $key (sort keys %$self){ + next if $key eq 'RESULT' || $key =~ /^[A-Z][a-z]/; + my($v) = neatvalue($self->{$key}); + $v =~ s/(CODE|HASH|ARRAY|SCALAR)\([\dxa-f]+\)/$1\(...\)/; + $v =~ tr/\n/ /s; + push @m, "# $key => $v"; + } + } + # added here as selfdocument is not overridable + push @m, <<'EOF'; + + # here so even if top_targets is overridden, these will still be defined + # gmake will silently still work if any are .PHONY-ed but nmake won't + static :: + $(NOECHO) $(NOOP) + + dynamic :: + $(NOECHO) $(NOOP) + EOF + push @m, join "\n", map "$_ ::\n\t\$(NOECHO) \$(NOOP)\n", + # config is so manifypods won't puke if no subdirs + qw(static dynamic config); + join "\n", @m; + } + + 1; + + __END__ + + =head1 NAME + + ExtUtils::MakeMaker - Create a module Makefile + + =head1 SYNOPSIS + + use ExtUtils::MakeMaker; + + WriteMakefile( + NAME => "Foo::Bar", + VERSION_FROM => "lib/Foo/Bar.pm", + ); + + =head1 DESCRIPTION + + This utility is designed to write a Makefile for an extension module + from a Makefile.PL. It is based on the Makefile.SH model provided by + Andy Dougherty and the perl5-porters. + + It splits the task of generating the Makefile into several subroutines + that can be individually overridden. Each subroutine returns the text + it wishes to have written to the Makefile. + + As there are various Make programs with incompatible syntax, which + use operating system shells, again with incompatible syntax, it is + important for users of this module to know which flavour of Make + a Makefile has been written for so they'll use the correct one and + won't have to face the possibly bewildering errors resulting from + using the wrong one. + + On POSIX systems, that program will likely be GNU Make; on Microsoft + Windows, it will be either Microsoft NMake, DMake or GNU Make. + See the section on the L parameter for details. + + ExtUtils::MakeMaker (EUMM) is object oriented. Each directory below the current + directory that contains a Makefile.PL is treated as a separate + object. This makes it possible to write an unlimited number of + Makefiles with a single invocation of WriteMakefile(). + + All inputs to WriteMakefile are Unicode characters, not just octets. EUMM + seeks to handle all of these correctly. It is currently still not possible + to portably use Unicode characters in module names, because this requires + Perl to handle Unicode filenames, which is not yet the case on Windows. + + =head2 How To Write A Makefile.PL + + See L. + + The long answer is the rest of the manpage :-) + + =head2 Default Makefile Behaviour + + The generated Makefile enables the user of the extension to invoke + + perl Makefile.PL # optionally "perl Makefile.PL verbose" + make + make test # optionally set TEST_VERBOSE=1 + make install # See below + + The Makefile to be produced may be altered by adding arguments of the + form C. E.g. + + perl Makefile.PL INSTALL_BASE=~ + + Other interesting targets in the generated Makefile are + + make config # to check if the Makefile is up-to-date + make clean # delete local temp files (Makefile gets renamed) + make realclean # delete derived files (including ./blib) + make ci # check in all the files in the MANIFEST file + make dist # see below the Distribution Support section + + =head2 make test + + MakeMaker checks for the existence of a file named F in the + current directory, and if it exists it executes the script with the + proper set of perl C<-I> options. + + MakeMaker also checks for any files matching glob("t/*.t"). It will + execute all matching files in alphabetical order via the + L module with the C<-I> switches set correctly. + + If you'd like to see the raw output of your tests, set the + C variable to true. + + make test TEST_VERBOSE=1 + + If you want to run particular test files, set the C variable. + It is possible to use globbing with this mechanism. + + make test TEST_FILES='t/foobar.t t/dagobah*.t' + + Windows users who are using C should note that due to a bug in C, + when specifying C you must use back-slashes instead of forward-slashes. + + nmake test TEST_FILES='t\foobar.t t\dagobah*.t' + + =head2 make testdb + + A useful variation of the above is the target C. It runs the + test under the Perl debugger (see L). If the file + F exists in the current directory, it is used for the test. + + If you want to debug some other testfile, set the C variable + thusly: + + make testdb TEST_FILE=t/mytest.t + + By default the debugger is called using C<-d> option to perl. If you + want to specify some other option, set the C variable: + + make testdb TESTDB_SW=-Dx + + =head2 make install + + make alone puts all relevant files into directories that are named by + the macros INST_LIB, INST_ARCHLIB, INST_SCRIPT, INST_MAN1DIR and + INST_MAN3DIR. All these default to something below ./blib if you are + I building below the perl source directory. If you I + building below the perl source, INST_LIB and INST_ARCHLIB default to + ../../lib, and INST_SCRIPT is not defined. + + The I target of the generated Makefile copies the files found + below each of the INST_* directories to their INSTALL* + counterparts. Which counterparts are chosen depends on the setting of + INSTALLDIRS according to the following table: + + INSTALLDIRS set to + perl site vendor + + PERLPREFIX SITEPREFIX VENDORPREFIX + INST_ARCHLIB INSTALLARCHLIB INSTALLSITEARCH INSTALLVENDORARCH + INST_LIB INSTALLPRIVLIB INSTALLSITELIB INSTALLVENDORLIB + INST_BIN INSTALLBIN INSTALLSITEBIN INSTALLVENDORBIN + INST_SCRIPT INSTALLSCRIPT INSTALLSITESCRIPT INSTALLVENDORSCRIPT + INST_MAN1DIR INSTALLMAN1DIR INSTALLSITEMAN1DIR INSTALLVENDORMAN1DIR + INST_MAN3DIR INSTALLMAN3DIR INSTALLSITEMAN3DIR INSTALLVENDORMAN3DIR + + The INSTALL... macros in turn default to their %Config + ($Config{installprivlib}, $Config{installarchlib}, etc.) counterparts. + + You can check the values of these variables on your system with + + perl '-V:install.*' + + And to check the sequence in which the library directories are + searched by perl, run + + perl -le 'print join $/, @INC' + + Sometimes older versions of the module you're installing live in other + directories in @INC. Because Perl loads the first version of a module it + finds, not the newest, you might accidentally get one of these older + versions even after installing a brand new version. To delete I (not simply older ones) set the + C variable. + + make install UNINST=1 + + + =head2 INSTALL_BASE + + INSTALL_BASE can be passed into Makefile.PL to change where your + module will be installed. INSTALL_BASE is more like what everyone + else calls "prefix" than PREFIX is. + + To have everything installed in your home directory, do the following. + + # Unix users, INSTALL_BASE=~ works fine + perl Makefile.PL INSTALL_BASE=/path/to/your/home/dir + + Like PREFIX, it sets several INSTALL* attributes at once. Unlike + PREFIX it is easy to predict where the module will end up. The + installation pattern looks like this: + + INSTALLARCHLIB INSTALL_BASE/lib/perl5/$Config{archname} + INSTALLPRIVLIB INSTALL_BASE/lib/perl5 + INSTALLBIN INSTALL_BASE/bin + INSTALLSCRIPT INSTALL_BASE/bin + INSTALLMAN1DIR INSTALL_BASE/man/man1 + INSTALLMAN3DIR INSTALL_BASE/man/man3 + + INSTALL_BASE in MakeMaker and C<--install_base> in Module::Build (as + of 0.28) install to the same location. If you want MakeMaker and + Module::Build to install to the same location simply set INSTALL_BASE + and C<--install_base> to the same location. + + INSTALL_BASE was added in 6.31. + + + =head2 PREFIX and LIB attribute + + PREFIX and LIB can be used to set several INSTALL* attributes in one + go. Here's an example for installing into your home directory. + + # Unix users, PREFIX=~ works fine + perl Makefile.PL PREFIX=/path/to/your/home/dir + + This will install all files in the module under your home directory, + with man pages and libraries going into an appropriate place (usually + ~/man and ~/lib). How the exact location is determined is complicated + and depends on how your Perl was configured. INSTALL_BASE works more + like what other build systems call "prefix" than PREFIX and we + recommend you use that instead. + + Another way to specify many INSTALL directories with a single + parameter is LIB. + + perl Makefile.PL LIB=~/lib + + This will install the module's architecture-independent files into + ~/lib, the architecture-dependent files into ~/lib/$archname. + + Note, that in both cases the tilde expansion is done by MakeMaker, not + by perl by default, nor by make. + + Conflicts between parameters LIB, PREFIX and the various INSTALL* + arguments are resolved so that: + + =over 4 + + =item * + + setting LIB overrides any setting of INSTALLPRIVLIB, INSTALLARCHLIB, + INSTALLSITELIB, INSTALLSITEARCH (and they are not affected by PREFIX); + + =item * + + without LIB, setting PREFIX replaces the initial C<$Config{prefix}> + part of those INSTALL* arguments, even if the latter are explicitly + set (but are set to still start with C<$Config{prefix}>). + + =back + + If the user has superuser privileges, and is not working on AFS or + relatives, then the defaults for INSTALLPRIVLIB, INSTALLARCHLIB, + INSTALLSCRIPT, etc. will be appropriate, and this incantation will be + the best: + + perl Makefile.PL; + make; + make test + make install + + make install by default writes some documentation of what has been + done into the file C<$(INSTALLARCHLIB)/perllocal.pod>. This feature + can be bypassed by calling make pure_install. + + =head2 AFS users + + will have to specify the installation directories as these most + probably have changed since perl itself has been installed. They will + have to do this by calling + + perl Makefile.PL INSTALLSITELIB=/afs/here/today \ + INSTALLSCRIPT=/afs/there/now INSTALLMAN3DIR=/afs/for/manpages + make + + Be careful to repeat this procedure every time you recompile an + extension, unless you are sure the AFS installation directories are + still valid. + + =head2 Static Linking of a new Perl Binary + + An extension that is built with the above steps is ready to use on + systems supporting dynamic loading. On systems that do not support + dynamic loading, any newly created extension has to be linked together + with the available resources. MakeMaker supports the linking process + by creating appropriate targets in the Makefile whenever an extension + is built. You can invoke the corresponding section of the makefile with + + make perl + + That produces a new perl binary in the current directory with all + extensions linked in that can be found in INST_ARCHLIB, SITELIBEXP, + and PERL_ARCHLIB. To do that, MakeMaker writes a new Makefile, on + UNIX, this is called F (may be system dependent). If you + want to force the creation of a new perl, it is recommended that you + delete this F, so the directories are searched through + for linkable libraries again. + + The binary can be installed into the directory where perl normally + resides on your machine with + + make inst_perl + + To produce a perl binary with a different name than C, either say + + perl Makefile.PL MAP_TARGET=myperl + make myperl + make inst_perl + + or say + + perl Makefile.PL + make myperl MAP_TARGET=myperl + make inst_perl MAP_TARGET=myperl + + In any case you will be prompted with the correct invocation of the + C target that installs the new binary into INSTALLBIN. + + make inst_perl by default writes some documentation of what has been + done into the file C<$(INSTALLARCHLIB)/perllocal.pod>. This + can be bypassed by calling make pure_inst_perl. + + Warning: the inst_perl: target will most probably overwrite your + existing perl binary. Use with care! + + Sometimes you might want to build a statically linked perl although + your system supports dynamic loading. In this case you may explicitly + set the linktype with the invocation of the Makefile.PL or make: + + perl Makefile.PL LINKTYPE=static # recommended + + or + + make LINKTYPE=static # works on most systems + + =head2 Determination of Perl Library and Installation Locations + + MakeMaker needs to know, or to guess, where certain things are + located. Especially INST_LIB and INST_ARCHLIB (where to put the files + during the make(1) run), PERL_LIB and PERL_ARCHLIB (where to read + existing modules from), and PERL_INC (header files and C). + + Extensions may be built either using the contents of the perl source + directory tree or from the installed perl library. The recommended way + is to build extensions after you have run 'make install' on perl + itself. You can do that in any directory on your hard disk that is not + below the perl source tree. The support for extensions below the ext + directory of the perl distribution is only good for the standard + extensions that come with perl. + + If an extension is being built below the C directory of the perl + source then MakeMaker will set PERL_SRC automatically (e.g., + C<../..>). If PERL_SRC is defined and the extension is recognized as + a standard extension, then other variables default to the following: + + PERL_INC = PERL_SRC + PERL_LIB = PERL_SRC/lib + PERL_ARCHLIB = PERL_SRC/lib + INST_LIB = PERL_LIB + INST_ARCHLIB = PERL_ARCHLIB + + If an extension is being built away from the perl source then MakeMaker + will leave PERL_SRC undefined and default to using the installed copy + of the perl library. The other variables default to the following: + + PERL_INC = $archlibexp/CORE + PERL_LIB = $privlibexp + PERL_ARCHLIB = $archlibexp + INST_LIB = ./blib/lib + INST_ARCHLIB = ./blib/arch + + If perl has not yet been installed then PERL_SRC can be defined on the + command line as shown in the previous section. + + + =head2 Which architecture dependent directory? + + If you don't want to keep the defaults for the INSTALL* macros, + MakeMaker helps you to minimize the typing needed: the usual + relationship between INSTALLPRIVLIB and INSTALLARCHLIB is determined + by Configure at perl compilation time. MakeMaker supports the user who + sets INSTALLPRIVLIB. If INSTALLPRIVLIB is set, but INSTALLARCHLIB not, + then MakeMaker defaults the latter to be the same subdirectory of + INSTALLPRIVLIB as Configure decided for the counterparts in %Config, + otherwise it defaults to INSTALLPRIVLIB. The same relationship holds + for INSTALLSITELIB and INSTALLSITEARCH. + + MakeMaker gives you much more freedom than needed to configure + internal variables and get different results. It is worth mentioning + that make(1) also lets you configure most of the variables that are + used in the Makefile. But in the majority of situations this will not + be necessary, and should only be done if the author of a package + recommends it (or you know what you're doing). + + =head2 Using Attributes and Parameters + + The following attributes may be specified as arguments to WriteMakefile() + or as NAME=VALUE pairs on the command line. Attributes that became + available with later versions of MakeMaker are indicated. + + In order to maintain portability of attributes with older versions of + MakeMaker you may want to use L with your C. + + =over 2 + + =item ABSTRACT + + One line description of the module. Will be included in PPD file. + + =item ABSTRACT_FROM + + Name of the file that contains the package description. MakeMaker looks + for a line in the POD matching /^($package\s-\s)(.*)/. This is typically + the first line in the "=head1 NAME" section. $2 becomes the abstract. + + =item AUTHOR + + Array of strings containing name (and email address) of package author(s). + Is used in CPAN Meta files (META.yml or META.json) and PPD + (Perl Package Description) files for PPM (Perl Package Manager). + + =item BINARY_LOCATION + + Used when creating PPD files for binary packages. It can be set to a + full or relative path or URL to the binary archive for a particular + architecture. For example: + + perl Makefile.PL BINARY_LOCATION=x86/Agent.tar.gz + + builds a PPD package that references a binary of the C package, + located in the C directory relative to the PPD itself. + + =item BUILD_REQUIRES + + Available in version 6.5503 and above. + + A hash of modules that are needed to build your module but not run it. + + This will go into the C field of your F and the C of the C field of your F. + + Defaults to C<<< { "ExtUtils::MakeMaker" => 0 } >>> if this attribute is not specified. + + The format is the same as PREREQ_PM. + + =item C + + Ref to array of *.c file names. Initialised from a directory scan + and the values portion of the XS attribute hash. This is not + currently used by MakeMaker but may be handy in Makefile.PLs. + + =item CCFLAGS + + String that will be included in the compiler call command line between + the arguments INC and OPTIMIZE. + + =item CONFIG + + Arrayref. E.g. [qw(archname manext)] defines ARCHNAME & MANEXT from + config.sh. MakeMaker will add to CONFIG the following values anyway: + ar + cc + cccdlflags + ccdlflags + dlext + dlsrc + ld + lddlflags + ldflags + libc + lib_ext + obj_ext + ranlib + sitelibexp + sitearchexp + so + + =item CONFIGURE + + CODE reference. The subroutine should return a hash reference. The + hash may contain further attributes, e.g. {LIBS =E ...}, that have to + be determined by some evaluation method. + + =item CONFIGURE_REQUIRES + + Available in version 6.52 and above. + + A hash of modules that are required to run Makefile.PL itself, but not + to run your distribution. + + This will go into the C field of your F and the C of the C field of your F. + + Defaults to C<<< { "ExtUtils::MakeMaker" => 0 } >>> if this attribute is not specified. + + The format is the same as PREREQ_PM. + + =item DEFINE + + Something like C<"-DHAVE_UNISTD_H"> + + =item DESTDIR + + This is the root directory into which the code will be installed. It + I. For example, if your code + would normally go into F you could set DESTDIR=~/tmp/ + and installation would go into F<~/tmp/usr/local/lib/perl>. + + This is primarily of use for people who repackage Perl modules. + + NOTE: Due to the nature of make, it is important that you put the trailing + slash on your DESTDIR. F<~/tmp/> not F<~/tmp>. + + =item DIR + + Ref to array of subdirectories containing Makefile.PLs e.g. ['sdbm'] + in ext/SDBM_File + + =item DISTNAME + + A safe filename for the package. + + Defaults to NAME below but with :: replaced with -. + + For example, Foo::Bar becomes Foo-Bar. + + =item DISTVNAME + + Your name for distributing the package with the version number + included. This is used by 'make dist' to name the resulting archive + file. + + Defaults to DISTNAME-VERSION. + + For example, version 1.04 of Foo::Bar becomes Foo-Bar-1.04. + + On some OS's where . has special meaning VERSION_SYM may be used in + place of VERSION. + + =item DLEXT + + Specifies the extension of the module's loadable object. For example: + + DLEXT => 'unusual_ext', # Default value is $Config{so} + + NOTE: When using this option to alter the extension of a module's + loadable object, it is also necessary that the module's pm file + specifies the same change: + + local $DynaLoader::dl_dlext = 'unusual_ext'; + + =item DL_FUNCS + + Hashref of symbol names for routines to be made available as universal + symbols. Each key/value pair consists of the package name and an + array of routine names in that package. Used only under AIX, OS/2, + VMS and Win32 at present. The routine names supplied will be expanded + in the same way as XSUB names are expanded by the XS() macro. + Defaults to + + {"$(NAME)" => ["boot_$(NAME)" ] } + + e.g. + + {"RPC" => [qw( boot_rpcb rpcb_gettime getnetconfigent )], + "NetconfigPtr" => [ 'DESTROY'] } + + Please see the L documentation for more information + about the DL_FUNCS, DL_VARS and FUNCLIST attributes. + + =item DL_VARS + + Array of symbol names for variables to be made available as universal symbols. + Used only under AIX, OS/2, VMS and Win32 at present. Defaults to []. + (e.g. [ qw(Foo_version Foo_numstreams Foo_tree ) ]) + + =item EXCLUDE_EXT + + Array of extension names to exclude when doing a static build. This + is ignored if INCLUDE_EXT is present. Consult INCLUDE_EXT for more + details. (e.g. [ qw( Socket POSIX ) ] ) + + This attribute may be most useful when specified as a string on the + command line: perl Makefile.PL EXCLUDE_EXT='Socket Safe' + + =item EXE_FILES + + Ref to array of executable files. The files will be copied to the + INST_SCRIPT directory. Make realclean will delete them from there + again. + + If your executables start with something like #!perl or + #!/usr/bin/perl MakeMaker will change this to the path of the perl + 'Makefile.PL' was invoked with so the programs will be sure to run + properly even if perl is not in /usr/bin/perl. + + =item FIRST_MAKEFILE + + The name of the Makefile to be produced. This is used for the second + Makefile that will be produced for the MAP_TARGET. + + Defaults to 'Makefile' or 'Descrip.MMS' on VMS. + + (Note: we couldn't use MAKEFILE because dmake uses this for something + else). + + =item FULLPERL + + Perl binary able to run this extension, load XS modules, etc... + + =item FULLPERLRUN + + Like PERLRUN, except it uses FULLPERL. + + =item FULLPERLRUNINST + + Like PERLRUNINST, except it uses FULLPERL. + + =item FUNCLIST + + This provides an alternate means to specify function names to be + exported from the extension. Its value is a reference to an + array of function names to be exported by the extension. These + names are passed through unaltered to the linker options file. + + =item H + + Ref to array of *.h file names. Similar to C. + + =item IMPORTS + + This attribute is used to specify names to be imported into the + extension. Takes a hash ref. + + It is only used on OS/2 and Win32. + + =item INC + + Include file dirs eg: C<"-I/usr/5include -I/path/to/inc"> + + =item INCLUDE_EXT + + Array of extension names to be included when doing a static build. + MakeMaker will normally build with all of the installed extensions when + doing a static build, and that is usually the desired behavior. If + INCLUDE_EXT is present then MakeMaker will build only with those extensions + which are explicitly mentioned. (e.g. [ qw( Socket POSIX ) ]) + + It is not necessary to mention DynaLoader or the current extension when + filling in INCLUDE_EXT. If the INCLUDE_EXT is mentioned but is empty then + only DynaLoader and the current extension will be included in the build. + + This attribute may be most useful when specified as a string on the + command line: perl Makefile.PL INCLUDE_EXT='POSIX Socket Devel::Peek' + + =item INSTALLARCHLIB + + Used by 'make install', which copies files from INST_ARCHLIB to this + directory if INSTALLDIRS is set to perl. + + =item INSTALLBIN + + Directory to install binary files (e.g. tkperl) into if + INSTALLDIRS=perl. + + =item INSTALLDIRS + + Determines which of the sets of installation directories to choose: + perl, site or vendor. Defaults to site. + + =item INSTALLMAN1DIR + + =item INSTALLMAN3DIR + + These directories get the man pages at 'make install' time if + INSTALLDIRS=perl. Defaults to $Config{installman*dir}. + + If set to 'none', no man pages will be installed. + + =item INSTALLPRIVLIB + + Used by 'make install', which copies files from INST_LIB to this + directory if INSTALLDIRS is set to perl. + + Defaults to $Config{installprivlib}. + + =item INSTALLSCRIPT + + Used by 'make install' which copies files from INST_SCRIPT to this + directory if INSTALLDIRS=perl. + + =item INSTALLSITEARCH + + Used by 'make install', which copies files from INST_ARCHLIB to this + directory if INSTALLDIRS is set to site (default). + + =item INSTALLSITEBIN + + Used by 'make install', which copies files from INST_BIN to this + directory if INSTALLDIRS is set to site (default). + + =item INSTALLSITELIB + + Used by 'make install', which copies files from INST_LIB to this + directory if INSTALLDIRS is set to site (default). + + =item INSTALLSITEMAN1DIR + + =item INSTALLSITEMAN3DIR + + These directories get the man pages at 'make install' time if + INSTALLDIRS=site (default). Defaults to + $(SITEPREFIX)/man/man$(MAN*EXT). + + If set to 'none', no man pages will be installed. + + =item INSTALLSITESCRIPT + + Used by 'make install' which copies files from INST_SCRIPT to this + directory if INSTALLDIRS is set to site (default). + + =item INSTALLVENDORARCH + + Used by 'make install', which copies files from INST_ARCHLIB to this + directory if INSTALLDIRS is set to vendor. + + =item INSTALLVENDORBIN + + Used by 'make install', which copies files from INST_BIN to this + directory if INSTALLDIRS is set to vendor. + + =item INSTALLVENDORLIB + + Used by 'make install', which copies files from INST_LIB to this + directory if INSTALLDIRS is set to vendor. + + =item INSTALLVENDORMAN1DIR + + =item INSTALLVENDORMAN3DIR + + These directories get the man pages at 'make install' time if + INSTALLDIRS=vendor. Defaults to $(VENDORPREFIX)/man/man$(MAN*EXT). + + If set to 'none', no man pages will be installed. + + =item INSTALLVENDORSCRIPT + + Used by 'make install' which copies files from INST_SCRIPT to this + directory if INSTALLDIRS is set to vendor. + + =item INST_ARCHLIB + + Same as INST_LIB for architecture dependent files. + + =item INST_BIN + + Directory to put real binary files during 'make'. These will be copied + to INSTALLBIN during 'make install' + + =item INST_LIB + + Directory where we put library files of this extension while building + it. + + =item INST_MAN1DIR + + Directory to hold the man pages at 'make' time + + =item INST_MAN3DIR + + Directory to hold the man pages at 'make' time + + =item INST_SCRIPT + + Directory where executable files should be installed during + 'make'. Defaults to "./blib/script", just to have a dummy location during + testing. make install will copy the files in INST_SCRIPT to + INSTALLSCRIPT. + + =item LD + + Program to be used to link libraries for dynamic loading. + + Defaults to $Config{ld}. + + =item LDDLFLAGS + + Any special flags that might need to be passed to ld to create a + shared library suitable for dynamic loading. It is up to the makefile + to use it. (See L) + + Defaults to $Config{lddlflags}. + + =item LDFROM + + Defaults to "$(OBJECT)" and is used in the ld command to specify + what files to link/load from (also see dynamic_lib below for how to + specify ld flags) + + =item LIB + + LIB should only be set at C time but is allowed as a + MakeMaker argument. It has the effect of setting both INSTALLPRIVLIB + and INSTALLSITELIB to that value regardless any explicit setting of + those arguments (or of PREFIX). INSTALLARCHLIB and INSTALLSITEARCH + are set to the corresponding architecture subdirectory. + + =item LIBPERL_A + + The filename of the perllibrary that will be used together with this + extension. Defaults to libperl.a. + + =item LIBS + + An anonymous array of alternative library + specifications to be searched for (in order) until + at least one library is found. E.g. + + 'LIBS' => ["-lgdbm", "-ldbm -lfoo", "-L/path -ldbm.nfs"] + + Mind, that any element of the array + contains a complete set of arguments for the ld + command. So do not specify + + 'LIBS' => ["-ltcl", "-ltk", "-lX11"] + + See ODBM_File/Makefile.PL for an example, where an array is needed. If + you specify a scalar as in + + 'LIBS' => "-ltcl -ltk -lX11" + + MakeMaker will turn it into an array with one element. + + =item LICENSE + + Available in version 6.31 and above. + + The licensing terms of your distribution. Generally it's "perl_5" for the + same license as Perl itself. + + See L for the list of options. + + Defaults to "unknown". + + =item LINKTYPE + + 'static' or 'dynamic' (default unless usedl=undef in + config.sh). Should only be used to force static linking (also see + linkext below). + + =item MAGICXS + + When this is set to C<1>, C will be automagically derived from + C. + + =item MAKE + + Variant of make you intend to run the generated Makefile with. This + parameter lets Makefile.PL know what make quirks to account for when + generating the Makefile. + + MakeMaker also honors the MAKE environment variable. This parameter + takes precedence. + + Currently the only significant values are 'dmake' and 'nmake' for Windows + users, instructing MakeMaker to generate a Makefile in the flavour of + DMake ("Dennis Vadura's Make") or Microsoft NMake respectively. + + Defaults to $Config{make}, which may go looking for a Make program + in your environment. + + How are you supposed to know what flavour of Make a Makefile has + been generated for if you didn't specify a value explicitly? Search + the generated Makefile for the definition of the MAKE variable, + which is used to recursively invoke the Make utility. That will tell + you what Make you're supposed to invoke the Makefile with. + + =item MAKEAPERL + + Boolean which tells MakeMaker that it should include the rules to + make a perl. This is handled automatically as a switch by + MakeMaker. The user normally does not need it. + + =item MAKEFILE_OLD + + When 'make clean' or similar is run, the $(FIRST_MAKEFILE) will be + backed up at this location. + + Defaults to $(FIRST_MAKEFILE).old or $(FIRST_MAKEFILE)_old on VMS. + + =item MAN1PODS + + Hashref of pod-containing files. MakeMaker will default this to all + EXE_FILES files that include POD directives. The files listed + here will be converted to man pages and installed as was requested + at Configure time. + + This hash should map POD files (or scripts containing POD) to the + man file names under the C directory, as in the following + example: + + MAN1PODS => { + 'doc/command.pod' => 'blib/man1/command.1', + 'scripts/script.pl' => 'blib/man1/script.1', + } + + =item MAN3PODS + + Hashref that assigns to *.pm and *.pod files the files into which the + manpages are to be written. MakeMaker parses all *.pod and *.pm files + for POD directives. Files that contain POD will be the default keys of + the MAN3PODS hashref. These will then be converted to man pages during + C and will be installed during C. + + Example similar to MAN1PODS. + + =item MAP_TARGET + + If it is intended that a new perl binary be produced, this variable + may hold a name for that binary. Defaults to perl + + =item META_ADD + + =item META_MERGE + + Available in version 6.46 and above. + + A hashref of items to add to the CPAN Meta file (F or + F). + + They differ in how they behave if they have the same key as the + default metadata. META_ADD will override the default value with its + own. META_MERGE will merge its value with the default. + + Unless you want to override the defaults, prefer META_MERGE so as to + get the advantage of any future defaults. + + Where prereqs are concerned, if META_MERGE is used, prerequisites are merged + with their counterpart C argument + (PREREQ_PM is merged into {prereqs}{runtime}{requires}, + BUILD_REQUIRES into C<{prereqs}{build}{requires}>, + CONFIGURE_REQUIRES into C<{prereqs}{configure}{requires}>, + and TEST_REQUIRES into C<{prereqs}{test}{requires})>. + When prereqs are specified with META_ADD, the only prerequisites added to the + file come from the metadata, not C arguments. + + Note that these configuration options are only used for generating F + and F -- they are NOT used for F and F. + Therefore data in these fields should NOT be used for dynamic (user-side) + configuration. + + By default CPAN Meta specification C<1.4> is used. In order to use + CPAN Meta specification C<2.0>, indicate with C the version + you want to use. + + META_MERGE => { + + "meta-spec" => { version => 2 }, + + resources => { + + repository => { + type => 'git', + url => 'git://github.com/Perl-Toolchain-Gang/ExtUtils-MakeMaker.git', + web => 'https://github.com/Perl-Toolchain-Gang/ExtUtils-MakeMaker', + }, + + }, + + }, + + =item MIN_PERL_VERSION + + Available in version 6.48 and above. + + The minimum required version of Perl for this distribution. + + Either the 5.006001 or the 5.6.1 format is acceptable. + + =item MYEXTLIB + + If the extension links to a library that it builds, set this to the + name of the library (see SDBM_File) + + =item NAME + + The package representing the distribution. For example, C + or C. It will be used to derive information about + the distribution such as the L, installation locations + within the Perl library and where XS files will be looked for by + default (see L). + + C I be a valid Perl package name and it I have an + associated C<.pm> file. For example, C is a valid C + and there must exist F. Any XS code should be in + F unless stated otherwise. + + Your distribution B have a C. + + =item NEEDS_LINKING + + MakeMaker will figure out if an extension contains linkable code + anywhere down the directory tree, and will set this variable + accordingly, but you can speed it up a very little bit if you define + this boolean variable yourself. + + =item NOECHO + + Command so make does not print the literal commands it's running. + + By setting it to an empty string you can generate a Makefile that + prints all commands. Mainly used in debugging MakeMaker itself. + + Defaults to C<@>. + + =item NORECURS + + Boolean. Attribute to inhibit descending into subdirectories. + + =item NO_META + + When true, suppresses the generation and addition to the MANIFEST of + the META.yml and META.json module meta-data files during 'make distdir'. + + Defaults to false. + + =item NO_MYMETA + + When true, suppresses the generation of MYMETA.yml and MYMETA.json module + meta-data files during 'perl Makefile.PL'. + + Defaults to false. + + =item NO_PACKLIST + + When true, suppresses the writing of C files for installs. + + Defaults to false. + + =item NO_PERLLOCAL + + When true, suppresses the appending of installations to C. + + Defaults to false. + + =item NO_VC + + In general, any generated Makefile checks for the current version of + MakeMaker and the version the Makefile was built under. If NO_VC is + set, the version check is neglected. Do not write this into your + Makefile.PL, use it interactively instead. + + =item OBJECT + + List of object files, defaults to '$(BASEEXT)$(OBJ_EXT)', but can be a long + string or an array containing all object files, e.g. "tkpBind.o + tkpButton.o tkpCanvas.o" or ["tkpBind.o", "tkpButton.o", "tkpCanvas.o"] + + (Where BASEEXT is the last component of NAME, and OBJ_EXT is $Config{obj_ext}.) + + =item OPTIMIZE + + Defaults to C<-O>. Set it to C<-g> to turn debugging on. The flag is + passed to subdirectory makes. + + =item PERL + + Perl binary for tasks that can be done by miniperl. If it contains + spaces or other shell metacharacters, it needs to be quoted in a way + that protects them, since this value is intended to be inserted in a + shell command line in the Makefile. E.g.: + + # Perl executable lives in "C:/Program Files/Perl/bin" + # Normally you don't need to set this yourself! + $ perl Makefile.PL PERL='"C:/Program Files/Perl/bin/perl.exe" -w' + + =item PERL_CORE + + Set only when MakeMaker is building the extensions of the Perl core + distribution. + + =item PERLMAINCC + + The call to the program that is able to compile perlmain.c. Defaults + to $(CC). + + =item PERL_ARCHLIB + + Same as for PERL_LIB, but for architecture dependent files. + + Used only when MakeMaker is building the extensions of the Perl core + distribution (because normally $(PERL_ARCHLIB) is automatically in @INC, + and adding it would get in the way of PERL5LIB). + + =item PERL_LIB + + Directory containing the Perl library to use. + + Used only when MakeMaker is building the extensions of the Perl core + distribution (because normally $(PERL_LIB) is automatically in @INC, + and adding it would get in the way of PERL5LIB). + + =item PERL_MALLOC_OK + + defaults to 0. Should be set to TRUE if the extension can work with + the memory allocation routines substituted by the Perl malloc() subsystem. + This should be applicable to most extensions with exceptions of those + + =over 4 + + =item * + + with bugs in memory allocations which are caught by Perl's malloc(); + + =item * + + which interact with the memory allocator in other ways than via + malloc(), realloc(), free(), calloc(), sbrk() and brk(); + + =item * + + which rely on special alignment which is not provided by Perl's malloc(). + + =back + + B Neglecting to set this flag in I of the loaded extension + nullifies many advantages of Perl's malloc(), such as better usage of + system resources, error detection, memory usage reporting, catchable failure + of memory allocations, etc. + + =item PERLPREFIX + + Directory under which core modules are to be installed. + + Defaults to $Config{installprefixexp}, falling back to + $Config{installprefix}, $Config{prefixexp} or $Config{prefix} should + $Config{installprefixexp} not exist. + + Overridden by PREFIX. + + =item PERLRUN + + Use this instead of $(PERL) when you wish to run perl. It will set up + extra necessary flags for you. + + =item PERLRUNINST + + Use this instead of $(PERL) when you wish to run perl to work with + modules. It will add things like -I$(INST_ARCH) and other necessary + flags so perl can see the modules you're about to install. + + =item PERL_SRC + + Directory containing the Perl source code (use of this should be + avoided, it may be undefined) + + =item PERM_DIR + + Desired permission for directories. Defaults to C<755>. + + =item PERM_RW + + Desired permission for read/writable files. Defaults to C<644>. + + =item PERM_RWX + + Desired permission for executable files. Defaults to C<755>. + + =item PL_FILES + + MakeMaker can run programs to generate files for you at build time. + By default any file named *.PL (except Makefile.PL and Build.PL) in + the top level directory will be assumed to be a Perl program and run + passing its own basename in as an argument. This basename is actually a build + target, and there is an intention, but not a requirement, that the *.PL file + make the file passed to to as an argument. For example... + + perl foo.PL foo + + This behavior can be overridden by supplying your own set of files to + search. PL_FILES accepts a hash ref, the key being the file to run + and the value is passed in as the first argument when the PL file is run. + + PL_FILES => {'bin/foobar.PL' => 'bin/foobar'} + + PL_FILES => {'foo.PL' => 'foo.c'} + + Would run bin/foobar.PL like this: + + perl bin/foobar.PL bin/foobar + + If multiple files from one program are desired an array ref can be used. + + PL_FILES => {'bin/foobar.PL' => [qw(bin/foobar1 bin/foobar2)]} + + In this case the program will be run multiple times using each target file. + + perl bin/foobar.PL bin/foobar1 + perl bin/foobar.PL bin/foobar2 + + PL files are normally run B pm_to_blib and include INST_LIB and + INST_ARCH in their C<@INC>, so the just built modules can be + accessed... unless the PL file is making a module (or anything else in + PM) in which case it is run B pm_to_blib and does not include + INST_LIB and INST_ARCH in its C<@INC>. This apparently odd behavior + is there for backwards compatibility (and it's somewhat DWIM). The argument + passed to the .PL is set up as a target to build in the Makefile. In other + sections such as C you can specify a dependency on the + filename/argument that the .PL is supposed (or will have, now that that is + is a dependency) to generate. Note the file to be generated will still be + generated and the .PL will still run even without an explicit dependency created + by you, since the C target still depends on running all eligible to run.PL + files. + + =item PM + + Hashref of .pm files and *.pl files to be installed. e.g. + + {'name_of_file.pm' => '$(INST_LIB)/install_as.pm'} + + By default this will include *.pm and *.pl and the files found in + the PMLIBDIRS directories. Defining PM in the + Makefile.PL will override PMLIBDIRS. + + =item PMLIBDIRS + + Ref to array of subdirectories containing library files. Defaults to + [ 'lib', $(BASEEXT) ]. The directories will be scanned and I files + they contain will be installed in the corresponding location in the + library. A libscan() method can be used to alter the behaviour. + Defining PM in the Makefile.PL will override PMLIBDIRS. + + (Where BASEEXT is the last component of NAME.) + + =item PM_FILTER + + A filter program, in the traditional Unix sense (input from stdin, output + to stdout) that is passed on each .pm file during the build (in the + pm_to_blib() phase). It is empty by default, meaning no filtering is done. + You could use: + + PM_FILTER => 'perl -ne "print unless /^\\#/"', + + to remove all the leading comments on the fly during the build. In order + to be as portable as possible, please consider using a Perl one-liner + rather than Unix (or other) utilities, as above. The # is escaped for + the Makefile, since what is going to be generated will then be: + + PM_FILTER = perl -ne "print unless /^\#/" + + Without the \ before the #, we'd have the start of a Makefile comment, + and the macro would be incorrectly defined. + + You will almost certainly be better off using the C system, + instead. See above, or the L entry. + + =item POLLUTE + + Release 5.005 grandfathered old global symbol names by providing preprocessor + macros for extension source compatibility. As of release 5.6, these + preprocessor definitions are not available by default. The POLLUTE flag + specifies that the old names should still be defined: + + perl Makefile.PL POLLUTE=1 + + Please inform the module author if this is necessary to successfully install + a module under 5.6 or later. + + =item PPM_INSTALL_EXEC + + Name of the executable used to run C below. (e.g. perl) + + =item PPM_INSTALL_SCRIPT + + Name of the script that gets executed by the Perl Package Manager after + the installation of a package. + + =item PPM_UNINSTALL_EXEC + + Name of the executable used to run C below. (e.g. perl) + + =item PPM_UNINSTALL_SCRIPT + + Name of the script that gets executed by the Perl Package Manager before + the removal of a package. + + =item PREFIX + + This overrides all the default install locations. Man pages, + libraries, scripts, etc... MakeMaker will try to make an educated + guess about where to place things under the new PREFIX based on your + Config defaults. Failing that, it will fall back to a structure + which should be sensible for your platform. + + If you specify LIB or any INSTALL* variables they will not be affected + by the PREFIX. + + =item PREREQ_FATAL + + Bool. If this parameter is true, failing to have the required modules + (or the right versions thereof) will be fatal. C + will C instead of simply informing the user of the missing dependencies. + + It is I rare to have to use C. Its use by module + authors is I and should never be used lightly. + + For dependencies that are required in order to run C, + see C. + + Module installation tools have ways of resolving unmet dependencies but + to do that they need a F. Using C breaks this. + That's bad. + + Assuming you have good test coverage, your tests should fail with + missing dependencies informing the user more strongly that something + is wrong. You can write a F test which will simply + check that your code compiles and stop "make test" prematurely if it + doesn't. See L for more details. + + + =item PREREQ_PM + + A hash of modules that are needed to run your module. The keys are + the module names ie. Test::More, and the minimum version is the + value. If the required version number is 0 any version will do. + The versions given may be a Perl v-string (see L) or a range + (see L). + + This will go into the C field of your F and the + C of the C field of your F. + + PREREQ_PM => { + # Require Test::More at least 0.47 + "Test::More" => "0.47", + + # Require any version of Acme::Buffy + "Acme::Buffy" => 0, + } + + =item PREREQ_PRINT + + Bool. If this parameter is true, the prerequisites will be printed to + stdout and MakeMaker will exit. The output format is an evalable hash + ref. + + $PREREQ_PM = { + 'A::B' => Vers1, + 'C::D' => Vers2, + ... + }; + + If a distribution defines a minimal required perl version, this is + added to the output as an additional line of the form: + + $MIN_PERL_VERSION = '5.008001'; + + If BUILD_REQUIRES is not empty, it will be dumped as $BUILD_REQUIRES hashref. + + =item PRINT_PREREQ + + RedHatism for C. The output format is different, though: + + perl(A::B)>=Vers1 perl(C::D)>=Vers2 ... + + A minimal required perl version, if present, will look like this: + + perl(perl)>=5.008001 + + =item SITEPREFIX + + Like PERLPREFIX, but only for the site install locations. + + Defaults to $Config{siteprefixexp}. Perls prior to 5.6.0 didn't have + an explicit siteprefix in the Config. In those cases + $Config{installprefix} will be used. + + Overridable by PREFIX + + =item SIGN + + When true, perform the generation and addition to the MANIFEST of the + SIGNATURE file in the distdir during 'make distdir', via 'cpansign + -s'. + + Note that you need to install the Module::Signature module to + perform this operation. + + Defaults to false. + + =item SKIP + + Arrayref. E.g. [qw(name1 name2)] skip (do not write) sections of the + Makefile. Caution! Do not use the SKIP attribute for the negligible + speedup. It may seriously damage the resulting Makefile. Only use it + if you really need it. + + =item TEST_REQUIRES + + Available in version 6.64 and above. + + A hash of modules that are needed to test your module but not run or + build it. + + This will go into the C field of your F and the C of the C field of your F. + + The format is the same as PREREQ_PM. + + =item TYPEMAPS + + Ref to array of typemap file names. Use this when the typemaps are + in some directory other than the current directory or when they are + not named B. The last typemap in the list takes + precedence. A typemap in the current directory has highest + precedence, even if it isn't listed in TYPEMAPS. The default system + typemap has lowest precedence. + + =item VENDORPREFIX + + Like PERLPREFIX, but only for the vendor install locations. + + Defaults to $Config{vendorprefixexp}. + + Overridable by PREFIX + + =item VERBINST + + If true, make install will be verbose + + =item VERSION + + Your version number for distributing the package. This defaults to + 0.1. + + =item VERSION_FROM + + Instead of specifying the VERSION in the Makefile.PL you can let + MakeMaker parse a file to determine the version number. The parsing + routine requires that the file named by VERSION_FROM contains one + single line to compute the version number. The first line in the file + that contains something like a $VERSION assignment or C will be used. The following lines will be parsed o.k.: + + # Good + package Foo::Bar 1.23; # 1.23 + $VERSION = '1.00'; # 1.00 + *VERSION = \'1.01'; # 1.01 + ($VERSION) = q$Revision$ =~ /(\d+)/g; # The digits in $Revision$ + $FOO::VERSION = '1.10'; # 1.10 + *FOO::VERSION = \'1.11'; # 1.11 + + but these will fail: + + # Bad + my $VERSION = '1.01'; + local $VERSION = '1.02'; + local $FOO::VERSION = '1.30'; + + (Putting C or C on the preceding line will work o.k.) + + "Version strings" are incompatible and should not be used. + + # Bad + $VERSION = 1.2.3; + $VERSION = v1.2.3; + + L objects are fine. As of MakeMaker 6.35 version.pm will be + automatically loaded, but you must declare the dependency on version.pm. + For compatibility with older MakeMaker you should load on the same line + as $VERSION is declared. + + # All on one line + use version; our $VERSION = qv(1.2.3); + + The file named in VERSION_FROM is not added as a dependency to + Makefile. This is not really correct, but it would be a major pain + during development to have to rewrite the Makefile for any smallish + change in that file. If you want to make sure that the Makefile + contains the correct VERSION macro after any change of the file, you + would have to do something like + + depend => { Makefile => '$(VERSION_FROM)' } + + See attribute C below. + + =item VERSION_SYM + + A sanitized VERSION with . replaced by _. For places where . has + special meaning (some filesystems, RCS labels, etc...) + + =item XS + + Hashref of .xs files. MakeMaker will default this. e.g. + + {'name_of_file.xs' => 'name_of_file.c'} + + The .c files will automatically be included in the list of files + deleted by a make clean. + + =item XSBUILD + + Hashref with options controlling the operation of C: + + { + xs => { + all => { + # options applying to all .xs files for this distribution + }, + 'lib/Class/Name/File' => { # specifically for this file + DEFINE => '-Dfunktastic', # defines for only this file + INC => "-I$funkyliblocation", # include flags for only this file + # OBJECT => 'lib/Class/Name/File$(OBJ_EXT)', # default + LDFROM => "lib/Class/Name/File\$(OBJ_EXT) $otherfile\$(OBJ_EXT)", # what's linked + }, + }, + } + + Note C is the file-extension. More possibilities may arise in the + future. Note that object names are specified without their XS extension. + + C defaults to the same as C. C defaults to, + for C, just the XS filename with the extension replaced with + the compiler-specific object-file extension. + + The distinction between C and C: C is the make + target, so make will try to build it. However, C is what will + actually be linked together to make the shared object or static library + (SO/SL), so if you override it, make sure it includes what you want to + make the final SO/SL, almost certainly including the XS basename with + C<$(OBJ_EXT)> appended. + + =item XSMULTI + + When this is set to C<1>, multiple XS files may be placed under F + next to their corresponding C<*.pm> files (this is essential for compiling + with the correct C values). This feature should be considered + experimental, and details of it may change. + + This feature was inspired by, and small portions of code copied from, + L. Hopefully this feature will render + that module mainly obsolete. + + =item XSOPT + + String of options to pass to xsubpp. This might include C<-C++> or + C<-extern>. Do not include typemaps here; the TYPEMAP parameter exists for + that purpose. + + =item XSPROTOARG + + May be set to C<-protoypes>, C<-noprototypes> or the empty string. The + empty string is equivalent to the xsubpp default, or C<-noprototypes>. + See the xsubpp documentation for details. MakeMaker + defaults to the empty string. + + =item XS_VERSION + + Your version number for the .xs file of this package. This defaults + to the value of the VERSION attribute. + + =back + + =head2 Additional lowercase attributes + + can be used to pass parameters to the methods which implement that + part of the Makefile. Parameters are specified as a hash ref but are + passed to the method as a hash. + + =over 2 + + =item clean + + {FILES => "*.xyz foo"} + + =item depend + + {ANY_TARGET => ANY_DEPENDENCY, ...} + + (ANY_TARGET must not be given a double-colon rule by MakeMaker.) + + =item dist + + {TARFLAGS => 'cvfF', COMPRESS => 'gzip', SUFFIX => '.gz', + SHAR => 'shar -m', DIST_CP => 'ln', ZIP => '/bin/zip', + ZIPFLAGS => '-rl', DIST_DEFAULT => 'private tardist' } + + If you specify COMPRESS, then SUFFIX should also be altered, as it is + needed to tell make the target file of the compression. Setting + DIST_CP to ln can be useful, if you need to preserve the timestamps on + your files. DIST_CP can take the values 'cp', which copies the file, + 'ln', which links the file, and 'best' which copies symbolic links and + links the rest. Default is 'best'. + + =item dynamic_lib + + {ARMAYBE => 'ar', OTHERLDFLAGS => '...', INST_DYNAMIC_DEP => '...'} + + =item linkext + + {LINKTYPE => 'static', 'dynamic' or ''} + + NB: Extensions that have nothing but *.pm files had to say + + {LINKTYPE => ''} + + with Pre-5.0 MakeMakers. Since version 5.00 of MakeMaker such a line + can be deleted safely. MakeMaker recognizes when there's nothing to + be linked. + + =item macro + + {ANY_MACRO => ANY_VALUE, ...} + + =item postamble + + Anything put here will be passed to MY::postamble() if you have one. + + =item realclean + + {FILES => '$(INST_ARCHAUTODIR)/*.xyz'} + + =item test + + Specify the targets for testing. + + {TESTS => 't/*.t'} + + C can be used to include all directories + recursively under C that contain C<.t> files. It will be ignored if + you provide your own C attribute, defaults to false. + + {RECURSIVE_TEST_FILES=>1} + + =item tool_autosplit + + {MAXLEN => 8} + + =back + + =head2 Overriding MakeMaker Methods + + If you cannot achieve the desired Makefile behaviour by specifying + attributes you may define private subroutines in the Makefile.PL. + Each subroutine returns the text it wishes to have written to + the Makefile. To override a section of the Makefile you can + either say: + + sub MY::c_o { "new literal text" } + + or you can edit the default by saying something like: + + package MY; # so that "SUPER" works right + sub c_o { + my $inherited = shift->SUPER::c_o(@_); + $inherited =~ s/old text/new text/; + $inherited; + } + + If you are running experiments with embedding perl as a library into + other applications, you might find MakeMaker is not sufficient. You'd + better have a look at ExtUtils::Embed which is a collection of utilities + for embedding. + + If you still need a different solution, try to develop another + subroutine that fits your needs and submit the diffs to + C + + For a complete description of all MakeMaker methods see + L. + + Here is a simple example of how to add a new target to the generated + Makefile: + + sub MY::postamble { + return <<'MAKE_FRAG'; + $(MYEXTLIB): sdbm/Makefile + cd sdbm && $(MAKE) all + + MAKE_FRAG + } + + =head2 The End Of Cargo Cult Programming + + WriteMakefile() now does some basic sanity checks on its parameters to + protect against typos and malformatted values. This means some things + which happened to work in the past will now throw warnings and + possibly produce internal errors. + + Some of the most common mistakes: + + =over 2 + + =item C<< MAN3PODS => ' ' >> + + This is commonly used to suppress the creation of man pages. MAN3PODS + takes a hash ref not a string, but the above worked by accident in old + versions of MakeMaker. + + The correct code is C<< MAN3PODS => { } >>. + + =back + + + =head2 Hintsfile support + + MakeMaker.pm uses the architecture-specific information from + Config.pm. In addition it evaluates architecture specific hints files + in a C directory. The hints files are expected to be named + like their counterparts in C, but with an C<.pl> file + name extension (eg. C). They are simply Ced by + MakeMaker within the WriteMakefile() subroutine, and can be used to + execute commands as well as to include special variables. The rules + which hintsfile is chosen are the same as in Configure. + + The hintsfile is eval()ed immediately after the arguments given to + WriteMakefile are stuffed into a hash reference $self but before this + reference becomes blessed. So if you want to do the equivalent to + override or create an attribute you would say something like + + $self->{LIBS} = ['-ldbm -lucb -lc']; + + =head2 Distribution Support + + For authors of extensions MakeMaker provides several Makefile + targets. Most of the support comes from the ExtUtils::Manifest module, + where additional documentation can be found. + + =over 4 + + =item make distcheck + + reports which files are below the build directory but not in the + MANIFEST file and vice versa. (See ExtUtils::Manifest::fullcheck() for + details) + + =item make skipcheck + + reports which files are skipped due to the entries in the + C file (See ExtUtils::Manifest::skipcheck() for + details) + + =item make distclean + + does a realclean first and then the distcheck. Note that this is not + needed to build a new distribution as long as you are sure that the + MANIFEST file is ok. + + =item make veryclean + + does a realclean first and then removes backup files such as C<*~>, + C<*.bak>, C<*.old> and C<*.orig> + + =item make manifest + + rewrites the MANIFEST file, adding all remaining files found (See + ExtUtils::Manifest::mkmanifest() for details) + + =item make distdir + + Copies all the files that are in the MANIFEST file to a newly created + directory with the name C<$(DISTNAME)-$(VERSION)>. If that directory + exists, it will be removed first. + + Additionally, it will create META.yml and META.json module meta-data file + in the distdir and add this to the distdir's MANIFEST. You can shut this + behavior off with the NO_META flag. + + =item make disttest + + Makes a distdir first, and runs a C, a make, and + a make test in that directory. + + =item make tardist + + First does a distdir. Then a command $(PREOP) which defaults to a null + command, followed by $(TO_UNIX), which defaults to a null command under + UNIX, and will convert files in distribution directory to UNIX format + otherwise. Next it runs C on that directory into a tarfile and + deletes the directory. Finishes with a command $(POSTOP) which + defaults to a null command. + + =item make dist + + Defaults to $(DIST_DEFAULT) which in turn defaults to tardist. + + =item make uutardist + + Runs a tardist first and uuencodes the tarfile. + + =item make shdist + + First does a distdir. Then a command $(PREOP) which defaults to a null + command. Next it runs C on that directory into a sharfile and + deletes the intermediate directory again. Finishes with a command + $(POSTOP) which defaults to a null command. Note: For shdist to work + properly a C program that can handle directories is mandatory. + + =item make zipdist + + First does a distdir. Then a command $(PREOP) which defaults to a null + command. Runs C<$(ZIP) $(ZIPFLAGS)> on that directory into a + zipfile. Then deletes that directory. Finishes with a command + $(POSTOP) which defaults to a null command. + + =item make ci + + Does a $(CI) and a $(RCS_LABEL) on all files in the MANIFEST file. + + =back + + Customization of the dist targets can be done by specifying a hash + reference to the dist attribute of the WriteMakefile call. The + following parameters are recognized: + + CI ('ci -u') + COMPRESS ('gzip --best') + POSTOP ('@ :') + PREOP ('@ :') + TO_UNIX (depends on the system) + RCS_LABEL ('rcs -q -Nv$(VERSION_SYM):') + SHAR ('shar') + SUFFIX ('.gz') + TAR ('tar') + TARFLAGS ('cvf') + ZIP ('zip') + ZIPFLAGS ('-r') + + An example: + + WriteMakefile( + ...other options... + dist => { + COMPRESS => "bzip2", + SUFFIX => ".bz2" + } + ); + + + =head2 Module Meta-Data (META and MYMETA) + + Long plaguing users of MakeMaker based modules has been the problem of + getting basic information about the module out of the sources + I running the F and doing a bunch of messy + heuristics on the resulting F. Over the years, it has become + standard to keep this information in one or more CPAN Meta files + distributed with each distribution. + + The original format of CPAN Meta files was L and the corresponding + file was called F. In 2010, version 2 of the L + was released, which mandates JSON format for the metadata in order to + overcome certain compatibility issues between YAML serializers and to + avoid breaking older clients unable to handle a new version of the spec. + The L library is now standard for accessing old and new-style + Meta files. + + If L is installed, MakeMaker will automatically generate + F and F files for you and add them to your F as + part of the 'distdir' target (and thus the 'dist' target). This is intended to + seamlessly and rapidly populate CPAN with module meta-data. If you wish to + shut this feature off, set the C C flag to true. + + At the 2008 QA Hackathon in Oslo, Perl module toolchain maintainers agrees + to use the CPAN Meta format to communicate post-configuration requirements + between toolchain components. These files, F and F, + are generated when F generates a F (if L + is installed). Clients like L or L will read this + files to see what prerequisites must be fulfilled before building or testing + the distribution. If you with to shut this feature off, set the C + C flag to true. + + =head2 Disabling an extension + + If some events detected in F imply that there is no way + to create the Module, but this is a normal state of things, then you + can create a F which does nothing, but succeeds on all the + "usual" build targets. To do so, use + + use ExtUtils::MakeMaker qw(WriteEmptyMakefile); + WriteEmptyMakefile(); + + instead of WriteMakefile(). + + This may be useful if other modules expect this module to be I + OK, as opposed to I OK (say, this system-dependent module builds + in a subdirectory of some other distribution, or is listed as a + dependency in a CPAN::Bundle, but the functionality is supported by + different means on the current architecture). + + =head2 Other Handy Functions + + =over 4 + + =item prompt + + my $value = prompt($message); + my $value = prompt($message, $default); + + The C function provides an easy way to request user input + used to write a makefile. It displays the $message as a prompt for + input. If a $default is provided it will be used as a default. The + function returns the $value selected by the user. + + If C detects that it is not running interactively and there + is nothing on STDIN or if the PERL_MM_USE_DEFAULT environment variable + is set to true, the $default will be used without prompting. This + prevents automated processes from blocking on user input. + + If no $default is provided an empty string will be used instead. + + =back + + =head2 Supported versions of Perl + + Please note that while this module works on Perl 5.6, it is no longer + being routinely tested on 5.6 - the earliest Perl version being routinely + tested, and expressly supported, is 5.8.1. However, patches to repair + any breakage on 5.6 are still being accepted. + + =head1 ENVIRONMENT + + =over 4 + + =item PERL_MM_OPT + + Command line options used by Cnew()>, and thus by + C. The string is split as the shell would, and the result + is processed before any actual command line arguments are processed. + + PERL_MM_OPT='CCFLAGS="-Wl,-rpath -Wl,/foo/bar/lib" LIBS="-lwibble -lwobble"' + + =item PERL_MM_USE_DEFAULT + + If set to a true value then MakeMaker's prompt function will + always return the default without waiting for user input. + + =item PERL_CORE + + Same as the PERL_CORE parameter. The parameter overrides this. + + =back + + =head1 SEE ALSO + + L is a pure-Perl alternative to MakeMaker which does + not rely on make or any other external utility. It is easier to + extend to suit your needs. + + L is a wrapper around MakeMaker which adds features + not normally available. + + L and L are both modules to + help you setup your distribution. + + L and L explain CPAN Meta files in detail. + + L makes it easy to install static, sometimes + also referred to as 'shared' files. L helps accessing + the shared files after installation. + + L makes it easy for the module author to create MakeMaker-based + distributions with lots of bells and whistles. + + =head1 AUTHORS + + Andy Dougherty C, Andreas KEnig + C, Tim Bunce C. VMS + support by Charles Bailey C. OS/2 support + by Ilya Zakharevich C. + + Currently maintained by Michael G Schwern C + + Send patches and ideas to C. + + Send bug reports via http://rt.cpan.org/. Please send your + generated Makefile along with your report. + + For more up-to-date information, see L. + + Repository available at L. + + =head1 LICENSE + + This program is free software; you can redistribute it and/or + modify it under the same terms as Perl itself. + + See L + + + =cut +EXTUTILS_MAKEMAKER + +$fatpacked{"ExtUtils/MakeMaker/Config.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MAKEMAKER_CONFIG'; + package ExtUtils::MakeMaker::Config; + + use strict; + + our $VERSION = '7.06'; + $VERSION = eval $VERSION; + + use Config (); + + # Give us an overridable config. + our %Config = %Config::Config; + + sub import { + my $caller = caller; + + no strict 'refs'; ## no critic + *{$caller.'::Config'} = \%Config; + } + + 1; + + + =head1 NAME + + ExtUtils::MakeMaker::Config - Wrapper around Config.pm + + + =head1 SYNOPSIS + + use ExtUtils::MakeMaker::Config; + print $Config{installbin}; # or whatever + + + =head1 DESCRIPTION + + B + + A very thin wrapper around Config.pm so MakeMaker is easier to test. + + =cut +EXTUTILS_MAKEMAKER_CONFIG + +$fatpacked{"ExtUtils/MakeMaker/Locale.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MAKEMAKER_LOCALE'; + package ExtUtils::MakeMaker::Locale; + + use strict; + our $VERSION = "7.06"; + $VERSION = eval $VERSION; + + use base 'Exporter'; + our @EXPORT_OK = qw( + decode_argv env + $ENCODING_LOCALE $ENCODING_LOCALE_FS + $ENCODING_CONSOLE_IN $ENCODING_CONSOLE_OUT + ); + + use Encode (); + use Encode::Alias (); + + our $ENCODING_LOCALE; + our $ENCODING_LOCALE_FS; + our $ENCODING_CONSOLE_IN; + our $ENCODING_CONSOLE_OUT; + + sub DEBUG () { 0 } + + sub _init { + if ($^O eq "MSWin32") { + unless ($ENCODING_LOCALE) { + # Try to obtain what the Windows ANSI code page is + eval { + unless (defined &GetConsoleCP) { + require Win32; + # no point falling back to Win32::GetConsoleCP from this + # as added same time, 0.45 + eval { Win32::GetConsoleCP() }; + # manually "import" it since Win32->import refuses + *GetConsoleCP = sub { &Win32::GetConsoleCP } unless $@; + } + unless (defined &GetConsoleCP) { + require Win32::API; + Win32::API->Import('kernel32', 'int GetConsoleCP()'); + } + if (defined &GetConsoleCP) { + my $cp = GetConsoleCP(); + $ENCODING_LOCALE = "cp$cp" if $cp; + } + }; + } + + unless ($ENCODING_CONSOLE_IN) { + # only test one since set together + unless (defined &GetInputCP) { + eval { + require Win32; + eval { Win32::GetConsoleCP() }; + # manually "import" it since Win32->import refuses + *GetInputCP = sub { &Win32::GetConsoleCP } unless $@; + *GetOutputCP = sub { &Win32::GetConsoleOutputCP } unless $@; + }; + unless (defined &GetInputCP) { + eval { + # try Win32::Console module for codepage to use + require Win32::Console; + eval { Win32::Console::InputCP() }; + *GetInputCP = sub { &Win32::Console::InputCP } + unless $@; + *GetOutputCP = sub { &Win32::Console::OutputCP } + unless $@; + }; + } + unless (defined &GetInputCP) { + # final fallback + *GetInputCP = *GetOutputCP = sub { + # another fallback that could work is: + # reg query HKLM\System\CurrentControlSet\Control\Nls\CodePage /v ACP + ((qx(chcp) || '') =~ /^Active code page: (\d+)/) + ? $1 : (); + }; + } + } + my $cp = GetInputCP(); + $ENCODING_CONSOLE_IN = "cp$cp" if $cp; + $cp = GetOutputCP(); + $ENCODING_CONSOLE_OUT = "cp$cp" if $cp; + } + } + + unless ($ENCODING_LOCALE) { + eval { + require I18N::Langinfo; + $ENCODING_LOCALE = I18N::Langinfo::langinfo(I18N::Langinfo::CODESET()); + + # Workaround of Encode < v2.25. The "646" encoding alias was + # introduced in Encode-2.25, but we don't want to require that version + # quite yet. Should avoid the CPAN testers failure reported from + # openbsd-4.7/perl-5.10.0 combo. + $ENCODING_LOCALE = "ascii" if $ENCODING_LOCALE eq "646"; + + # https://rt.cpan.org/Ticket/Display.html?id=66373 + $ENCODING_LOCALE = "hp-roman8" if $^O eq "hpux" && $ENCODING_LOCALE eq "roman8"; + }; + $ENCODING_LOCALE ||= $ENCODING_CONSOLE_IN; + } + + if ($^O eq "darwin") { + $ENCODING_LOCALE_FS ||= "UTF-8"; + } + + # final fallback + $ENCODING_LOCALE ||= $^O eq "MSWin32" ? "cp1252" : "UTF-8"; + $ENCODING_LOCALE_FS ||= $ENCODING_LOCALE; + $ENCODING_CONSOLE_IN ||= $ENCODING_LOCALE; + $ENCODING_CONSOLE_OUT ||= $ENCODING_CONSOLE_IN; + + unless (Encode::find_encoding($ENCODING_LOCALE)) { + my $foundit; + if (lc($ENCODING_LOCALE) eq "gb18030") { + eval { + require Encode::HanExtra; + }; + if ($@) { + die "Need Encode::HanExtra to be installed to support locale codeset ($ENCODING_LOCALE), stopped"; + } + $foundit++ if Encode::find_encoding($ENCODING_LOCALE); + } + die "The locale codeset ($ENCODING_LOCALE) isn't one that perl can decode, stopped" + unless $foundit; + + } + + # use Data::Dump; ddx $ENCODING_LOCALE, $ENCODING_LOCALE_FS, $ENCODING_CONSOLE_IN, $ENCODING_CONSOLE_OUT; + } + + _init(); + Encode::Alias::define_alias(sub { + no strict 'refs'; + no warnings 'once'; + return ${"ENCODING_" . uc(shift)}; + }, "locale"); + + sub _flush_aliases { + no strict 'refs'; + for my $a (keys %Encode::Alias::Alias) { + if (defined ${"ENCODING_" . uc($a)}) { + delete $Encode::Alias::Alias{$a}; + warn "Flushed alias cache for $a" if DEBUG; + } + } + } + + sub reinit { + $ENCODING_LOCALE = shift; + $ENCODING_LOCALE_FS = shift; + $ENCODING_CONSOLE_IN = $ENCODING_LOCALE; + $ENCODING_CONSOLE_OUT = $ENCODING_LOCALE; + _init(); + _flush_aliases(); + } + + sub decode_argv { + die if defined wantarray; + for (@ARGV) { + $_ = Encode::decode(locale => $_, @_); + } + } + + sub env { + my $k = Encode::encode(locale => shift); + my $old = $ENV{$k}; + if (@_) { + my $v = shift; + if (defined $v) { + $ENV{$k} = Encode::encode(locale => $v); + } + else { + delete $ENV{$k}; + } + } + return Encode::decode(locale => $old) if defined wantarray; + } + + 1; + + __END__ + + =head1 NAME + + ExtUtils::MakeMaker::Locale - bundled Encode::Locale + + =head1 SYNOPSIS + + use Encode::Locale; + use Encode; + + $string = decode(locale => $bytes); + $bytes = encode(locale => $string); + + if (-t) { + binmode(STDIN, ":encoding(console_in)"); + binmode(STDOUT, ":encoding(console_out)"); + binmode(STDERR, ":encoding(console_out)"); + } + + # Processing file names passed in as arguments + my $uni_filename = decode(locale => $ARGV[0]); + open(my $fh, "<", encode(locale_fs => $uni_filename)) + || die "Can't open '$uni_filename': $!"; + binmode($fh, ":encoding(locale)"); + ... + + =head1 DESCRIPTION + + In many applications it's wise to let Perl use Unicode for the strings it + processes. Most of the interfaces Perl has to the outside world are still byte + based. Programs therefore need to decode byte strings that enter the program + from the outside and encode them again on the way out. + + The POSIX locale system is used to specify both the language conventions + requested by the user and the preferred character set to consume and + output. The C module looks up the charset and encoding (called + a CODESET in the locale jargon) and arranges for the L module to know + this encoding under the name "locale". It means bytes obtained from the + environment can be converted to Unicode strings by calling C<< + Encode::encode(locale => $bytes) >> and converted back again with C<< + Encode::decode(locale => $string) >>. + + Where file systems interfaces pass file names in and out of the program we also + need care. The trend is for operating systems to use a fixed file encoding + that don't actually depend on the locale; and this module determines the most + appropriate encoding for file names. The L module will know this + encoding under the name "locale_fs". For traditional Unix systems this will + be an alias to the same encoding as "locale". + + For programs running in a terminal window (called a "Console" on some systems) + the "locale" encoding is usually a good choice for what to expect as input and + output. Some systems allows us to query the encoding set for the terminal and + C will do that if available and make these encodings known + under the C aliases "console_in" and "console_out". For systems where + we can't determine the terminal encoding these will be aliased as the same + encoding as "locale". The advice is to use "console_in" for input known to + come from the terminal and "console_out" for output to the terminal. + + In addition to arranging for various Encode aliases the following functions and + variables are provided: + + =over + + =item decode_argv( ) + + =item decode_argv( Encode::FB_CROAK ) + + This will decode the command line arguments to perl (the C<@ARGV> array) in-place. + + The function will by default replace characters that can't be decoded by + "\x{FFFD}", the Unicode replacement character. + + Any argument provided is passed as CHECK to underlying Encode::decode() call. + Pass the value C to have the decoding croak if not all the + command line arguments can be decoded. See L + for details on other options for CHECK. + + =item env( $uni_key ) + + =item env( $uni_key => $uni_value ) + + Interface to get/set environment variables. Returns the current value as a + Unicode string. The $uni_key and $uni_value arguments are expected to be + Unicode strings as well. Passing C as $uni_value deletes the + environment variable named $uni_key. + + The returned value will have the characters that can't be decoded replaced by + "\x{FFFD}", the Unicode replacement character. + + There is no interface to request alternative CHECK behavior as for + decode_argv(). If you need that you need to call encode/decode yourself. + For example: + + my $key = Encode::encode(locale => $uni_key, Encode::FB_CROAK); + my $uni_value = Encode::decode(locale => $ENV{$key}, Encode::FB_CROAK); + + =item reinit( ) + + =item reinit( $encoding ) + + Reinitialize the encodings from the locale. You want to call this function if + you changed anything in the environment that might influence the locale. + + This function will croak if the determined encoding isn't recognized by + the Encode module. + + With argument force $ENCODING_... variables to set to the given value. + + =item $ENCODING_LOCALE + + The encoding name determined to be suitable for the current locale. + L know this encoding as "locale". + + =item $ENCODING_LOCALE_FS + + The encoding name determined to be suitable for file system interfaces + involving file names. + L know this encoding as "locale_fs". + + =item $ENCODING_CONSOLE_IN + + =item $ENCODING_CONSOLE_OUT + + The encodings to be used for reading and writing output to the a console. + L know these encodings as "console_in" and "console_out". + + =back + + =head1 NOTES + + This table summarizes the mapping of the encodings set up + by the C module: + + Encode | | | + Alias | Windows | Mac OS X | POSIX + ------------+---------+--------------+------------ + locale | ANSI | nl_langinfo | nl_langinfo + locale_fs | ANSI | UTF-8 | nl_langinfo + console_in | OEM | nl_langinfo | nl_langinfo + console_out | OEM | nl_langinfo | nl_langinfo + + =head2 Windows + + Windows has basically 2 sets of APIs. A wide API (based on passing UTF-16 + strings) and a byte based API based a character set called ANSI. The + regular Perl interfaces to the OS currently only uses the ANSI APIs. + Unfortunately ANSI is not a single character set. + + The encoding that corresponds to ANSI varies between different editions of + Windows. For many western editions of Windows ANSI corresponds to CP-1252 + which is a character set similar to ISO-8859-1. Conceptually the ANSI + character set is a similar concept to the POSIX locale CODESET so this module + figures out what the ANSI code page is and make this available as + $ENCODING_LOCALE and the "locale" Encoding alias. + + Windows systems also operate with another byte based character set. + It's called the OEM code page. This is the encoding that the Console + takes as input and output. It's common for the OEM code page to + differ from the ANSI code page. + + =head2 Mac OS X + + On Mac OS X the file system encoding is always UTF-8 while the locale + can otherwise be set up as normal for POSIX systems. + + File names on Mac OS X will at the OS-level be converted to + NFD-form. A file created by passing a NFC-filename will come + in NFD-form from readdir(). See L for details + of NFD/NFC. + + Actually, Apple does not follow the Unicode NFD standard since not all + character ranges are decomposed. The claim is that this avoids problems with + round trip conversions from old Mac text encodings. See L for + details. + + =head2 POSIX (Linux and other Unixes) + + File systems might vary in what encoding is to be used for + filenames. Since this module has no way to actually figure out + what the is correct it goes with the best guess which is to + assume filenames are encoding according to the current locale. + Users are advised to always specify UTF-8 as the locale charset. + + =head1 SEE ALSO + + L, L, L + + =head1 AUTHOR + + Copyright 2010 Gisle Aas . + + This library is free software; you can redistribute it and/or + modify it under the same terms as Perl itself. + + =cut +EXTUTILS_MAKEMAKER_LOCALE + +$fatpacked{"ExtUtils/MakeMaker/version.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MAKEMAKER_VERSION'; + #--------------------------------------------------------------------------# + # This is a modified copy of version.pm 0.9909, bundled exclusively for + # use by ExtUtils::Makemaker and its dependencies to bootstrap when + # version.pm is not available. It should not be used by ordinary modules. + # + # When loaded, it will try to load version.pm. If that fails, it will load + # ExtUtils::MakeMaker::version::vpp and alias various *version functions + # to functions in that module. It will also override UNIVERSAL::VERSION. + #--------------------------------------------------------------------------# + + package ExtUtils::MakeMaker::version; + + use 5.006001; + use strict; + + use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv); + + $VERSION = '7.06'; + $VERSION = eval $VERSION; + $CLASS = 'version'; + + { + local $SIG{'__DIE__'}; + eval "use version"; + if ( $@ ) { # don't have any version.pm installed + eval "use ExtUtils::MakeMaker::version::vpp"; + die "$@" if ( $@ ); + local $^W; + delete $INC{'version.pm'}; + $INC{'version.pm'} = $INC{'ExtUtils/MakeMaker/version.pm'}; + push @version::ISA, "ExtUtils::MakeMaker::version::vpp"; + $version::VERSION = $VERSION; + *version::qv = \&ExtUtils::MakeMaker::version::vpp::qv; + *version::declare = \&ExtUtils::MakeMaker::version::vpp::declare; + *version::_VERSION = \&ExtUtils::MakeMaker::version::vpp::_VERSION; + *version::vcmp = \&ExtUtils::MakeMaker::version::vpp::vcmp; + *version::new = \&ExtUtils::MakeMaker::version::vpp::new; + if ($] >= 5.009000) { + no strict 'refs'; + *version::stringify = \&ExtUtils::MakeMaker::version::vpp::stringify; + *{'version::(""'} = \&ExtUtils::MakeMaker::version::vpp::stringify; + *{'version::(<=>'} = \&ExtUtils::MakeMaker::version::vpp::vcmp; + *version::parse = \&ExtUtils::MakeMaker::version::vpp::parse; + } + require ExtUtils::MakeMaker::version::regex; + *version::is_lax = \&ExtUtils::MakeMaker::version::regex::is_lax; + *version::is_strict = \&ExtUtils::MakeMaker::version::regex::is_strict; + *LAX = \$ExtUtils::MakeMaker::version::regex::LAX; + *STRICT = \$ExtUtils::MakeMaker::version::regex::STRICT; + } + elsif ( ! version->can('is_qv') ) { + *version::is_qv = sub { exists $_[0]->{qv} }; + } + } + + 1; +EXTUTILS_MAKEMAKER_VERSION + +$fatpacked{"ExtUtils/MakeMaker/version/regex.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MAKEMAKER_VERSION_REGEX'; + #--------------------------------------------------------------------------# + # This is a modified copy of version.pm 0.9909, bundled exclusively for + # use by ExtUtils::Makemaker and its dependencies to bootstrap when + # version.pm is not available. It should not be used by ordinary modules. + #--------------------------------------------------------------------------# + + package ExtUtils::MakeMaker::version::regex; + + use strict; + + use vars qw($VERSION $CLASS $STRICT $LAX); + + $VERSION = '7.06'; + $VERSION = eval $VERSION; + + #--------------------------------------------------------------------------# + # Version regexp components + #--------------------------------------------------------------------------# + + # Fraction part of a decimal version number. This is a common part of + # both strict and lax decimal versions + + my $FRACTION_PART = qr/\.[0-9]+/; + + # First part of either decimal or dotted-decimal strict version number. + # Unsigned integer with no leading zeroes (except for zero itself) to + # avoid confusion with octal. + + my $STRICT_INTEGER_PART = qr/0|[1-9][0-9]*/; + + # First part of either decimal or dotted-decimal lax version number. + # Unsigned integer, but allowing leading zeros. Always interpreted + # as decimal. However, some forms of the resulting syntax give odd + # results if used as ordinary Perl expressions, due to how perl treats + # octals. E.g. + # version->new("010" ) == 10 + # version->new( 010 ) == 8 + # version->new( 010.2) == 82 # "8" . "2" + + my $LAX_INTEGER_PART = qr/[0-9]+/; + + # Second and subsequent part of a strict dotted-decimal version number. + # Leading zeroes are permitted, and the number is always decimal. + # Limited to three digits to avoid overflow when converting to decimal + # form and also avoid problematic style with excessive leading zeroes. + + my $STRICT_DOTTED_DECIMAL_PART = qr/\.[0-9]{1,3}/; + + # Second and subsequent part of a lax dotted-decimal version number. + # Leading zeroes are permitted, and the number is always decimal. No + # limit on the numerical value or number of digits, so there is the + # possibility of overflow when converting to decimal form. + + my $LAX_DOTTED_DECIMAL_PART = qr/\.[0-9]+/; + + # Alpha suffix part of lax version number syntax. Acts like a + # dotted-decimal part. + + my $LAX_ALPHA_PART = qr/_[0-9]+/; + + #--------------------------------------------------------------------------# + # Strict version regexp definitions + #--------------------------------------------------------------------------# + + # Strict decimal version number. + + my $STRICT_DECIMAL_VERSION = + qr/ $STRICT_INTEGER_PART $FRACTION_PART? /x; + + # Strict dotted-decimal version number. Must have both leading "v" and + # at least three parts, to avoid confusion with decimal syntax. + + my $STRICT_DOTTED_DECIMAL_VERSION = + qr/ v $STRICT_INTEGER_PART $STRICT_DOTTED_DECIMAL_PART{2,} /x; + + # Complete strict version number syntax -- should generally be used + # anchored: qr/ \A $STRICT \z /x + + $STRICT = + qr/ $STRICT_DECIMAL_VERSION | $STRICT_DOTTED_DECIMAL_VERSION /x; + + #--------------------------------------------------------------------------# + # Lax version regexp definitions + #--------------------------------------------------------------------------# + + # Lax decimal version number. Just like the strict one except for + # allowing an alpha suffix or allowing a leading or trailing + # decimal-point + + my $LAX_DECIMAL_VERSION = + qr/ $LAX_INTEGER_PART (?: \. | $FRACTION_PART $LAX_ALPHA_PART? )? + | + $FRACTION_PART $LAX_ALPHA_PART? + /x; + + # Lax dotted-decimal version number. Distinguished by having either + # leading "v" or at least three non-alpha parts. Alpha part is only + # permitted if there are at least two non-alpha parts. Strangely + # enough, without the leading "v", Perl takes .1.2 to mean v0.1.2, + # so when there is no "v", the leading part is optional + + my $LAX_DOTTED_DECIMAL_VERSION = + qr/ + v $LAX_INTEGER_PART (?: $LAX_DOTTED_DECIMAL_PART+ $LAX_ALPHA_PART? )? + | + $LAX_INTEGER_PART? $LAX_DOTTED_DECIMAL_PART{2,} $LAX_ALPHA_PART? + /x; + + # Complete lax version number syntax -- should generally be used + # anchored: qr/ \A $LAX \z /x + # + # The string 'undef' is a special case to make for easier handling + # of return values from ExtUtils::MM->parse_version + + $LAX = + qr/ undef | $LAX_DECIMAL_VERSION | $LAX_DOTTED_DECIMAL_VERSION /x; + + #--------------------------------------------------------------------------# + + # Preloaded methods go here. + sub is_strict { defined $_[0] && $_[0] =~ qr/ \A $STRICT \z /x } + sub is_lax { defined $_[0] && $_[0] =~ qr/ \A $LAX \z /x } + + 1; +EXTUTILS_MAKEMAKER_VERSION_REGEX + +$fatpacked{"ExtUtils/MakeMaker/version/vpp.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MAKEMAKER_VERSION_VPP'; + #--------------------------------------------------------------------------# + # This is a modified copy of version.pm 0.9909, bundled exclusively for + # use by ExtUtils::Makemaker and its dependencies to bootstrap when + # version.pm is not available. It should not be used by ordinary modules. + #--------------------------------------------------------------------------# + + package ExtUtils::MakeMaker::charstar; + # a little helper class to emulate C char* semantics in Perl + # so that prescan_version can use the same code as in C + + use overload ( + '""' => \&thischar, + '0+' => \&thischar, + '++' => \&increment, + '--' => \&decrement, + '+' => \&plus, + '-' => \&minus, + '*' => \&multiply, + 'cmp' => \&cmp, + '<=>' => \&spaceship, + 'bool' => \&thischar, + '=' => \&clone, + ); + + sub new { + my ($self, $string) = @_; + my $class = ref($self) || $self; + + my $obj = { + string => [split(//,$string)], + current => 0, + }; + return bless $obj, $class; + } + + sub thischar { + my ($self) = @_; + my $last = $#{$self->{string}}; + my $curr = $self->{current}; + if ($curr >= 0 && $curr <= $last) { + return $self->{string}->[$curr]; + } + else { + return ''; + } + } + + sub increment { + my ($self) = @_; + $self->{current}++; + } + + sub decrement { + my ($self) = @_; + $self->{current}--; + } + + sub plus { + my ($self, $offset) = @_; + my $rself = $self->clone; + $rself->{current} += $offset; + return $rself; + } + + sub minus { + my ($self, $offset) = @_; + my $rself = $self->clone; + $rself->{current} -= $offset; + return $rself; + } + + sub multiply { + my ($left, $right, $swapped) = @_; + my $char = $left->thischar(); + return $char * $right; + } + + sub spaceship { + my ($left, $right, $swapped) = @_; + unless (ref($right)) { # not an object already + $right = $left->new($right); + } + return $left->{current} <=> $right->{current}; + } + + sub cmp { + my ($left, $right, $swapped) = @_; + unless (ref($right)) { # not an object already + if (length($right) == 1) { # comparing single character only + return $left->thischar cmp $right; + } + $right = $left->new($right); + } + return $left->currstr cmp $right->currstr; + } + + sub bool { + my ($self) = @_; + my $char = $self->thischar; + return ($char ne ''); + } + + sub clone { + my ($left, $right, $swapped) = @_; + $right = { + string => [@{$left->{string}}], + current => $left->{current}, + }; + return bless $right, ref($left); + } + + sub currstr { + my ($self, $s) = @_; + my $curr = $self->{current}; + my $last = $#{$self->{string}}; + if (defined($s) && $s->{current} < $last) { + $last = $s->{current}; + } + + my $string = join('', @{$self->{string}}[$curr..$last]); + return $string; + } + + package ExtUtils::MakeMaker::version::vpp; + + use 5.006001; + use strict; + + use Config; + use vars qw($VERSION $CLASS @ISA $LAX $STRICT); + $VERSION = '7.06'; + $VERSION = eval $VERSION; + $CLASS = 'ExtUtils::MakeMaker::version::vpp'; + + require ExtUtils::MakeMaker::version::regex; + *ExtUtils::MakeMaker::version::vpp::is_strict = \&ExtUtils::MakeMaker::version::regex::is_strict; + *ExtUtils::MakeMaker::version::vpp::is_lax = \&ExtUtils::MakeMaker::version::regex::is_lax; + *LAX = \$ExtUtils::MakeMaker::version::regex::LAX; + *STRICT = \$ExtUtils::MakeMaker::version::regex::STRICT; + + use overload ( + '""' => \&stringify, + '0+' => \&numify, + 'cmp' => \&vcmp, + '<=>' => \&vcmp, + 'bool' => \&vbool, + '+' => \&vnoop, + '-' => \&vnoop, + '*' => \&vnoop, + '/' => \&vnoop, + '+=' => \&vnoop, + '-=' => \&vnoop, + '*=' => \&vnoop, + '/=' => \&vnoop, + 'abs' => \&vnoop, + ); + + eval "use warnings"; + if ($@) { + eval ' + package + warnings; + sub enabled {return $^W;} + 1; + '; + } + + sub import { + no strict 'refs'; + my ($class) = shift; + + # Set up any derived class + unless ($class eq $CLASS) { + local $^W; + *{$class.'::declare'} = \&{$CLASS.'::declare'}; + *{$class.'::qv'} = \&{$CLASS.'::qv'}; + } + + my %args; + if (@_) { # any remaining terms are arguments + map { $args{$_} = 1 } @_ + } + else { # no parameters at all on use line + %args = + ( + qv => 1, + 'UNIVERSAL::VERSION' => 1, + ); + } + + my $callpkg = caller(); + + if (exists($args{declare})) { + *{$callpkg.'::declare'} = + sub {return $class->declare(shift) } + unless defined(&{$callpkg.'::declare'}); + } + + if (exists($args{qv})) { + *{$callpkg.'::qv'} = + sub {return $class->qv(shift) } + unless defined(&{$callpkg.'::qv'}); + } + + if (exists($args{'UNIVERSAL::VERSION'})) { + local $^W; + *UNIVERSAL::VERSION + = \&{$CLASS.'::_VERSION'}; + } + + if (exists($args{'VERSION'})) { + *{$callpkg.'::VERSION'} = \&{$CLASS.'::_VERSION'}; + } + + if (exists($args{'is_strict'})) { + *{$callpkg.'::is_strict'} = \&{$CLASS.'::is_strict'} + unless defined(&{$callpkg.'::is_strict'}); + } + + if (exists($args{'is_lax'})) { + *{$callpkg.'::is_lax'} = \&{$CLASS.'::is_lax'} + unless defined(&{$callpkg.'::is_lax'}); + } + } + + my $VERSION_MAX = 0x7FFFFFFF; + + # implement prescan_version as closely to the C version as possible + use constant TRUE => 1; + use constant FALSE => 0; + + sub isDIGIT { + my ($char) = shift->thischar(); + return ($char =~ /\d/); + } + + sub isALPHA { + my ($char) = shift->thischar(); + return ($char =~ /[a-zA-Z]/); + } + + sub isSPACE { + my ($char) = shift->thischar(); + return ($char =~ /\s/); + } + + sub BADVERSION { + my ($s, $errstr, $error) = @_; + if ($errstr) { + $$errstr = $error; + } + return $s; + } + + sub prescan_version { + my ($s, $strict, $errstr, $sqv, $ssaw_decimal, $swidth, $salpha) = @_; + my $qv = defined $sqv ? $$sqv : FALSE; + my $saw_decimal = defined $ssaw_decimal ? $$ssaw_decimal : 0; + my $width = defined $swidth ? $$swidth : 3; + my $alpha = defined $salpha ? $$salpha : FALSE; + + my $d = $s; + + if ($qv && isDIGIT($d)) { + goto dotted_decimal_version; + } + + if ($d eq 'v') { # explicit v-string + $d++; + if (isDIGIT($d)) { + $qv = TRUE; + } + else { # degenerate v-string + # requires v1.2.3 + return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); + } + + dotted_decimal_version: + if ($strict && $d eq '0' && isDIGIT($d+1)) { + # no leading zeros allowed + return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)"); + } + + while (isDIGIT($d)) { # integer part + $d++; + } + + if ($d eq '.') + { + $saw_decimal++; + $d++; # decimal point + } + else + { + if ($strict) { + # require v1.2.3 + return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); + } + else { + goto version_prescan_finish; + } + } + + { + my $i = 0; + my $j = 0; + while (isDIGIT($d)) { # just keep reading + $i++; + while (isDIGIT($d)) { + $d++; $j++; + # maximum 3 digits between decimal + if ($strict && $j > 3) { + return BADVERSION($s,$errstr,"Invalid version format (maximum 3 digits between decimals)"); + } + } + if ($d eq '_') { + if ($strict) { + return BADVERSION($s,$errstr,"Invalid version format (no underscores)"); + } + if ( $alpha ) { + return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)"); + } + $d++; + $alpha = TRUE; + } + elsif ($d eq '.') { + if ($alpha) { + return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)"); + } + $saw_decimal++; + $d++; + } + elsif (!isDIGIT($d)) { + last; + } + $j = 0; + } + + if ($strict && $i < 2) { + # requires v1.2.3 + return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); + } + } + } # end if dotted-decimal + else + { # decimal versions + my $j = 0; + # special $strict case for leading '.' or '0' + if ($strict) { + if ($d eq '.') { + return BADVERSION($s,$errstr,"Invalid version format (0 before decimal required)"); + } + if ($d eq '0' && isDIGIT($d+1)) { + return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)"); + } + } + + # and we never support negative version numbers + if ($d eq '-') { + return BADVERSION($s,$errstr,"Invalid version format (negative version number)"); + } + + # consume all of the integer part + while (isDIGIT($d)) { + $d++; + } + + # look for a fractional part + if ($d eq '.') { + # we found it, so consume it + $saw_decimal++; + $d++; + } + elsif (!$d || $d eq ';' || isSPACE($d) || $d eq '}') { + if ( $d == $s ) { + # found nothing + return BADVERSION($s,$errstr,"Invalid version format (version required)"); + } + # found just an integer + goto version_prescan_finish; + } + elsif ( $d == $s ) { + # didn't find either integer or period + return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)"); + } + elsif ($d eq '_') { + # underscore can't come after integer part + if ($strict) { + return BADVERSION($s,$errstr,"Invalid version format (no underscores)"); + } + elsif (isDIGIT($d+1)) { + return BADVERSION($s,$errstr,"Invalid version format (alpha without decimal)"); + } + else { + return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)"); + } + } + elsif ($d) { + # anything else after integer part is just invalid data + return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)"); + } + + # scan the fractional part after the decimal point + if ($d && !isDIGIT($d) && ($strict || ! ($d eq ';' || isSPACE($d) || $d eq '}') )) { + # $strict or lax-but-not-the-end + return BADVERSION($s,$errstr,"Invalid version format (fractional part required)"); + } + + while (isDIGIT($d)) { + $d++; $j++; + if ($d eq '.' && isDIGIT($d-1)) { + if ($alpha) { + return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)"); + } + if ($strict) { + return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions must begin with 'v')"); + } + $d = $s; # start all over again + $qv = TRUE; + goto dotted_decimal_version; + } + if ($d eq '_') { + if ($strict) { + return BADVERSION($s,$errstr,"Invalid version format (no underscores)"); + } + if ( $alpha ) { + return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)"); + } + if ( ! isDIGIT($d+1) ) { + return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)"); + } + $width = $j; + $d++; + $alpha = TRUE; + } + } + } + + version_prescan_finish: + while (isSPACE($d)) { + $d++; + } + + if ($d && !isDIGIT($d) && (! ($d eq ';' || $d eq '}') )) { + # trailing non-numeric data + return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)"); + } + + if (defined $sqv) { + $$sqv = $qv; + } + if (defined $swidth) { + $$swidth = $width; + } + if (defined $ssaw_decimal) { + $$ssaw_decimal = $saw_decimal; + } + if (defined $salpha) { + $$salpha = $alpha; + } + return $d; + } + + sub scan_version { + my ($s, $rv, $qv) = @_; + my $start; + my $pos; + my $last; + my $errstr; + my $saw_decimal = 0; + my $width = 3; + my $alpha = FALSE; + my $vinf = FALSE; + my @av; + + $s = new ExtUtils::MakeMaker::charstar $s; + + while (isSPACE($s)) { # leading whitespace is OK + $s++; + } + + $last = prescan_version($s, FALSE, \$errstr, \$qv, \$saw_decimal, + \$width, \$alpha); + + if ($errstr) { + # 'undef' is a special case and not an error + if ( $s ne 'undef') { + require Carp; + Carp::croak($errstr); + } + } + + $start = $s; + if ($s eq 'v') { + $s++; + } + $pos = $s; + + if ( $qv ) { + $$rv->{qv} = $qv; + } + if ( $alpha ) { + $$rv->{alpha} = $alpha; + } + if ( !$qv && $width < 3 ) { + $$rv->{width} = $width; + } + + while (isDIGIT($pos)) { + $pos++; + } + if (!isALPHA($pos)) { + my $rev; + + for (;;) { + $rev = 0; + { + # this is atoi() that delimits on underscores + my $end = $pos; + my $mult = 1; + my $orev; + + # the following if() will only be true after the decimal + # point of a version originally created with a bare + # floating point number, i.e. not quoted in any way + # + if ( !$qv && $s > $start && $saw_decimal == 1 ) { + $mult *= 100; + while ( $s < $end ) { + $orev = $rev; + $rev += $s * $mult; + $mult /= 10; + if ( (abs($orev) > abs($rev)) + || (abs($rev) > $VERSION_MAX )) { + warn("Integer overflow in version %d", + $VERSION_MAX); + $s = $end - 1; + $rev = $VERSION_MAX; + $vinf = 1; + } + $s++; + if ( $s eq '_' ) { + $s++; + } + } + } + else { + while (--$end >= $s) { + $orev = $rev; + $rev += $end * $mult; + $mult *= 10; + if ( (abs($orev) > abs($rev)) + || (abs($rev) > $VERSION_MAX )) { + warn("Integer overflow in version"); + $end = $s - 1; + $rev = $VERSION_MAX; + $vinf = 1; + } + } + } + } + + # Append revision + push @av, $rev; + if ( $vinf ) { + $s = $last; + last; + } + elsif ( $pos eq '.' ) { + $s = ++$pos; + } + elsif ( $pos eq '_' && isDIGIT($pos+1) ) { + $s = ++$pos; + } + elsif ( $pos eq ',' && isDIGIT($pos+1) ) { + $s = ++$pos; + } + elsif ( isDIGIT($pos) ) { + $s = $pos; + } + else { + $s = $pos; + last; + } + if ( $qv ) { + while ( isDIGIT($pos) ) { + $pos++; + } + } + else { + my $digits = 0; + while ( ( isDIGIT($pos) || $pos eq '_' ) && $digits < 3 ) { + if ( $pos ne '_' ) { + $digits++; + } + $pos++; + } + } + } + } + if ( $qv ) { # quoted versions always get at least three terms + my $len = $#av; + # This for loop appears to trigger a compiler bug on OS X, as it + # loops infinitely. Yes, len is negative. No, it makes no sense. + # Compiler in question is: + # gcc version 3.3 20030304 (Apple Computer, Inc. build 1640) + # for ( len = 2 - len; len > 0; len-- ) + # av_push(MUTABLE_AV(sv), newSViv(0)); + # + $len = 2 - $len; + while ($len-- > 0) { + push @av, 0; + } + } + + # need to save off the current version string for later + if ( $vinf ) { + $$rv->{original} = "v.Inf"; + $$rv->{vinf} = 1; + } + elsif ( $s > $start ) { + $$rv->{original} = $start->currstr($s); + if ( $qv && $saw_decimal == 1 && $start ne 'v' ) { + # need to insert a v to be consistent + $$rv->{original} = 'v' . $$rv->{original}; + } + } + else { + $$rv->{original} = '0'; + push(@av, 0); + } + + # And finally, store the AV in the hash + $$rv->{version} = \@av; + + # fix RT#19517 - special case 'undef' as string + if ($s eq 'undef') { + $s += 5; + } + + return $s; + } + + sub new { + my $class = shift; + unless (defined $class or $#_ > 1) { + require Carp; + Carp::croak('Usage: version::new(class, version)'); + } + + my $self = bless ({}, ref ($class) || $class); + my $qv = FALSE; + + if ( $#_ == 1 ) { # must be CVS-style + $qv = TRUE; + } + my $value = pop; # always going to be the last element + + if ( ref($value) && eval('$value->isa("version")') ) { + # Can copy the elements directly + $self->{version} = [ @{$value->{version} } ]; + $self->{qv} = 1 if $value->{qv}; + $self->{alpha} = 1 if $value->{alpha}; + $self->{original} = ''.$value->{original}; + return $self; + } + + if ( not defined $value or $value =~ /^undef$/ ) { + # RT #19517 - special case for undef comparison + # or someone forgot to pass a value + push @{$self->{version}}, 0; + $self->{original} = "0"; + return ($self); + } + + + if (ref($value) =~ m/ARRAY|HASH/) { + require Carp; + Carp::croak("Invalid version format (non-numeric data)"); + } + + $value = _un_vstring($value); + + if ($Config{d_setlocale} && eval { require POSIX } ) { + require locale; + my $currlocale = POSIX::setlocale(&POSIX::LC_ALL); + + # if the current locale uses commas for decimal points, we + # just replace commas with decimal places, rather than changing + # locales + if ( POSIX::localeconv()->{decimal_point} eq ',' ) { + $value =~ tr/,/./; + } + } + + # exponential notation + if ( $value =~ /\d+.?\d*e[-+]?\d+/ ) { + $value = sprintf("%.9f",$value); + $value =~ s/(0+)$//; # trim trailing zeros + } + + my $s = scan_version($value, \$self, $qv); + + if ($s) { # must be something left over + warn("Version string '%s' contains invalid data; " + ."ignoring: '%s'", $value, $s); + } + + return ($self); + } + + *parse = \&new; + + sub numify { + my ($self) = @_; + unless (_verify($self)) { + require Carp; + Carp::croak("Invalid version object"); + } + my $width = $self->{width} || 3; + my $alpha = $self->{alpha} || ""; + my $len = $#{$self->{version}}; + my $digit = $self->{version}[0]; + my $string = sprintf("%d.", $digit ); + + for ( my $i = 1 ; $i < $len ; $i++ ) { + $digit = $self->{version}[$i]; + if ( $width < 3 ) { + my $denom = 10**(3-$width); + my $quot = int($digit/$denom); + my $rem = $digit - ($quot * $denom); + $string .= sprintf("%0".$width."d_%d", $quot, $rem); + } + else { + $string .= sprintf("%03d", $digit); + } + } + + if ( $len > 0 ) { + $digit = $self->{version}[$len]; + if ( $alpha && $width == 3 ) { + $string .= "_"; + } + $string .= sprintf("%0".$width."d", $digit); + } + else # $len = 0 + { + $string .= sprintf("000"); + } + + return $string; + } + + sub normal { + my ($self) = @_; + unless (_verify($self)) { + require Carp; + Carp::croak("Invalid version object"); + } + my $alpha = $self->{alpha} || ""; + my $len = $#{$self->{version}}; + my $digit = $self->{version}[0]; + my $string = sprintf("v%d", $digit ); + + for ( my $i = 1 ; $i < $len ; $i++ ) { + $digit = $self->{version}[$i]; + $string .= sprintf(".%d", $digit); + } + + if ( $len > 0 ) { + $digit = $self->{version}[$len]; + if ( $alpha ) { + $string .= sprintf("_%0d", $digit); + } + else { + $string .= sprintf(".%0d", $digit); + } + } + + if ( $len <= 2 ) { + for ( $len = 2 - $len; $len != 0; $len-- ) { + $string .= sprintf(".%0d", 0); + } + } + + return $string; + } + + sub stringify { + my ($self) = @_; + unless (_verify($self)) { + require Carp; + Carp::croak("Invalid version object"); + } + return exists $self->{original} + ? $self->{original} + : exists $self->{qv} + ? $self->normal + : $self->numify; + } + + sub vcmp { + require UNIVERSAL; + my ($left,$right,$swap) = @_; + my $class = ref($left); + unless ( UNIVERSAL::isa($right, $class) ) { + $right = $class->new($right); + } + + if ( $swap ) { + ($left, $right) = ($right, $left); + } + unless (_verify($left)) { + require Carp; + Carp::croak("Invalid version object"); + } + unless (_verify($right)) { + require Carp; + Carp::croak("Invalid version format"); + } + my $l = $#{$left->{version}}; + my $r = $#{$right->{version}}; + my $m = $l < $r ? $l : $r; + my $lalpha = $left->is_alpha; + my $ralpha = $right->is_alpha; + my $retval = 0; + my $i = 0; + while ( $i <= $m && $retval == 0 ) { + $retval = $left->{version}[$i] <=> $right->{version}[$i]; + $i++; + } + + # tiebreaker for alpha with identical terms + if ( $retval == 0 + && $l == $r + && $left->{version}[$m] == $right->{version}[$m] + && ( $lalpha || $ralpha ) ) { + + if ( $lalpha && !$ralpha ) { + $retval = -1; + } + elsif ( $ralpha && !$lalpha) { + $retval = +1; + } + } + + # possible match except for trailing 0's + if ( $retval == 0 && $l != $r ) { + if ( $l < $r ) { + while ( $i <= $r && $retval == 0 ) { + if ( $right->{version}[$i] != 0 ) { + $retval = -1; # not a match after all + } + $i++; + } + } + else { + while ( $i <= $l && $retval == 0 ) { + if ( $left->{version}[$i] != 0 ) { + $retval = +1; # not a match after all + } + $i++; + } + } + } + + return $retval; + } + + sub vbool { + my ($self) = @_; + return vcmp($self,$self->new("0"),1); + } + + sub vnoop { + require Carp; + Carp::croak("operation not supported with version object"); + } + + sub is_alpha { + my ($self) = @_; + return (exists $self->{alpha}); + } + + sub qv { + my $value = shift; + my $class = $CLASS; + if (@_) { + $class = ref($value) || $value; + $value = shift; + } + + $value = _un_vstring($value); + $value = 'v'.$value unless $value =~ /(^v|\d+\.\d+\.\d)/; + my $obj = $CLASS->new($value); + return bless $obj, $class; + } + + *declare = \&qv; + + sub is_qv { + my ($self) = @_; + return (exists $self->{qv}); + } + + + sub _verify { + my ($self) = @_; + if ( ref($self) + && eval { exists $self->{version} } + && ref($self->{version}) eq 'ARRAY' + ) { + return 1; + } + else { + return 0; + } + } + + sub _is_non_alphanumeric { + my $s = shift; + $s = new ExtUtils::MakeMaker::charstar $s; + while ($s) { + return 0 if isSPACE($s); # early out + return 1 unless (isALPHA($s) || isDIGIT($s) || $s =~ /[.-]/); + $s++; + } + return 0; + } + + sub _un_vstring { + my $value = shift; + # may be a v-string + if ( length($value) >= 3 && $value !~ /[._]/ + && _is_non_alphanumeric($value)) { + my $tvalue; + if ( $] ge 5.008_001 ) { + $tvalue = _find_magic_vstring($value); + $value = $tvalue if length $tvalue; + } + elsif ( $] ge 5.006_000 ) { + $tvalue = sprintf("v%vd",$value); + if ( $tvalue =~ /^v\d+(\.\d+){2,}$/ ) { + # must be a v-string + $value = $tvalue; + } + } + } + return $value; + } + + sub _find_magic_vstring { + my $value = shift; + my $tvalue = ''; + require B; + my $sv = B::svref_2object(\$value); + my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef; + while ( $magic ) { + if ( $magic->TYPE eq 'V' ) { + $tvalue = $magic->PTR; + $tvalue =~ s/^v?(.+)$/v$1/; + last; + } + else { + $magic = $magic->MOREMAGIC; + } + } + return $tvalue; + } + + sub _VERSION { + my ($obj, $req) = @_; + my $class = ref($obj) || $obj; + + no strict 'refs'; + if ( exists $INC{"$class.pm"} and not %{"$class\::"} and $] >= 5.008) { + # file but no package + require Carp; + Carp::croak( "$class defines neither package nor VERSION" + ."--version check failed"); + } + + my $version = eval "\$$class\::VERSION"; + if ( defined $version ) { + local $^W if $] <= 5.008; + $version = ExtUtils::MakeMaker::version::vpp->new($version); + } + + if ( defined $req ) { + unless ( defined $version ) { + require Carp; + my $msg = $] < 5.006 + ? "$class version $req required--this is only version " + : "$class does not define \$$class\::VERSION" + ."--version check failed"; + + if ( $ENV{VERSION_DEBUG} ) { + Carp::confess($msg); + } + else { + Carp::croak($msg); + } + } + + $req = ExtUtils::MakeMaker::version::vpp->new($req); + + if ( $req > $version ) { + require Carp; + if ( $req->is_qv ) { + Carp::croak( + sprintf ("%s version %s required--". + "this is only version %s", $class, + $req->normal, $version->normal) + ); + } + else { + Carp::croak( + sprintf ("%s version %s required--". + "this is only version %s", $class, + $req->stringify, $version->stringify) + ); + } + } + } + + return defined $version ? $version->stringify : undef; + } + + 1; #this line is important and will help the module return a true value +EXTUTILS_MAKEMAKER_VERSION_VPP + +$fatpacked{"ExtUtils/Manifest.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MANIFEST'; + package ExtUtils::Manifest; + + require Exporter; + use Config; + use File::Basename; + use File::Copy 'copy'; + use File::Find; + use File::Spec 0.8; + use Carp; + use strict; + use warnings; + + our $VERSION = '1.70'; + our @ISA = ('Exporter'); + our @EXPORT_OK = qw(mkmanifest + manicheck filecheck fullcheck skipcheck + manifind maniread manicopy maniadd + maniskip + ); + + our $Is_MacOS = $^O eq 'MacOS'; + our $Is_VMS = $^O eq 'VMS'; + our $Is_VMS_mode = 0; + our $Is_VMS_lc = 0; + our $Is_VMS_nodot = 0; # No dots in dir names or double dots in files + + if ($Is_VMS) { + require VMS::Filespec if $Is_VMS; + my $vms_unix_rpt; + my $vms_efs; + my $vms_case; + + $Is_VMS_mode = 1; + $Is_VMS_lc = 1; + $Is_VMS_nodot = 1; + if (eval { local $SIG{__DIE__}; require VMS::Feature; }) { + $vms_unix_rpt = VMS::Feature::current("filename_unix_report"); + $vms_efs = VMS::Feature::current("efs_charset"); + $vms_case = VMS::Feature::current("efs_case_preserve"); + } else { + my $unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || ''; + my $efs_charset = $ENV{'DECC$EFS_CHARSET'} || ''; + my $efs_case = $ENV{'DECC$EFS_CASE_PRESERVE'} || ''; + $vms_unix_rpt = $unix_rpt =~ /^[ET1]/i; + $vms_efs = $efs_charset =~ /^[ET1]/i; + $vms_case = $efs_case =~ /^[ET1]/i; + } + $Is_VMS_lc = 0 if ($vms_case); + $Is_VMS_mode = 0 if ($vms_unix_rpt); + $Is_VMS_nodot = 0 if ($vms_efs); + } + + our $Debug = $ENV{PERL_MM_MANIFEST_DEBUG} || 0; + our $Verbose = defined $ENV{PERL_MM_MANIFEST_VERBOSE} ? + $ENV{PERL_MM_MANIFEST_VERBOSE} : 1; + our $Quiet = 0; + our $MANIFEST = 'MANIFEST'; + + our $DEFAULT_MSKIP = File::Spec->catfile( dirname(__FILE__), "$MANIFEST.SKIP" ); + + + =head1 NAME + + ExtUtils::Manifest - utilities to write and check a MANIFEST file + + =head1 VERSION + + version 1.70 + + =head1 SYNOPSIS + + use ExtUtils::Manifest qw(...funcs to import...); + + mkmanifest(); + + my @missing_files = manicheck; + my @skipped = skipcheck; + my @extra_files = filecheck; + my($missing, $extra) = fullcheck; + + my $found = manifind(); + + my $manifest = maniread(); + + manicopy($read,$target); + + maniadd({$file => $comment, ...}); + + + =head1 DESCRIPTION + + =head2 Functions + + ExtUtils::Manifest exports no functions by default. The following are + exported on request + + =over 4 + + =item mkmanifest + + mkmanifest(); + + Writes all files in and below the current directory to your F. + It works similar to the result of the Unix command + + find . > MANIFEST + + All files that match any regular expression in a file F + (if it exists) are ignored. + + Any existing F file will be saved as F. + + =cut + + sub _sort { + return sort { lc $a cmp lc $b } @_; + } + + sub mkmanifest { + my $manimiss = 0; + my $read = (-r 'MANIFEST' && maniread()) or $manimiss++; + $read = {} if $manimiss; + local *M; + my $bakbase = $MANIFEST; + $bakbase =~ s/\./_/g if $Is_VMS_nodot; # avoid double dots + rename $MANIFEST, "$bakbase.bak" unless $manimiss; + open M, "> $MANIFEST" or die "Could not open $MANIFEST: $!"; + binmode M, ':raw'; + my $skip = maniskip(); + my $found = manifind(); + my($key,$val,$file,%all); + %all = (%$found, %$read); + $all{$MANIFEST} = ($Is_VMS_mode ? "$MANIFEST\t\t" : '') . + 'This list of files' + if $manimiss; # add new MANIFEST to known file list + foreach $file (_sort keys %all) { + if ($skip->($file)) { + # Policy: only remove files if they're listed in MANIFEST.SKIP. + # Don't remove files just because they don't exist. + warn "Removed from $MANIFEST: $file\n" if $Verbose and exists $read->{$file}; + next; + } + if ($Verbose){ + warn "Added to $MANIFEST: $file\n" unless exists $read->{$file}; + } + my $text = $all{$file}; + $file = _unmacify($file); + my $tabs = (5 - (length($file)+1)/8); + $tabs = 1 if $tabs < 1; + $tabs = 0 unless $text; + if ($file =~ /\s/) { + $file =~ s/([\\'])/\\$1/g; + $file = "'$file'"; + } + print M $file, "\t" x $tabs, $text, "\n"; + } + close M; + } + + # Geez, shouldn't this use File::Spec or File::Basename or something? + # Why so careful about dependencies? + sub clean_up_filename { + my $filename = shift; + $filename =~ s|^\./||; + $filename =~ s/^:([^:]+)$/$1/ if $Is_MacOS; + if ( $Is_VMS ) { + $filename =~ s/\.$//; # trim trailing dot + $filename = VMS::Filespec::unixify($filename); # unescape spaces, etc. + if( $Is_VMS_lc ) { + $filename = lc($filename); + $filename = uc($filename) if $filename =~ /^MANIFEST(\.SKIP)?$/i; + } + } + return $filename; + } + + + =item manifind + + my $found = manifind(); + + returns a hash reference. The keys of the hash are the files found + below the current directory. + + =cut + + sub manifind { + my $p = shift || {}; + my $found = {}; + + my $wanted = sub { + my $name = clean_up_filename($File::Find::name); + warn "Debug: diskfile $name\n" if $Debug; + return if -d $_; + $found->{$name} = ""; + }; + + # We have to use "$File::Find::dir/$_" in preprocess, because + # $File::Find::name is unavailable. + # Also, it's okay to use / here, because MANIFEST files use Unix-style + # paths. + find({wanted => $wanted, follow_fast => 1}, + $Is_MacOS ? ":" : "."); + + return $found; + } + + + =item manicheck + + my @missing_files = manicheck(); + + checks if all the files within a C in the current directory + really do exist. If C and the tree below the current + directory are in sync it silently returns an empty list. + Otherwise it returns a list of files which are listed in the + C but missing from the directory, and by default also + outputs these names to STDERR. + + =cut + + sub manicheck { + return _check_files(); + } + + + =item filecheck + + my @extra_files = filecheck(); + + finds files below the current directory that are not mentioned in the + C file. An optional file C will be + consulted. Any file matching a regular expression in such a file will + not be reported as missing in the C file. The list of any + extraneous files found is returned, and by default also reported to + STDERR. + + =cut + + sub filecheck { + return _check_manifest(); + } + + + =item fullcheck + + my($missing, $extra) = fullcheck(); + + does both a manicheck() and a filecheck(), returning then as two array + refs. + + =cut + + sub fullcheck { + return [_check_files()], [_check_manifest()]; + } + + + =item skipcheck + + my @skipped = skipcheck(); + + lists all the files that are skipped due to your C + file. + + =cut + + sub skipcheck { + my($p) = @_; + my $found = manifind(); + my $matches = maniskip(); + + my @skipped = (); + foreach my $file (_sort keys %$found){ + if (&$matches($file)){ + warn "Skipping $file\n" unless $Quiet; + push @skipped, $file; + next; + } + } + + return @skipped; + } + + + sub _check_files { + my $p = shift; + my $dosnames=(defined(&Dos::UseLFN) && Dos::UseLFN()==0); + my $read = maniread() || {}; + my $found = manifind($p); + + my(@missfile) = (); + foreach my $file (_sort keys %$read){ + warn "Debug: manicheck checking from $MANIFEST $file\n" if $Debug; + if ($dosnames){ + $file = lc $file; + $file =~ s=(\.(\w|-)+)=substr ($1,0,4)=ge; + $file =~ s=((\w|-)+)=substr ($1,0,8)=ge; + } + unless ( exists $found->{$file} ) { + warn "No such file: $file\n" unless $Quiet; + push @missfile, $file; + } + } + + return @missfile; + } + + + sub _check_manifest { + my($p) = @_; + my $read = maniread() || {}; + my $found = manifind($p); + my $skip = maniskip(); + + my @missentry = (); + foreach my $file (_sort keys %$found){ + next if $skip->($file); + warn "Debug: manicheck checking from disk $file\n" if $Debug; + unless ( exists $read->{$file} ) { + my $canon = $Is_MacOS ? "\t" . _unmacify($file) : ''; + warn "Not in $MANIFEST: $file$canon\n" unless $Quiet; + push @missentry, $file; + } + } + + return @missentry; + } + + + =item maniread + + my $manifest = maniread(); + my $manifest = maniread($manifest_file); + + reads a named C file (defaults to C in the current + directory) and returns a HASH reference with files being the keys and + comments being the values of the HASH. Blank lines and lines which + start with C<#> in the C file are discarded. + + =cut + + sub maniread { + my ($mfile) = @_; + $mfile ||= $MANIFEST; + my $read = {}; + local *M; + unless (open M, "< $mfile"){ + warn "Problem opening $mfile: $!"; + return $read; + } + local $_; + while (){ + chomp; + next if /^\s*#/; + + my($file, $comment); + + # filename may contain spaces if enclosed in '' + # (in which case, \\ and \' are escapes) + if (($file, $comment) = /^'((?:\\[\\']|.+)+)'\s*(.*)/) { + $file =~ s/\\([\\'])/$1/g; + } + else { + ($file, $comment) = /^(\S+)\s*(.*)/; + } + next unless $file; + + if ($Is_MacOS) { + $file = _macify($file); + $file =~ s/\\([0-3][0-7][0-7])/sprintf("%c", oct($1))/ge; + } + elsif ($Is_VMS_mode) { + require File::Basename; + my($base,$dir) = File::Basename::fileparse($file); + # Resolve illegal file specifications in the same way as tar + if ($Is_VMS_nodot) { + $dir =~ tr/./_/; + my(@pieces) = split(/\./,$base); + if (@pieces > 2) + { $base = shift(@pieces) . '.' . join('_',@pieces); } + my $okfile = "$dir$base"; + warn "Debug: Illegal name $file changed to $okfile\n" if $Debug; + $file = $okfile; + } + if( $Is_VMS_lc ) { + $file = lc($file); + $file = uc($file) if $file =~ /^MANIFEST(\.SKIP)?$/i; + } + } + + $read->{$file} = $comment; + } + close M; + $read; + } + + =item maniskip + + my $skipchk = maniskip(); + my $skipchk = maniskip($manifest_skip_file); + + if ($skipchk->($file)) { .. } + + reads a named C file (defaults to C in + the current directory) and returns a CODE reference that tests whether + a given filename should be skipped. + + =cut + + # returns an anonymous sub that decides if an argument matches + sub maniskip { + my @skip ; + my $mfile = shift || "$MANIFEST.SKIP"; + _check_mskip_directives($mfile) if -f $mfile; + local(*M, $_); + open M, "< $mfile" or open M, "< $DEFAULT_MSKIP" or return sub {0}; + while (){ + chomp; + s/\r//; + $_ =~ qr{^\s*(?:(?:'([^\\']*(?:\\.[^\\']*)*)')|([^#\s]\S*))?(?:(?:\s*)|(?:\s+(.*?)\s*))$}; + #my $comment = $3; + my $filename = $2; + if ( defined($1) ) { + $filename = $1; + $filename =~ s/\\(['\\])/$1/g; + } + next if (not defined($filename) or not $filename); + push @skip, _macify($filename); + } + close M; + return sub {0} unless (scalar @skip > 0); + + my $opts = $Is_VMS_mode ? '(?i)' : ''; + + # Make sure each entry is isolated in its own parentheses, in case + # any of them contain alternations + my $regex = join '|', map "(?:$_)", @skip; + + return sub { $_[0] =~ qr{$opts$regex} }; + } + + # checks for the special directives + # #!include_default + # #!include /path/to/some/manifest.skip + # in a custom MANIFEST.SKIP for, for including + # the content of, respectively, the default MANIFEST.SKIP + # and an external manifest.skip file + sub _check_mskip_directives { + my $mfile = shift; + local (*M, $_); + my @lines = (); + my $flag = 0; + unless (open M, "< $mfile") { + warn "Problem opening $mfile: $!"; + return; + } + while () { + if (/^#!include_default\s*$/) { + if (my @default = _include_mskip_file()) { + push @lines, @default; + warn "Debug: Including default MANIFEST.SKIP\n" if $Debug; + $flag++; + } + next; + } + if (/^#!include\s+(.*)\s*$/) { + my $external_file = $1; + if (my @external = _include_mskip_file($external_file)) { + push @lines, @external; + warn "Debug: Including external $external_file\n" if $Debug; + $flag++; + } + next; + } + push @lines, $_; + } + close M; + return unless $flag; + my $bakbase = $mfile; + $bakbase =~ s/\./_/g if $Is_VMS_nodot; # avoid double dots + rename $mfile, "$bakbase.bak"; + warn "Debug: Saving original $mfile as $bakbase.bak\n" if $Debug; + unless (open M, "> $mfile") { + warn "Problem opening $mfile: $!"; + return; + } + binmode M, ':raw'; + print M $_ for (@lines); + close M; + return; + } + + # returns an array containing the lines of an external + # manifest.skip file, if given, or $DEFAULT_MSKIP + sub _include_mskip_file { + my $mskip = shift || $DEFAULT_MSKIP; + unless (-f $mskip) { + warn qq{Included file "$mskip" not found - skipping}; + return; + } + local (*M, $_); + unless (open M, "< $mskip") { + warn "Problem opening $mskip: $!"; + return; + } + my @lines = (); + push @lines, "\n#!start included $mskip\n"; + push @lines, $_ while ; + close M; + push @lines, "#!end included $mskip\n\n"; + return @lines; + } + + =item manicopy + + manicopy(\%src, $dest_dir); + manicopy(\%src, $dest_dir, $how); + + Copies the files that are the keys in %src to the $dest_dir. %src is + typically returned by the maniread() function. + + manicopy( maniread(), $dest_dir ); + + This function is useful for producing a directory tree identical to the + intended distribution tree. + + $how can be used to specify a different methods of "copying". Valid + values are C, which actually copies the files, C which creates + hard links, and C which mostly links the files but copies any + symbolic link to make a tree without any symbolic link. C is the + default. + + =cut + + sub manicopy { + my($read,$target,$how)=@_; + croak "manicopy() called without target argument" unless defined $target; + $how ||= 'cp'; + require File::Path; + require File::Basename; + + $target = VMS::Filespec::unixify($target) if $Is_VMS_mode; + File::Path::mkpath([ $target ],! $Quiet,$Is_VMS ? undef : 0755); + foreach my $file (keys %$read){ + if ($Is_MacOS) { + if ($file =~ m!:!) { + my $dir = _maccat($target, $file); + $dir =~ s/[^:]+$//; + File::Path::mkpath($dir,1,0755); + } + cp_if_diff($file, _maccat($target, $file), $how); + } else { + $file = VMS::Filespec::unixify($file) if $Is_VMS_mode; + if ($file =~ m!/!) { # Ilya, that hurts, I fear, or maybe not? + my $dir = File::Basename::dirname($file); + $dir = VMS::Filespec::unixify($dir) if $Is_VMS_mode; + File::Path::mkpath(["$target/$dir"],! $Quiet,$Is_VMS ? undef : 0755); + } + cp_if_diff($file, "$target/$file", $how); + } + } + } + + sub cp_if_diff { + my($from, $to, $how)=@_; + if (! -f $from) { + carp "$from not found"; + return; + } + my($diff) = 0; + local(*F,*T); + open(F,"< $from\0") or die "Can't read $from: $!\n"; + if (open(T,"< $to\0")) { + local $_; + while () { $diff++,last if $_ ne ; } + $diff++ unless eof(T); + close T; + } + else { $diff++; } + close F; + if ($diff) { + if (-e $to) { + unlink($to) or confess "unlink $to: $!"; + } + STRICT_SWITCH: { + best($from,$to), last STRICT_SWITCH if $how eq 'best'; + cp($from,$to), last STRICT_SWITCH if $how eq 'cp'; + ln($from,$to), last STRICT_SWITCH if $how eq 'ln'; + croak("ExtUtils::Manifest::cp_if_diff " . + "called with illegal how argument [$how]. " . + "Legal values are 'best', 'cp', and 'ln'."); + } + } + } + + sub cp { + my ($srcFile, $dstFile) = @_; + my ($access,$mod) = (stat $srcFile)[8,9]; + + copy($srcFile,$dstFile); + utime $access, $mod + ($Is_VMS ? 1 : 0), $dstFile; + _manicopy_chmod($srcFile, $dstFile); + } + + + sub ln { + my ($srcFile, $dstFile) = @_; + # Fix-me - VMS can support links. + return &cp if $Is_VMS or ($^O eq 'MSWin32' and Win32::IsWin95()); + link($srcFile, $dstFile); + + unless( _manicopy_chmod($srcFile, $dstFile) ) { + unlink $dstFile; + return; + } + 1; + } + + # 1) Strip off all group and world permissions. + # 2) Let everyone read it. + # 3) If the owner can execute it, everyone can. + sub _manicopy_chmod { + my($srcFile, $dstFile) = @_; + + my $perm = 0444 | (stat $srcFile)[2] & 0700; + chmod( $perm | ( $perm & 0100 ? 0111 : 0 ), $dstFile ); + } + + # Files that are often modified in the distdir. Don't hard link them. + my @Exceptions = qw(MANIFEST META.yml SIGNATURE); + sub best { + my ($srcFile, $dstFile) = @_; + + my $is_exception = grep $srcFile =~ /$_/, @Exceptions; + if ($is_exception or !$Config{d_link} or -l $srcFile) { + cp($srcFile, $dstFile); + } else { + ln($srcFile, $dstFile) or cp($srcFile, $dstFile); + } + } + + sub _macify { + my($file) = @_; + + return $file unless $Is_MacOS; + + $file =~ s|^\./||; + if ($file =~ m|/|) { + $file =~ s|/+|:|g; + $file = ":$file"; + } + + $file; + } + + sub _maccat { + my($f1, $f2) = @_; + + return "$f1/$f2" unless $Is_MacOS; + + $f1 .= ":$f2"; + $f1 =~ s/([^:]:):/$1/g; + return $f1; + } + + sub _unmacify { + my($file) = @_; + + return $file unless $Is_MacOS; + + $file =~ s|^:||; + $file =~ s|([/ \n])|sprintf("\\%03o", unpack("c", $1))|ge; + $file =~ y|:|/|; + + $file; + } + + + =item maniadd + + maniadd({ $file => $comment, ...}); + + Adds an entry to an existing F unless its already there. + + $file will be normalized (ie. Unixified). B + + =cut + + sub maniadd { + my($additions) = shift; + + _normalize($additions); + _fix_manifest($MANIFEST); + + my $manifest = maniread(); + my @needed = grep { !exists $manifest->{$_} } keys %$additions; + return 1 unless @needed; + + open(MANIFEST, ">>$MANIFEST") or + die "maniadd() could not open $MANIFEST: $!"; + binmode MANIFEST, ':raw'; + + foreach my $file (_sort @needed) { + my $comment = $additions->{$file} || ''; + if ($file =~ /\s/) { + $file =~ s/([\\'])/\\$1/g; + $file = "'$file'"; + } + printf MANIFEST "%-40s %s\n", $file, $comment; + } + close MANIFEST or die "Error closing $MANIFEST: $!"; + + return 1; + } + + + # Make sure this MANIFEST is consistently written with native + # newlines and has a terminal newline. + sub _fix_manifest { + my $manifest_file = shift; + + open MANIFEST, $MANIFEST or die "Could not open $MANIFEST: $!"; + local $/; + my @manifest = split /(\015\012|\012|\015)/, , -1; + close MANIFEST; + my $must_rewrite = ""; + if ($manifest[-1] eq ""){ + # sane case: last line had a terminal newline + pop @manifest; + for (my $i=1; $i<=$#manifest; $i+=2) { + unless ($manifest[$i] eq "\n") { + $must_rewrite = "not a newline at pos $i"; + last; + } + } + } else { + $must_rewrite = "last line without newline"; + } + + if ( $must_rewrite ) { + 1 while unlink $MANIFEST; # avoid multiple versions on VMS + open MANIFEST, ">", $MANIFEST or die "(must_rewrite=$must_rewrite) Could not open >$MANIFEST: $!"; + binmode MANIFEST, ':raw'; + for (my $i=0; $i<=$#manifest; $i+=2) { + print MANIFEST "$manifest[$i]\n"; + } + close MANIFEST or die "could not write $MANIFEST: $!"; + } + } + + + # UNIMPLEMENTED + sub _normalize { + return; + } + + + =back + + =head2 MANIFEST + + A list of files in the distribution, one file per line. The MANIFEST + always uses Unix filepath conventions even if you're not on Unix. This + means F style not F. + + Anything between white space and an end of line within a C + file is considered to be a comment. Any line beginning with # is also + a comment. Beginning with ExtUtils::Manifest 1.52, a filename may + contain whitespace characters if it is enclosed in single quotes; single + quotes or backslashes in that filename must be backslash-escaped. + + # this a comment + some/file + some/other/file comment about some/file + 'some/third file' comment + + + =head2 MANIFEST.SKIP + + The file MANIFEST.SKIP may contain regular expressions of files that + should be ignored by mkmanifest() and filecheck(). The regular + expressions should appear one on each line. Blank lines and lines + which start with C<#> are skipped. Use C<\#> if you need a regular + expression to start with a C<#>. + + For example: + + # Version control files and dirs. + \bRCS\b + \bCVS\b + ,v$ + \B\.svn\b + + # Makemaker generated files and dirs. + ^MANIFEST\. + ^Makefile$ + ^blib/ + ^MakeMaker-\d + + # Temp, old and emacs backup files. + ~$ + \.old$ + ^#.*#$ + ^\.# + + If no MANIFEST.SKIP file is found, a default set of skips will be + used, similar to the example above. If you want nothing skipped, + simply make an empty MANIFEST.SKIP file. + + In one's own MANIFEST.SKIP file, certain directives + can be used to include the contents of other MANIFEST.SKIP + files. At present two such directives are recognized. + + =over 4 + + =item #!include_default + + This inserts the contents of the default MANIFEST.SKIP file + + =item #!include /Path/to/another/manifest.skip + + This inserts the contents of the specified external file + + =back + + The included contents will be inserted into the MANIFEST.SKIP + file in between I<#!start included /path/to/manifest.skip> + and I<#!end included /path/to/manifest.skip> markers. + The original MANIFEST.SKIP is saved as MANIFEST.SKIP.bak. + + =head2 EXPORT_OK + + C<&mkmanifest>, C<&manicheck>, C<&filecheck>, C<&fullcheck>, + C<&maniread>, and C<&manicopy> are exportable. + + =head2 GLOBAL VARIABLES + + C<$ExtUtils::Manifest::MANIFEST> defaults to C. Changing it + results in both a different C and a different + C file. This is useful if you want to maintain + different distributions for different audiences (say a user version + and a developer version including RCS). + + C<$ExtUtils::Manifest::Quiet> defaults to 0. If set to a true value, + all functions act silently. + + C<$ExtUtils::Manifest::Debug> defaults to 0. If set to a true value, + or if PERL_MM_MANIFEST_DEBUG is true, debugging output will be + produced. + + =head1 DIAGNOSTICS + + All diagnostic output is sent to C. + + =over 4 + + =item C I + + is reported if a file is found which is not in C. + + =item C I + + is reported if a file is skipped due to an entry in C. + + =item C I + + is reported if a file mentioned in a C file does not + exist. + + =item C I<$!> + + is reported if C could not be opened. + + =item C I + + is reported by mkmanifest() if $Verbose is set and a file is added + to MANIFEST. $Verbose is set to 1 by default. + + =back + + =head1 ENVIRONMENT + + =over 4 + + =item B + + Turns on debugging + + =back + + =head1 SEE ALSO + + L which has handy targets for most of the functionality. + + =head1 AUTHOR + + Andreas Koenig C + + Currently maintained by the Perl Toolchain Gang. + + =head1 COPYRIGHT AND LICENSE + + This software is copyright (c) 1996- by Andreas Koenig. + + This is free software; you can redistribute it and/or modify it under + the same terms as the Perl 5 programming language system itself. + + =cut + + 1; +EXTUTILS_MANIFEST + +$fatpacked{"ExtUtils/Mkbootstrap.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MKBOOTSTRAP'; + package ExtUtils::Mkbootstrap; + + # There's just too much Dynaloader incest here to turn on strict vars. + use strict 'refs'; + + our $VERSION = '7.06'; + $VERSION = eval $VERSION; + + require Exporter; + our @ISA = ('Exporter'); + our @EXPORT = ('&Mkbootstrap'); + + use Config; + + our $Verbose = 0; + + + sub Mkbootstrap { + my($baseext, @bsloadlibs)=@_; + @bsloadlibs = grep($_, @bsloadlibs); # strip empty libs + + print " bsloadlibs=@bsloadlibs\n" if $Verbose; + + # We need DynaLoader here because we and/or the *_BS file may + # call dl_findfile(). We don't say `use' here because when + # first building perl extensions the DynaLoader will not have + # been built when MakeMaker gets first used. + require DynaLoader; + + rename "$baseext.bs", "$baseext.bso" + if -s "$baseext.bs"; + + if (-f "${baseext}_BS"){ + $_ = "${baseext}_BS"; + package DynaLoader; # execute code as if in DynaLoader + local($osname, $dlsrc) = (); # avoid warnings + ($osname, $dlsrc) = @Config::Config{qw(osname dlsrc)}; + $bscode = ""; + unshift @INC, "."; + require $_; + shift @INC; + } + + if ($Config{'dlsrc'} =~ /^dl_dld/){ + package DynaLoader; + push(@dl_resolve_using, dl_findfile('-lc')); + } + + my(@all) = (@bsloadlibs, @DynaLoader::dl_resolve_using); + my($method) = ''; + if (@all || (defined $DynaLoader::bscode && length $DynaLoader::bscode)){ + open my $bs, ">", "$baseext.bs" + or die "Unable to open $baseext.bs: $!"; + print "Writing $baseext.bs\n"; + print " containing: @all" if $Verbose; + print $bs "# $baseext DynaLoader bootstrap file for $^O architecture.\n"; + print $bs "# Do not edit this file, changes will be lost.\n"; + print $bs "# This file was automatically generated by the\n"; + print $bs "# Mkbootstrap routine in ExtUtils::Mkbootstrap (v$VERSION).\n"; + if (@all) { + print $bs "\@DynaLoader::dl_resolve_using = "; + # If @all contains names in the form -lxxx or -Lxxx then it's asking for + # runtime library location so we automatically add a call to dl_findfile() + if (" @all" =~ m/ -[lLR]/){ + print $bs " dl_findfile(qw(\n @all\n ));\n"; + } else { + print $bs " qw(@all);\n"; + } + } + # write extra code if *_BS says so + print $bs $DynaLoader::bscode if $DynaLoader::bscode; + print $bs "\n1;\n"; + close $bs; + } + } + + 1; + + __END__ + + =head1 NAME + + ExtUtils::Mkbootstrap - make a bootstrap file for use by DynaLoader + + =head1 SYNOPSIS + + C + + =head1 DESCRIPTION + + Mkbootstrap typically gets called from an extension Makefile. + + There is no C<*.bs> file supplied with the extension. Instead, there may + be a C<*_BS> file which has code for the special cases, like posix for + berkeley db on the NeXT. + + This file will get parsed, and produce a maybe empty + C<@DynaLoader::dl_resolve_using> array for the current architecture. + That will be extended by $BSLOADLIBS, which was computed by + ExtUtils::Liblist::ext(). If this array still is empty, we do nothing, + else we write a .bs file with an C<@DynaLoader::dl_resolve_using> + array. + + The C<*_BS> file can put some code into the generated C<*.bs> file by + placing it in C<$bscode>. This is a handy 'escape' mechanism that may + prove useful in complex situations. + + If @DynaLoader::dl_resolve_using contains C<-L*> or C<-l*> entries then + Mkbootstrap will automatically add a dl_findfile() call to the + generated C<*.bs> file. + + =cut +EXTUTILS_MKBOOTSTRAP + +$fatpacked{"ExtUtils/Mksymlists.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_MKSYMLISTS'; + package ExtUtils::Mksymlists; + + use 5.006; + use strict qw[ subs refs ]; + # no strict 'vars'; # until filehandles are exempted + + use Carp; + use Exporter; + use Config; + + our @ISA = qw(Exporter); + our @EXPORT = qw(&Mksymlists); + our $VERSION = '7.06'; + $VERSION = eval $VERSION; + + sub Mksymlists { + my(%spec) = @_; + my($osname) = $^O; + + croak("Insufficient information specified to Mksymlists") + unless ( $spec{NAME} or + ($spec{FILE} and ($spec{DL_FUNCS} or $spec{FUNCLIST})) ); + + $spec{DL_VARS} = [] unless $spec{DL_VARS}; + ($spec{FILE} = $spec{NAME}) =~ s/.*::// unless $spec{FILE}; + $spec{FUNCLIST} = [] unless $spec{FUNCLIST}; + $spec{DL_FUNCS} = { $spec{NAME} => [] } + unless ( ($spec{DL_FUNCS} and keys %{$spec{DL_FUNCS}}) or + @{$spec{FUNCLIST}}); + if (defined $spec{DL_FUNCS}) { + foreach my $package (sort keys %{$spec{DL_FUNCS}}) { + my($packprefix,$bootseen); + ($packprefix = $package) =~ s/\W/_/g; + foreach my $sym (@{$spec{DL_FUNCS}->{$package}}) { + if ($sym =~ /^boot_/) { + push(@{$spec{FUNCLIST}},$sym); + $bootseen++; + } + else { + push(@{$spec{FUNCLIST}},"XS_${packprefix}_$sym"); + } + } + push(@{$spec{FUNCLIST}},"boot_$packprefix") unless $bootseen; + } + } + + # We'll need this if we ever add any OS which uses mod2fname + # not as pseudo-builtin. + # require DynaLoader; + if (defined &DynaLoader::mod2fname and not $spec{DLBASE}) { + $spec{DLBASE} = DynaLoader::mod2fname([ split(/::/,$spec{NAME}) ]); + } + + if ($osname eq 'aix') { _write_aix(\%spec); } + elsif ($osname eq 'MacOS'){ _write_aix(\%spec) } + elsif ($osname eq 'VMS') { _write_vms(\%spec) } + elsif ($osname eq 'os2') { _write_os2(\%spec) } + elsif ($osname eq 'MSWin32') { _write_win32(\%spec) } + else { + croak("Don't know how to create linker option file for $osname\n"); + } + } + + + sub _write_aix { + my($data) = @_; + + rename "$data->{FILE}.exp", "$data->{FILE}.exp_old"; + + open( my $exp, ">", "$data->{FILE}.exp") + or croak("Can't create $data->{FILE}.exp: $!\n"); + print $exp join("\n",@{$data->{DL_VARS}}, "\n") if @{$data->{DL_VARS}}; + print $exp join("\n",@{$data->{FUNCLIST}}, "\n") if @{$data->{FUNCLIST}}; + close $exp; + } + + + sub _write_os2 { + my($data) = @_; + require Config; + my $threaded = ($Config::Config{archname} =~ /-thread/ ? " threaded" : ""); + + if (not $data->{DLBASE}) { + ($data->{DLBASE} = $data->{NAME}) =~ s/.*:://; + $data->{DLBASE} = substr($data->{DLBASE},0,7) . '_'; + } + my $distname = $data->{DISTNAME} || $data->{NAME}; + $distname = "Distribution $distname"; + my $patchlevel = " pl$Config{perl_patchlevel}" || ''; + my $comment = sprintf "Perl (v%s%s%s) module %s", + $Config::Config{version}, $threaded, $patchlevel, $data->{NAME}; + chomp $comment; + if ($data->{INSTALLDIRS} and $data->{INSTALLDIRS} eq 'perl') { + $distname = 'perl5-porters@perl.org'; + $comment = "Core $comment"; + } + $comment = "$comment (Perl-config: $Config{config_args})"; + $comment = substr($comment, 0, 200) . "...)" if length $comment > 203; + rename "$data->{FILE}.def", "$data->{FILE}_def.old"; + + open(my $def, ">", "$data->{FILE}.def") + or croak("Can't create $data->{FILE}.def: $!\n"); + print $def "LIBRARY '$data->{DLBASE}' INITINSTANCE TERMINSTANCE\n"; + print $def "DESCRIPTION '\@#$distname:$data->{VERSION}#\@ $comment'\n"; + print $def "CODE LOADONCALL\n"; + print $def "DATA LOADONCALL NONSHARED MULTIPLE\n"; + print $def "EXPORTS\n "; + print $def join("\n ",@{$data->{DL_VARS}}, "\n") if @{$data->{DL_VARS}}; + print $def join("\n ",@{$data->{FUNCLIST}}, "\n") if @{$data->{FUNCLIST}}; + _print_imports($def, $data); + close $def; + } + + sub _print_imports { + my ($def, $data)= @_; + my $imports= $data->{IMPORTS} + or return; + if ( keys %$imports ) { + print $def "IMPORTS\n"; + foreach my $name (sort keys %$imports) { + print $def " $name=$imports->{$name}\n"; + } + } + } + + sub _write_win32 { + my($data) = @_; + + require Config; + if (not $data->{DLBASE}) { + ($data->{DLBASE} = $data->{NAME}) =~ s/.*:://; + $data->{DLBASE} = substr($data->{DLBASE},0,7) . '_'; + } + rename "$data->{FILE}.def", "$data->{FILE}_def.old"; + + open( my $def, ">", "$data->{FILE}.def" ) + or croak("Can't create $data->{FILE}.def: $!\n"); + # put library name in quotes (it could be a keyword, like 'Alias') + if ($Config::Config{'cc'} !~ /\bgcc/i) { + print $def "LIBRARY \"$data->{DLBASE}\"\n"; + } + print $def "EXPORTS\n "; + my @syms; + # Export public symbols both with and without underscores to + # ensure compatibility between DLLs from Borland C and Visual C + # NOTE: DynaLoader itself only uses the names without underscores, + # so this is only to cover the case when the extension DLL may be + # linked to directly from C. GSAR 97-07-10 + + #bcc dropped in 5.16, so dont create useless extra symbols for export table + unless($] >= 5.016) { + if ($Config::Config{'cc'} =~ /^bcc/i) { + push @syms, "_$_", "$_ = _$_" + for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}}); + } + else { + push @syms, "$_", "_$_ = $_" + for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}}); + } + } else { + push @syms, "$_" + for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}}); + } + print $def join("\n ",@syms, "\n") if @syms; + _print_imports($def, $data); + close $def; + } + + + sub _write_vms { + my($data) = @_; + + require Config; # a reminder for once we do $^O + require ExtUtils::XSSymSet; + + my($isvax) = $Config::Config{'archname'} =~ /VAX/i; + my($set) = new ExtUtils::XSSymSet; + + rename "$data->{FILE}.opt", "$data->{FILE}.opt_old"; + + open(my $opt,">", "$data->{FILE}.opt") + or croak("Can't create $data->{FILE}.opt: $!\n"); + + # Options file declaring universal symbols + # Used when linking shareable image for dynamic extension, + # or when linking PerlShr into which we've added this package + # as a static extension + # We don't do anything to preserve order, so we won't relax + # the GSMATCH criteria for a dynamic extension + + print $opt "case_sensitive=yes\n" + if $Config::Config{d_vms_case_sensitive_symbols}; + + foreach my $sym (@{$data->{FUNCLIST}}) { + my $safe = $set->addsym($sym); + if ($isvax) { print $opt "UNIVERSAL=$safe\n" } + else { print $opt "SYMBOL_VECTOR=($safe=PROCEDURE)\n"; } + } + + foreach my $sym (@{$data->{DL_VARS}}) { + my $safe = $set->addsym($sym); + print $opt "PSECT_ATTR=${sym},PIC,OVR,RD,NOEXE,WRT,NOSHR\n"; + if ($isvax) { print $opt "UNIVERSAL=$safe\n" } + else { print $opt "SYMBOL_VECTOR=($safe=DATA)\n"; } + } + + close $opt; + } + + 1; + + __END__ + + =head1 NAME + + ExtUtils::Mksymlists - write linker options files for dynamic extension + + =head1 SYNOPSIS + + use ExtUtils::Mksymlists; + Mksymlists( NAME => $name , + DL_VARS => [ $var1, $var2, $var3 ], + DL_FUNCS => { $pkg1 => [ $func1, $func2 ], + $pkg2 => [ $func3 ] ); + + =head1 DESCRIPTION + + C produces files used by the linker under some OSs + during the creation of shared libraries for dynamic extensions. It is + normally called from a MakeMaker-generated Makefile when the extension + is built. The linker option file is generated by calling the function + C, which is exported by default from C. + It takes one argument, a list of key-value pairs, in which the following + keys are recognized: + + =over 4 + + =item DLBASE + + This item specifies the name by which the linker knows the + extension, which may be different from the name of the + extension itself (for instance, some linkers add an '_' to the + name of the extension). If it is not specified, it is derived + from the NAME attribute. It is presently used only by OS2 and Win32. + + =item DL_FUNCS + + This is identical to the DL_FUNCS attribute available via MakeMaker, + from which it is usually taken. Its value is a reference to an + associative array, in which each key is the name of a package, and + each value is an a reference to an array of function names which + should be exported by the extension. For instance, one might say + C { Homer::Iliad =E [ qw(trojans greeks) ], + Homer::Odyssey =E [ qw(travellers family suitors) ] }>. The + function names should be identical to those in the XSUB code; + C will alter the names written to the linker option + file to match the changes made by F. In addition, if + none of the functions in a list begin with the string B, + C will add a bootstrap function for that package, + just as xsubpp does. (If a BpkgE> function is + present in the list, it is passed through unchanged.) If + DL_FUNCS is not specified, it defaults to the bootstrap + function for the extension specified in NAME. + + =item DL_VARS + + This is identical to the DL_VARS attribute available via MakeMaker, + and, like DL_FUNCS, it is usually specified via MakeMaker. Its + value is a reference to an array of variable names which should + be exported by the extension. + + =item FILE + + This key can be used to specify the name of the linker option file + (minus the OS-specific extension), if for some reason you do not + want to use the default value, which is the last word of the NAME + attribute (I for C, FILE defaults to C). + + =item FUNCLIST + + This provides an alternate means to specify function names to be + exported from the extension. Its value is a reference to an + array of function names to be exported by the extension. These + names are passed through unaltered to the linker options file. + Specifying a value for the FUNCLIST attribute suppresses automatic + generation of the bootstrap function for the package. To still create + the bootstrap name you have to specify the package name in the + DL_FUNCS hash: + + Mksymlists( NAME => $name , + FUNCLIST => [ $func1, $func2 ], + DL_FUNCS => { $pkg => [] } ); + + + =item IMPORTS + + This attribute is used to specify names to be imported into the + extension. It is currently only used by OS/2 and Win32. + + =item NAME + + This gives the name of the extension (I C) for which + the linker option file will be produced. + + =back + + When calling C, one should always specify the NAME + attribute. In most cases, this is all that's necessary. In + the case of unusual extensions, however, the other attributes + can be used to provide additional information to the linker. + + =head1 AUTHOR + + Charles Bailey Ibailey@newman.upenn.eduE> + + =head1 REVISION + + Last revised 14-Feb-1996, for Perl 5.002. +EXTUTILS_MKSYMLISTS + +$fatpacked{"ExtUtils/testlib.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_TESTLIB'; + package ExtUtils::testlib; + + use strict; + use warnings; + + our $VERSION = '7.06'; + $VERSION = eval $VERSION; + + use Cwd; + use File::Spec; + + # So the tests can chdir around and not break @INC. + # We use getcwd() because otherwise rel2abs will blow up under taint + # mode pre-5.8. We detaint is so @INC won't be tainted. This is + # no worse, and probably better, than just shoving an untainted, + # relative "blib/lib" onto @INC. + my $cwd; + BEGIN { + ($cwd) = getcwd() =~ /(.*)/; + } + use lib map { File::Spec->rel2abs($_, $cwd) } qw(blib/arch blib/lib); + 1; + __END__ + + =head1 NAME + + ExtUtils::testlib - add blib/* directories to @INC + + =head1 SYNOPSIS + + use ExtUtils::testlib; + + =head1 DESCRIPTION + + After an extension has been built and before it is installed it may be + desirable to test it bypassing C. By adding + + use ExtUtils::testlib; + + to a test program the intermediate directories used by C are + added to @INC. + +EXTUTILS_TESTLIB + +$fatpacked{"Getopt/Long.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'GETOPT_LONG'; + #! perl + + # Getopt::Long.pm -- Universal options parsing + # Author : Johan Vromans + # Created On : Tue Sep 11 15:00:12 1990 + # Last Modified By: Johan Vromans + # Last Modified On: Tue Jun 16 15:28:03 2015 + # Update Count : 1695 + # Status : Released + + ################ Module Preamble ################ + + package Getopt::Long; + + use 5.004; + + use strict; + + use vars qw($VERSION); + $VERSION = 2.47; + # For testing versions only. + use vars qw($VERSION_STRING); + $VERSION_STRING = "2.47"; + + use Exporter; + use vars qw(@ISA @EXPORT @EXPORT_OK); + @ISA = qw(Exporter); + + # Exported subroutines. + sub GetOptions(@); # always + sub GetOptionsFromArray(@); # on demand + sub GetOptionsFromString(@); # on demand + sub Configure(@); # on demand + sub HelpMessage(@); # on demand + sub VersionMessage(@); # in demand + + BEGIN { + # Init immediately so their contents can be used in the 'use vars' below. + @EXPORT = qw(&GetOptions $REQUIRE_ORDER $PERMUTE $RETURN_IN_ORDER); + @EXPORT_OK = qw(&HelpMessage &VersionMessage &Configure + &GetOptionsFromArray &GetOptionsFromString); + } + + # User visible variables. + use vars @EXPORT, @EXPORT_OK; + use vars qw($error $debug $major_version $minor_version); + # Deprecated visible variables. + use vars qw($autoabbrev $getopt_compat $ignorecase $bundling $order + $passthrough); + # Official invisible variables. + use vars qw($genprefix $caller $gnu_compat $auto_help $auto_version $longprefix); + + # Really invisible variables. + my $bundling_values; + + # Public subroutines. + sub config(@); # deprecated name + + # Private subroutines. + sub ConfigDefaults(); + sub ParseOptionSpec($$); + sub OptCtl($); + sub FindOption($$$$$); + sub ValidValue ($$$$$); + + ################ Local Variables ################ + + # $requested_version holds the version that was mentioned in the 'use' + # or 'require', if any. It can be used to enable or disable specific + # features. + my $requested_version = 0; + + ################ Resident subroutines ################ + + sub ConfigDefaults() { + # Handle POSIX compliancy. + if ( defined $ENV{"POSIXLY_CORRECT"} ) { + $genprefix = "(--|-)"; + $autoabbrev = 0; # no automatic abbrev of options + $bundling = 0; # no bundling of single letter switches + $getopt_compat = 0; # disallow '+' to start options + $order = $REQUIRE_ORDER; + } + else { + $genprefix = "(--|-|\\+)"; + $autoabbrev = 1; # automatic abbrev of options + $bundling = 0; # bundling off by default + $getopt_compat = 1; # allow '+' to start options + $order = $PERMUTE; + } + # Other configurable settings. + $debug = 0; # for debugging + $error = 0; # error tally + $ignorecase = 1; # ignore case when matching options + $passthrough = 0; # leave unrecognized options alone + $gnu_compat = 0; # require --opt=val if value is optional + $longprefix = "(--)"; # what does a long prefix look like + $bundling_values = 0; # no bundling of values + } + + # Override import. + sub import { + my $pkg = shift; # package + my @syms = (); # symbols to import + my @config = (); # configuration + my $dest = \@syms; # symbols first + for ( @_ ) { + if ( $_ eq ':config' ) { + $dest = \@config; # config next + next; + } + push(@$dest, $_); # push + } + # Hide one level and call super. + local $Exporter::ExportLevel = 1; + push(@syms, qw(&GetOptions)) if @syms; # always export GetOptions + $requested_version = 0; + $pkg->SUPER::import(@syms); + # And configure. + Configure(@config) if @config; + } + + ################ Initialization ################ + + # Values for $order. See GNU getopt.c for details. + ($REQUIRE_ORDER, $PERMUTE, $RETURN_IN_ORDER) = (0..2); + # Version major/minor numbers. + ($major_version, $minor_version) = $VERSION =~ /^(\d+)\.(\d+)/; + + ConfigDefaults(); + + ################ OO Interface ################ + + package Getopt::Long::Parser; + + # Store a copy of the default configuration. Since ConfigDefaults has + # just been called, what we get from Configure is the default. + my $default_config = do { + Getopt::Long::Configure () + }; + + sub new { + my $that = shift; + my $class = ref($that) || $that; + my %atts = @_; + + # Register the callers package. + my $self = { caller_pkg => (caller)[0] }; + + bless ($self, $class); + + # Process config attributes. + if ( defined $atts{config} ) { + my $save = Getopt::Long::Configure ($default_config, @{$atts{config}}); + $self->{settings} = Getopt::Long::Configure ($save); + delete ($atts{config}); + } + # Else use default config. + else { + $self->{settings} = $default_config; + } + + if ( %atts ) { # Oops + die(__PACKAGE__.": unhandled attributes: ". + join(" ", sort(keys(%atts)))."\n"); + } + + $self; + } + + sub configure { + my ($self) = shift; + + # Restore settings, merge new settings in. + my $save = Getopt::Long::Configure ($self->{settings}, @_); + + # Restore orig config and save the new config. + $self->{settings} = Getopt::Long::Configure ($save); + } + + sub getoptions { + my ($self) = shift; + + return $self->getoptionsfromarray(\@ARGV, @_); + } + + sub getoptionsfromarray { + my ($self) = shift; + + # Restore config settings. + my $save = Getopt::Long::Configure ($self->{settings}); + + # Call main routine. + my $ret = 0; + $Getopt::Long::caller = $self->{caller_pkg}; + + eval { + # Locally set exception handler to default, otherwise it will + # be called implicitly here, and again explicitly when we try + # to deliver the messages. + local ($SIG{__DIE__}) = 'DEFAULT'; + $ret = Getopt::Long::GetOptionsFromArray (@_); + }; + + # Restore saved settings. + Getopt::Long::Configure ($save); + + # Handle errors and return value. + die ($@) if $@; + return $ret; + } + + package Getopt::Long; + + ################ Back to Normal ################ + + # Indices in option control info. + # Note that ParseOptions uses the fields directly. Search for 'hard-wired'. + use constant CTL_TYPE => 0; + #use constant CTL_TYPE_FLAG => ''; + #use constant CTL_TYPE_NEG => '!'; + #use constant CTL_TYPE_INCR => '+'; + #use constant CTL_TYPE_INT => 'i'; + #use constant CTL_TYPE_INTINC => 'I'; + #use constant CTL_TYPE_XINT => 'o'; + #use constant CTL_TYPE_FLOAT => 'f'; + #use constant CTL_TYPE_STRING => 's'; + + use constant CTL_CNAME => 1; + + use constant CTL_DEFAULT => 2; + + use constant CTL_DEST => 3; + use constant CTL_DEST_SCALAR => 0; + use constant CTL_DEST_ARRAY => 1; + use constant CTL_DEST_HASH => 2; + use constant CTL_DEST_CODE => 3; + + use constant CTL_AMIN => 4; + use constant CTL_AMAX => 5; + + # FFU. + #use constant CTL_RANGE => ; + #use constant CTL_REPEAT => ; + + # Rather liberal patterns to match numbers. + use constant PAT_INT => "[-+]?_*[0-9][0-9_]*"; + use constant PAT_XINT => + "(?:". + "[-+]?_*[1-9][0-9_]*". + "|". + "0x_*[0-9a-f][0-9a-f_]*". + "|". + "0b_*[01][01_]*". + "|". + "0[0-7_]*". + ")"; + use constant PAT_FLOAT => + "[-+]?". # optional sign + "(?=[0-9.])". # must start with digit or dec.point + "[0-9_]*". # digits before the dec.point + "(\.[0-9_]+)?". # optional fraction + "([eE][-+]?[0-9_]+)?"; # optional exponent + + sub GetOptions(@) { + # Shift in default array. + unshift(@_, \@ARGV); + # Try to keep caller() and Carp consistent. + goto &GetOptionsFromArray; + } + + sub GetOptionsFromString(@) { + my ($string) = shift; + require Text::ParseWords; + my $args = [ Text::ParseWords::shellwords($string) ]; + $caller ||= (caller)[0]; # current context + my $ret = GetOptionsFromArray($args, @_); + return ( $ret, $args ) if wantarray; + if ( @$args ) { + $ret = 0; + warn("GetOptionsFromString: Excess data \"@$args\" in string \"$string\"\n"); + } + $ret; + } + + sub GetOptionsFromArray(@) { + + my ($argv, @optionlist) = @_; # local copy of the option descriptions + my $argend = '--'; # option list terminator + my %opctl = (); # table of option specs + my $pkg = $caller || (caller)[0]; # current context + # Needed if linkage is omitted. + my @ret = (); # accum for non-options + my %linkage; # linkage + my $userlinkage; # user supplied HASH + my $opt; # current option + my $prefix = $genprefix; # current prefix + + $error = ''; + + if ( $debug ) { + # Avoid some warnings if debugging. + local ($^W) = 0; + print STDERR + ("Getopt::Long $Getopt::Long::VERSION ", + "called from package \"$pkg\".", + "\n ", + "argv: ", + defined($argv) + ? UNIVERSAL::isa( $argv, 'ARRAY' ) ? "(@$argv)" : $argv + : "", + "\n ", + "autoabbrev=$autoabbrev,". + "bundling=$bundling,", + "bundling_values=$bundling_values,", + "getopt_compat=$getopt_compat,", + "gnu_compat=$gnu_compat,", + "order=$order,", + "\n ", + "ignorecase=$ignorecase,", + "requested_version=$requested_version,", + "passthrough=$passthrough,", + "genprefix=\"$genprefix\",", + "longprefix=\"$longprefix\".", + "\n"); + } + + # Check for ref HASH as first argument. + # First argument may be an object. It's OK to use this as long + # as it is really a hash underneath. + $userlinkage = undef; + if ( @optionlist && ref($optionlist[0]) and + UNIVERSAL::isa($optionlist[0],'HASH') ) { + $userlinkage = shift (@optionlist); + print STDERR ("=> user linkage: $userlinkage\n") if $debug; + } + + # See if the first element of the optionlist contains option + # starter characters. + # Be careful not to interpret '<>' as option starters. + if ( @optionlist && $optionlist[0] =~ /^\W+$/ + && !($optionlist[0] eq '<>' + && @optionlist > 0 + && ref($optionlist[1])) ) { + $prefix = shift (@optionlist); + # Turn into regexp. Needs to be parenthesized! + $prefix =~ s/(\W)/\\$1/g; + $prefix = "([" . $prefix . "])"; + print STDERR ("=> prefix=\"$prefix\"\n") if $debug; + } + + # Verify correctness of optionlist. + %opctl = (); + while ( @optionlist ) { + my $opt = shift (@optionlist); + + unless ( defined($opt) ) { + $error .= "Undefined argument in option spec\n"; + next; + } + + # Strip leading prefix so people can specify "--foo=i" if they like. + $opt = $+ if $opt =~ /^$prefix+(.*)$/s; + + if ( $opt eq '<>' ) { + if ( (defined $userlinkage) + && !(@optionlist > 0 && ref($optionlist[0])) + && (exists $userlinkage->{$opt}) + && ref($userlinkage->{$opt}) ) { + unshift (@optionlist, $userlinkage->{$opt}); + } + unless ( @optionlist > 0 + && ref($optionlist[0]) && ref($optionlist[0]) eq 'CODE' ) { + $error .= "Option spec <> requires a reference to a subroutine\n"; + # Kill the linkage (to avoid another error). + shift (@optionlist) + if @optionlist && ref($optionlist[0]); + next; + } + $linkage{'<>'} = shift (@optionlist); + next; + } + + # Parse option spec. + my ($name, $orig) = ParseOptionSpec ($opt, \%opctl); + unless ( defined $name ) { + # Failed. $orig contains the error message. Sorry for the abuse. + $error .= $orig; + # Kill the linkage (to avoid another error). + shift (@optionlist) + if @optionlist && ref($optionlist[0]); + next; + } + + # If no linkage is supplied in the @optionlist, copy it from + # the userlinkage if available. + if ( defined $userlinkage ) { + unless ( @optionlist > 0 && ref($optionlist[0]) ) { + if ( exists $userlinkage->{$orig} && + ref($userlinkage->{$orig}) ) { + print STDERR ("=> found userlinkage for \"$orig\": ", + "$userlinkage->{$orig}\n") + if $debug; + unshift (@optionlist, $userlinkage->{$orig}); + } + else { + # Do nothing. Being undefined will be handled later. + next; + } + } + } + + # Copy the linkage. If omitted, link to global variable. + if ( @optionlist > 0 && ref($optionlist[0]) ) { + print STDERR ("=> link \"$orig\" to $optionlist[0]\n") + if $debug; + my $rl = ref($linkage{$orig} = shift (@optionlist)); + + if ( $rl eq "ARRAY" ) { + $opctl{$name}[CTL_DEST] = CTL_DEST_ARRAY; + } + elsif ( $rl eq "HASH" ) { + $opctl{$name}[CTL_DEST] = CTL_DEST_HASH; + } + elsif ( $rl eq "SCALAR" || $rl eq "REF" ) { + # if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) { + # my $t = $linkage{$orig}; + # $$t = $linkage{$orig} = []; + # } + # elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) { + # } + # else { + # Ok. + # } + } + elsif ( $rl eq "CODE" ) { + # Ok. + } + else { + $error .= "Invalid option linkage for \"$opt\"\n"; + } + } + else { + # Link to global $opt_XXX variable. + # Make sure a valid perl identifier results. + my $ov = $orig; + $ov =~ s/\W/_/g; + if ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY ) { + print STDERR ("=> link \"$orig\" to \@$pkg","::opt_$ov\n") + if $debug; + eval ("\$linkage{\$orig} = \\\@".$pkg."::opt_$ov;"); + } + elsif ( $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) { + print STDERR ("=> link \"$orig\" to \%$pkg","::opt_$ov\n") + if $debug; + eval ("\$linkage{\$orig} = \\\%".$pkg."::opt_$ov;"); + } + else { + print STDERR ("=> link \"$orig\" to \$$pkg","::opt_$ov\n") + if $debug; + eval ("\$linkage{\$orig} = \\\$".$pkg."::opt_$ov;"); + } + } + + if ( $opctl{$name}[CTL_TYPE] eq 'I' + && ( $opctl{$name}[CTL_DEST] == CTL_DEST_ARRAY + || $opctl{$name}[CTL_DEST] == CTL_DEST_HASH ) + ) { + $error .= "Invalid option linkage for \"$opt\"\n"; + } + + } + + $error .= "GetOptionsFromArray: 1st parameter is not an array reference\n" + unless $argv && UNIVERSAL::isa( $argv, 'ARRAY' ); + + # Bail out if errors found. + die ($error) if $error; + $error = 0; + + # Supply --version and --help support, if needed and allowed. + if ( defined($auto_version) ? $auto_version : ($requested_version >= 2.3203) ) { + if ( !defined($opctl{version}) ) { + $opctl{version} = ['','version',0,CTL_DEST_CODE,undef]; + $linkage{version} = \&VersionMessage; + } + $auto_version = 1; + } + if ( defined($auto_help) ? $auto_help : ($requested_version >= 2.3203) ) { + if ( !defined($opctl{help}) && !defined($opctl{'?'}) ) { + $opctl{help} = $opctl{'?'} = ['','help',0,CTL_DEST_CODE,undef]; + $linkage{help} = \&HelpMessage; + } + $auto_help = 1; + } + + # Show the options tables if debugging. + if ( $debug ) { + my ($arrow, $k, $v); + $arrow = "=> "; + while ( ($k,$v) = each(%opctl) ) { + print STDERR ($arrow, "\$opctl{$k} = $v ", OptCtl($v), "\n"); + $arrow = " "; + } + } + + # Process argument list + my $goon = 1; + while ( $goon && @$argv > 0 ) { + + # Get next argument. + $opt = shift (@$argv); + print STDERR ("=> arg \"", $opt, "\"\n") if $debug; + + # Double dash is option list terminator. + if ( defined($opt) && $opt eq $argend ) { + push (@ret, $argend) if $passthrough; + last; + } + + # Look it up. + my $tryopt = $opt; + my $found; # success status + my $key; # key (if hash type) + my $arg; # option argument + my $ctl; # the opctl entry + + ($found, $opt, $ctl, $arg, $key) = + FindOption ($argv, $prefix, $argend, $opt, \%opctl); + + if ( $found ) { + + # FindOption undefines $opt in case of errors. + next unless defined $opt; + + my $argcnt = 0; + while ( defined $arg ) { + + # Get the canonical name. + print STDERR ("=> cname for \"$opt\" is ") if $debug; + $opt = $ctl->[CTL_CNAME]; + print STDERR ("\"$ctl->[CTL_CNAME]\"\n") if $debug; + + if ( defined $linkage{$opt} ) { + print STDERR ("=> ref(\$L{$opt}) -> ", + ref($linkage{$opt}), "\n") if $debug; + + if ( ref($linkage{$opt}) eq 'SCALAR' + || ref($linkage{$opt}) eq 'REF' ) { + if ( $ctl->[CTL_TYPE] eq '+' ) { + print STDERR ("=> \$\$L{$opt} += \"$arg\"\n") + if $debug; + if ( defined ${$linkage{$opt}} ) { + ${$linkage{$opt}} += $arg; + } + else { + ${$linkage{$opt}} = $arg; + } + } + elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) { + print STDERR ("=> ref(\$L{$opt}) auto-vivified", + " to ARRAY\n") + if $debug; + my $t = $linkage{$opt}; + $$t = $linkage{$opt} = []; + print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n") + if $debug; + push (@{$linkage{$opt}}, $arg); + } + elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) { + print STDERR ("=> ref(\$L{$opt}) auto-vivified", + " to HASH\n") + if $debug; + my $t = $linkage{$opt}; + $$t = $linkage{$opt} = {}; + print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n") + if $debug; + $linkage{$opt}->{$key} = $arg; + } + else { + print STDERR ("=> \$\$L{$opt} = \"$arg\"\n") + if $debug; + ${$linkage{$opt}} = $arg; + } + } + elsif ( ref($linkage{$opt}) eq 'ARRAY' ) { + print STDERR ("=> push(\@{\$L{$opt}, \"$arg\")\n") + if $debug; + push (@{$linkage{$opt}}, $arg); + } + elsif ( ref($linkage{$opt}) eq 'HASH' ) { + print STDERR ("=> \$\$L{$opt}->{$key} = \"$arg\"\n") + if $debug; + $linkage{$opt}->{$key} = $arg; + } + elsif ( ref($linkage{$opt}) eq 'CODE' ) { + print STDERR ("=> &L{$opt}(\"$opt\"", + $ctl->[CTL_DEST] == CTL_DEST_HASH ? ", \"$key\"" : "", + ", \"$arg\")\n") + if $debug; + my $eval_error = do { + local $@; + local $SIG{__DIE__} = 'DEFAULT'; + eval { + &{$linkage{$opt}} + (Getopt::Long::CallBack->new + (name => $opt, + ctl => $ctl, + opctl => \%opctl, + linkage => \%linkage, + prefix => $prefix, + ), + $ctl->[CTL_DEST] == CTL_DEST_HASH ? ($key) : (), + $arg); + }; + $@; + }; + print STDERR ("=> die($eval_error)\n") + if $debug && $eval_error ne ''; + if ( $eval_error =~ /^!/ ) { + if ( $eval_error =~ /^!FINISH\b/ ) { + $goon = 0; + } + } + elsif ( $eval_error ne '' ) { + warn ($eval_error); + $error++; + } + } + else { + print STDERR ("Invalid REF type \"", ref($linkage{$opt}), + "\" in linkage\n"); + die("Getopt::Long -- internal error!\n"); + } + } + # No entry in linkage means entry in userlinkage. + elsif ( $ctl->[CTL_DEST] == CTL_DEST_ARRAY ) { + if ( defined $userlinkage->{$opt} ) { + print STDERR ("=> push(\@{\$L{$opt}}, \"$arg\")\n") + if $debug; + push (@{$userlinkage->{$opt}}, $arg); + } + else { + print STDERR ("=>\$L{$opt} = [\"$arg\"]\n") + if $debug; + $userlinkage->{$opt} = [$arg]; + } + } + elsif ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) { + if ( defined $userlinkage->{$opt} ) { + print STDERR ("=> \$L{$opt}->{$key} = \"$arg\"\n") + if $debug; + $userlinkage->{$opt}->{$key} = $arg; + } + else { + print STDERR ("=>\$L{$opt} = {$key => \"$arg\"}\n") + if $debug; + $userlinkage->{$opt} = {$key => $arg}; + } + } + else { + if ( $ctl->[CTL_TYPE] eq '+' ) { + print STDERR ("=> \$L{$opt} += \"$arg\"\n") + if $debug; + if ( defined $userlinkage->{$opt} ) { + $userlinkage->{$opt} += $arg; + } + else { + $userlinkage->{$opt} = $arg; + } + } + else { + print STDERR ("=>\$L{$opt} = \"$arg\"\n") if $debug; + $userlinkage->{$opt} = $arg; + } + } + + $argcnt++; + last if $argcnt >= $ctl->[CTL_AMAX] && $ctl->[CTL_AMAX] != -1; + undef($arg); + + # Need more args? + if ( $argcnt < $ctl->[CTL_AMIN] ) { + if ( @$argv ) { + if ( ValidValue($ctl, $argv->[0], 1, $argend, $prefix) ) { + $arg = shift(@$argv); + if ( $ctl->[CTL_TYPE] =~ /^[iIo]$/ ) { + $arg =~ tr/_//d; + $arg = $ctl->[CTL_TYPE] eq 'o' && $arg =~ /^0/ + ? oct($arg) + : 0+$arg + } + ($key,$arg) = $arg =~ /^([^=]+)=(.*)/ + if $ctl->[CTL_DEST] == CTL_DEST_HASH; + next; + } + warn("Value \"$$argv[0]\" invalid for option $opt\n"); + $error++; + } + else { + warn("Insufficient arguments for option $opt\n"); + $error++; + } + } + + # Any more args? + if ( @$argv && ValidValue($ctl, $argv->[0], 0, $argend, $prefix) ) { + $arg = shift(@$argv); + if ( $ctl->[CTL_TYPE] =~ /^[iIo]$/ ) { + $arg =~ tr/_//d; + $arg = $ctl->[CTL_TYPE] eq 'o' && $arg =~ /^0/ + ? oct($arg) + : 0+$arg + } + ($key,$arg) = $arg =~ /^([^=]+)=(.*)/ + if $ctl->[CTL_DEST] == CTL_DEST_HASH; + next; + } + } + } + + # Not an option. Save it if we $PERMUTE and don't have a <>. + elsif ( $order == $PERMUTE ) { + # Try non-options call-back. + my $cb; + if ( defined ($cb = $linkage{'<>'}) ) { + print STDERR ("=> &L{$tryopt}(\"$tryopt\")\n") + if $debug; + my $eval_error = do { + local $@; + local $SIG{__DIE__} = 'DEFAULT'; + eval { + # The arg to <> cannot be the CallBack object + # since it may be passed to other modules that + # get confused (e.g., Archive::Tar). Well, + # it's not relevant for this callback anyway. + &$cb($tryopt); + }; + $@; + }; + print STDERR ("=> die($eval_error)\n") + if $debug && $eval_error ne ''; + if ( $eval_error =~ /^!/ ) { + if ( $eval_error =~ /^!FINISH\b/ ) { + $goon = 0; + } + } + elsif ( $eval_error ne '' ) { + warn ($eval_error); + $error++; + } + } + else { + print STDERR ("=> saving \"$tryopt\" ", + "(not an option, may permute)\n") if $debug; + push (@ret, $tryopt); + } + next; + } + + # ...otherwise, terminate. + else { + # Push this one back and exit. + unshift (@$argv, $tryopt); + return ($error == 0); + } + + } + + # Finish. + if ( @ret && $order == $PERMUTE ) { + # Push back accumulated arguments + print STDERR ("=> restoring \"", join('" "', @ret), "\"\n") + if $debug; + unshift (@$argv, @ret); + } + + return ($error == 0); + } + + # A readable representation of what's in an optbl. + sub OptCtl ($) { + my ($v) = @_; + my @v = map { defined($_) ? ($_) : ("") } @$v; + "[". + join(",", + "\"$v[CTL_TYPE]\"", + "\"$v[CTL_CNAME]\"", + "\"$v[CTL_DEFAULT]\"", + ("\$","\@","\%","\&")[$v[CTL_DEST] || 0], + $v[CTL_AMIN] || '', + $v[CTL_AMAX] || '', + # $v[CTL_RANGE] || '', + # $v[CTL_REPEAT] || '', + ). "]"; + } + + # Parse an option specification and fill the tables. + sub ParseOptionSpec ($$) { + my ($opt, $opctl) = @_; + + # Match option spec. + if ( $opt !~ m;^ + ( + # Option name + (?: \w+[-\w]* ) + # Alias names, or "?" + (?: \| (?: \? | \w[-\w]* ) )* + # Aliases + (?: \| (?: [^-|!+=:][^|!+=:]* )? )* + )? + ( + # Either modifiers ... + [!+] + | + # ... or a value/dest/repeat specification + [=:] [ionfs] [@%]? (?: \{\d*,?\d*\} )? + | + # ... or an optional-with-default spec + : (?: -?\d+ | \+ ) [@%]? + )? + $;x ) { + return (undef, "Error in option spec: \"$opt\"\n"); + } + + my ($names, $spec) = ($1, $2); + $spec = '' unless defined $spec; + + # $orig keeps track of the primary name the user specified. + # This name will be used for the internal or external linkage. + # In other words, if the user specifies "FoO|BaR", it will + # match any case combinations of 'foo' and 'bar', but if a global + # variable needs to be set, it will be $opt_FoO in the exact case + # as specified. + my $orig; + + my @names; + if ( defined $names ) { + @names = split (/\|/, $names); + $orig = $names[0]; + } + else { + @names = (''); + $orig = ''; + } + + # Construct the opctl entries. + my $entry; + if ( $spec eq '' || $spec eq '+' || $spec eq '!' ) { + # Fields are hard-wired here. + $entry = [$spec,$orig,undef,CTL_DEST_SCALAR,0,0]; + } + elsif ( $spec =~ /^:(-?\d+|\+)([@%])?$/ ) { + my $def = $1; + my $dest = $2; + my $type = $def eq '+' ? 'I' : 'i'; + $dest ||= '$'; + $dest = $dest eq '@' ? CTL_DEST_ARRAY + : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR; + # Fields are hard-wired here. + $entry = [$type,$orig,$def eq '+' ? undef : $def, + $dest,0,1]; + } + else { + my ($mand, $type, $dest) = + $spec =~ /^([=:])([ionfs])([@%])?(\{(\d+)?(,)?(\d+)?\})?$/; + return (undef, "Cannot repeat while bundling: \"$opt\"\n") + if $bundling && defined($4); + my ($mi, $cm, $ma) = ($5, $6, $7); + return (undef, "{0} is useless in option spec: \"$opt\"\n") + if defined($mi) && !$mi && !defined($ma) && !defined($cm); + + $type = 'i' if $type eq 'n'; + $dest ||= '$'; + $dest = $dest eq '@' ? CTL_DEST_ARRAY + : $dest eq '%' ? CTL_DEST_HASH : CTL_DEST_SCALAR; + # Default minargs to 1/0 depending on mand status. + $mi = $mand eq '=' ? 1 : 0 unless defined $mi; + # Adjust mand status according to minargs. + $mand = $mi ? '=' : ':'; + # Adjust maxargs. + $ma = $mi ? $mi : 1 unless defined $ma || defined $cm; + return (undef, "Max must be greater than zero in option spec: \"$opt\"\n") + if defined($ma) && !$ma; + return (undef, "Max less than min in option spec: \"$opt\"\n") + if defined($ma) && $ma < $mi; + + # Fields are hard-wired here. + $entry = [$type,$orig,undef,$dest,$mi,$ma||-1]; + } + + # Process all names. First is canonical, the rest are aliases. + my $dups = ''; + foreach ( @names ) { + + $_ = lc ($_) + if $ignorecase > (($bundling && length($_) == 1) ? 1 : 0); + + if ( exists $opctl->{$_} ) { + $dups .= "Duplicate specification \"$opt\" for option \"$_\"\n"; + } + + if ( $spec eq '!' ) { + $opctl->{"no$_"} = $entry; + $opctl->{"no-$_"} = $entry; + $opctl->{$_} = [@$entry]; + $opctl->{$_}->[CTL_TYPE] = ''; + } + else { + $opctl->{$_} = $entry; + } + } + + if ( $dups && $^W ) { + foreach ( split(/\n+/, $dups) ) { + warn($_."\n"); + } + } + ($names[0], $orig); + } + + # Option lookup. + sub FindOption ($$$$$) { + + # returns (1, $opt, $ctl, $arg, $key) if okay, + # returns (1, undef) if option in error, + # returns (0) otherwise. + + my ($argv, $prefix, $argend, $opt, $opctl) = @_; + + print STDERR ("=> find \"$opt\"\n") if $debug; + + return (0) unless defined($opt); + return (0) unless $opt =~ /^($prefix)(.*)$/s; + return (0) if $opt eq "-" && !defined $opctl->{''}; + + $opt = substr( $opt, length($1) ); # retain taintedness + my $starter = $1; + + print STDERR ("=> split \"$starter\"+\"$opt\"\n") if $debug; + + my $optarg; # value supplied with --opt=value + my $rest; # remainder from unbundling + + # If it is a long option, it may include the value. + # With getopt_compat, only if not bundling. + if ( ($starter=~/^$longprefix$/ + || ($getopt_compat && ($bundling == 0 || $bundling == 2))) + && (my $oppos = index($opt, '=', 1)) > 0) { + my $optorg = $opt; + $opt = substr($optorg, 0, $oppos); + $optarg = substr($optorg, $oppos + 1); # retain tainedness + print STDERR ("=> option \"", $opt, + "\", optarg = \"$optarg\"\n") if $debug; + } + + #### Look it up ### + + my $tryopt = $opt; # option to try + + if ( ( $bundling || $bundling_values ) && $starter eq '-' ) { + + # To try overrides, obey case ignore. + $tryopt = $ignorecase ? lc($opt) : $opt; + + # If bundling == 2, long options can override bundles. + if ( $bundling == 2 && length($tryopt) > 1 + && defined ($opctl->{$tryopt}) ) { + print STDERR ("=> $starter$tryopt overrides unbundling\n") + if $debug; + } + + # If bundling_values, option may be followed by the value. + elsif ( $bundling_values ) { + $tryopt = $opt; + # Unbundle single letter option. + $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : ''; + $tryopt = substr ($tryopt, 0, 1); + $tryopt = lc ($tryopt) if $ignorecase > 1; + print STDERR ("=> $starter$tryopt unbundled from ", + "$starter$tryopt$rest\n") if $debug; + # Whatever remains may not be considered an option. + $optarg = $rest eq '' ? undef : $rest; + $rest = undef; + } + + # Split off a single letter and leave the rest for + # further processing. + else { + $tryopt = $opt; + # Unbundle single letter option. + $rest = length ($tryopt) > 0 ? substr ($tryopt, 1) : ''; + $tryopt = substr ($tryopt, 0, 1); + $tryopt = lc ($tryopt) if $ignorecase > 1; + print STDERR ("=> $starter$tryopt unbundled from ", + "$starter$tryopt$rest\n") if $debug; + $rest = undef unless $rest ne ''; + } + } + + # Try auto-abbreviation. + elsif ( $autoabbrev && $opt ne "" ) { + # Sort the possible long option names. + my @names = sort(keys (%$opctl)); + # Downcase if allowed. + $opt = lc ($opt) if $ignorecase; + $tryopt = $opt; + # Turn option name into pattern. + my $pat = quotemeta ($opt); + # Look up in option names. + my @hits = grep (/^$pat/, @names); + print STDERR ("=> ", scalar(@hits), " hits (@hits) with \"$pat\" ", + "out of ", scalar(@names), "\n") if $debug; + + # Check for ambiguous results. + unless ( (@hits <= 1) || (grep ($_ eq $opt, @hits) == 1) ) { + # See if all matches are for the same option. + my %hit; + foreach ( @hits ) { + my $hit = $opctl->{$_}->[CTL_CNAME] + if defined $opctl->{$_}->[CTL_CNAME]; + $hit = "no" . $hit if $opctl->{$_}->[CTL_TYPE] eq '!'; + $hit{$hit} = 1; + } + # Remove auto-supplied options (version, help). + if ( keys(%hit) == 2 ) { + if ( $auto_version && exists($hit{version}) ) { + delete $hit{version}; + } + elsif ( $auto_help && exists($hit{help}) ) { + delete $hit{help}; + } + } + # Now see if it really is ambiguous. + unless ( keys(%hit) == 1 ) { + return (0) if $passthrough; + warn ("Option ", $opt, " is ambiguous (", + join(", ", @hits), ")\n"); + $error++; + return (1, undef); + } + @hits = keys(%hit); + } + + # Complete the option name, if appropriate. + if ( @hits == 1 && $hits[0] ne $opt ) { + $tryopt = $hits[0]; + $tryopt = lc ($tryopt) if $ignorecase; + print STDERR ("=> option \"$opt\" -> \"$tryopt\"\n") + if $debug; + } + } + + # Map to all lowercase if ignoring case. + elsif ( $ignorecase ) { + $tryopt = lc ($opt); + } + + # Check validity by fetching the info. + my $ctl = $opctl->{$tryopt}; + unless ( defined $ctl ) { + return (0) if $passthrough; + # Pretend one char when bundling. + if ( $bundling == 1 && length($starter) == 1 ) { + $opt = substr($opt,0,1); + unshift (@$argv, $starter.$rest) if defined $rest; + } + if ( $opt eq "" ) { + warn ("Missing option after ", $starter, "\n"); + } + else { + warn ("Unknown option: ", $opt, "\n"); + } + $error++; + return (1, undef); + } + # Apparently valid. + $opt = $tryopt; + print STDERR ("=> found ", OptCtl($ctl), + " for \"", $opt, "\"\n") if $debug; + + #### Determine argument status #### + + # If it is an option w/o argument, we're almost finished with it. + my $type = $ctl->[CTL_TYPE]; + my $arg; + + if ( $type eq '' || $type eq '!' || $type eq '+' ) { + if ( defined $optarg ) { + return (0) if $passthrough; + warn ("Option ", $opt, " does not take an argument\n"); + $error++; + undef $opt; + undef $optarg if $bundling_values; + } + elsif ( $type eq '' || $type eq '+' ) { + # Supply explicit value. + $arg = 1; + } + else { + $opt =~ s/^no-?//i; # strip NO prefix + $arg = 0; # supply explicit value + } + unshift (@$argv, $starter.$rest) if defined $rest; + return (1, $opt, $ctl, $arg); + } + + # Get mandatory status and type info. + my $mand = $ctl->[CTL_AMIN]; + + # Check if there is an option argument available. + if ( $gnu_compat && defined $optarg && $optarg eq '' ) { + return (1, $opt, $ctl, $type eq 's' ? '' : 0) ;#unless $mand; + $optarg = 0 unless $type eq 's'; + } + + # Check if there is an option argument available. + if ( defined $optarg + ? ($optarg eq '') + : !(defined $rest || @$argv > 0) ) { + # Complain if this option needs an argument. + # if ( $mand && !($type eq 's' ? defined($optarg) : 0) ) { + if ( $mand ) { + return (0) if $passthrough; + warn ("Option ", $opt, " requires an argument\n"); + $error++; + return (1, undef); + } + if ( $type eq 'I' ) { + # Fake incremental type. + my @c = @$ctl; + $c[CTL_TYPE] = '+'; + return (1, $opt, \@c, 1); + } + return (1, $opt, $ctl, + defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : + $type eq 's' ? '' : 0); + } + + # Get (possibly optional) argument. + $arg = (defined $rest ? $rest + : (defined $optarg ? $optarg : shift (@$argv))); + + # Get key if this is a "name=value" pair for a hash option. + my $key; + if ($ctl->[CTL_DEST] == CTL_DEST_HASH && defined $arg) { + ($key, $arg) = ($arg =~ /^([^=]*)=(.*)$/s) ? ($1, $2) + : ($arg, defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : + ($mand ? undef : ($type eq 's' ? "" : 1))); + if (! defined $arg) { + warn ("Option $opt, key \"$key\", requires a value\n"); + $error++; + # Push back. + unshift (@$argv, $starter.$rest) if defined $rest; + return (1, undef); + } + } + + #### Check if the argument is valid for this option #### + + my $key_valid = $ctl->[CTL_DEST] == CTL_DEST_HASH ? "[^=]+=" : ""; + + if ( $type eq 's' ) { # string + # A mandatory string takes anything. + return (1, $opt, $ctl, $arg, $key) if $mand; + + # Same for optional string as a hash value + return (1, $opt, $ctl, $arg, $key) + if $ctl->[CTL_DEST] == CTL_DEST_HASH; + + # An optional string takes almost anything. + return (1, $opt, $ctl, $arg, $key) + if defined $optarg || defined $rest; + return (1, $opt, $ctl, $arg, $key) if $arg eq "-"; # ?? + + # Check for option or option list terminator. + if ($arg eq $argend || + $arg =~ /^$prefix.+/) { + # Push back. + unshift (@$argv, $arg); + # Supply empty value. + $arg = ''; + } + } + + elsif ( $type eq 'i' # numeric/integer + || $type eq 'I' # numeric/integer w/ incr default + || $type eq 'o' ) { # dec/oct/hex/bin value + + my $o_valid = $type eq 'o' ? PAT_XINT : PAT_INT; + + if ( $bundling && defined $rest + && $rest =~ /^($key_valid)($o_valid)(.*)$/si ) { + ($key, $arg, $rest) = ($1, $2, $+); + chop($key) if $key; + $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg; + unshift (@$argv, $starter.$rest) if defined $rest && $rest ne ''; + } + elsif ( $arg =~ /^$o_valid$/si ) { + $arg =~ tr/_//d; + $arg = ($type eq 'o' && $arg =~ /^0/) ? oct($arg) : 0+$arg; + } + else { + if ( defined $optarg || $mand ) { + if ( $passthrough ) { + unshift (@$argv, defined $rest ? $starter.$rest : $arg) + unless defined $optarg; + return (0); + } + warn ("Value \"", $arg, "\" invalid for option ", + $opt, " (", + $type eq 'o' ? "extended " : '', + "number expected)\n"); + $error++; + # Push back. + unshift (@$argv, $starter.$rest) if defined $rest; + return (1, undef); + } + else { + # Push back. + unshift (@$argv, defined $rest ? $starter.$rest : $arg); + if ( $type eq 'I' ) { + # Fake incremental type. + my @c = @$ctl; + $c[CTL_TYPE] = '+'; + return (1, $opt, \@c, 1); + } + # Supply default value. + $arg = defined($ctl->[CTL_DEFAULT]) ? $ctl->[CTL_DEFAULT] : 0; + } + } + } + + elsif ( $type eq 'f' ) { # real number, int is also ok + my $o_valid = PAT_FLOAT; + if ( $bundling && defined $rest && + $rest =~ /^($key_valid)($o_valid)(.*)$/s ) { + $arg =~ tr/_//d; + ($key, $arg, $rest) = ($1, $2, $+); + chop($key) if $key; + unshift (@$argv, $starter.$rest) if defined $rest && $rest ne ''; + } + elsif ( $arg =~ /^$o_valid$/ ) { + $arg =~ tr/_//d; + } + else { + if ( defined $optarg || $mand ) { + if ( $passthrough ) { + unshift (@$argv, defined $rest ? $starter.$rest : $arg) + unless defined $optarg; + return (0); + } + warn ("Value \"", $arg, "\" invalid for option ", + $opt, " (real number expected)\n"); + $error++; + # Push back. + unshift (@$argv, $starter.$rest) if defined $rest; + return (1, undef); + } + else { + # Push back. + unshift (@$argv, defined $rest ? $starter.$rest : $arg); + # Supply default value. + $arg = 0.0; + } + } + } + else { + die("Getopt::Long internal error (Can't happen)\n"); + } + return (1, $opt, $ctl, $arg, $key); + } + + sub ValidValue ($$$$$) { + my ($ctl, $arg, $mand, $argend, $prefix) = @_; + + if ( $ctl->[CTL_DEST] == CTL_DEST_HASH ) { + return 0 unless $arg =~ /[^=]+=(.*)/; + $arg = $1; + } + + my $type = $ctl->[CTL_TYPE]; + + if ( $type eq 's' ) { # string + # A mandatory string takes anything. + return (1) if $mand; + + return (1) if $arg eq "-"; + + # Check for option or option list terminator. + return 0 if $arg eq $argend || $arg =~ /^$prefix.+/; + return 1; + } + + elsif ( $type eq 'i' # numeric/integer + || $type eq 'I' # numeric/integer w/ incr default + || $type eq 'o' ) { # dec/oct/hex/bin value + + my $o_valid = $type eq 'o' ? PAT_XINT : PAT_INT; + return $arg =~ /^$o_valid$/si; + } + + elsif ( $type eq 'f' ) { # real number, int is also ok + my $o_valid = PAT_FLOAT; + return $arg =~ /^$o_valid$/; + } + die("ValidValue: Cannot happen\n"); + } + + # Getopt::Long Configuration. + sub Configure (@) { + my (@options) = @_; + + my $prevconfig = + [ $error, $debug, $major_version, $minor_version, $caller, + $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order, + $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help, + $longprefix, $bundling_values ]; + + if ( ref($options[0]) eq 'ARRAY' ) { + ( $error, $debug, $major_version, $minor_version, $caller, + $autoabbrev, $getopt_compat, $ignorecase, $bundling, $order, + $gnu_compat, $passthrough, $genprefix, $auto_version, $auto_help, + $longprefix, $bundling_values ) = @{shift(@options)}; + } + + my $opt; + foreach $opt ( @options ) { + my $try = lc ($opt); + my $action = 1; + if ( $try =~ /^no_?(.*)$/s ) { + $action = 0; + $try = $+; + } + if ( ($try eq 'default' or $try eq 'defaults') && $action ) { + ConfigDefaults (); + } + elsif ( ($try eq 'posix_default' or $try eq 'posix_defaults') ) { + local $ENV{POSIXLY_CORRECT}; + $ENV{POSIXLY_CORRECT} = 1 if $action; + ConfigDefaults (); + } + elsif ( $try eq 'auto_abbrev' or $try eq 'autoabbrev' ) { + $autoabbrev = $action; + } + elsif ( $try eq 'getopt_compat' ) { + $getopt_compat = $action; + $genprefix = $action ? "(--|-|\\+)" : "(--|-)"; + } + elsif ( $try eq 'gnu_getopt' ) { + if ( $action ) { + $gnu_compat = 1; + $bundling = 1; + $getopt_compat = 0; + $genprefix = "(--|-)"; + $order = $PERMUTE; + $bundling_values = 0; + } + } + elsif ( $try eq 'gnu_compat' ) { + $gnu_compat = $action; + } + elsif ( $try =~ /^(auto_?)?version$/ ) { + $auto_version = $action; + } + elsif ( $try =~ /^(auto_?)?help$/ ) { + $auto_help = $action; + } + elsif ( $try eq 'ignorecase' or $try eq 'ignore_case' ) { + $ignorecase = $action; + } + elsif ( $try eq 'ignorecase_always' or $try eq 'ignore_case_always' ) { + $ignorecase = $action ? 2 : 0; + } + elsif ( $try eq 'bundling' ) { + $bundling = $action; + $bundling_values = 0 if $action; + } + elsif ( $try eq 'bundling_override' ) { + $bundling = $action ? 2 : 0; + $bundling_values = 0 if $action; + } + elsif ( $try eq 'bundling_values' ) { + $bundling_values = $action; + $bundling = 0 if $action; + } + elsif ( $try eq 'require_order' ) { + $order = $action ? $REQUIRE_ORDER : $PERMUTE; + } + elsif ( $try eq 'permute' ) { + $order = $action ? $PERMUTE : $REQUIRE_ORDER; + } + elsif ( $try eq 'pass_through' or $try eq 'passthrough' ) { + $passthrough = $action; + } + elsif ( $try =~ /^prefix=(.+)$/ && $action ) { + $genprefix = $1; + # Turn into regexp. Needs to be parenthesized! + $genprefix = "(" . quotemeta($genprefix) . ")"; + eval { '' =~ /$genprefix/; }; + die("Getopt::Long: invalid pattern \"$genprefix\"\n") if $@; + } + elsif ( $try =~ /^prefix_pattern=(.+)$/ && $action ) { + $genprefix = $1; + # Parenthesize if needed. + $genprefix = "(" . $genprefix . ")" + unless $genprefix =~ /^\(.*\)$/; + eval { '' =~ m"$genprefix"; }; + die("Getopt::Long: invalid pattern \"$genprefix\"\n") if $@; + } + elsif ( $try =~ /^long_prefix_pattern=(.+)$/ && $action ) { + $longprefix = $1; + # Parenthesize if needed. + $longprefix = "(" . $longprefix . ")" + unless $longprefix =~ /^\(.*\)$/; + eval { '' =~ m"$longprefix"; }; + die("Getopt::Long: invalid long prefix pattern \"$longprefix\"\n") if $@; + } + elsif ( $try eq 'debug' ) { + $debug = $action; + } + else { + die("Getopt::Long: unknown or erroneous config parameter \"$opt\"\n") + } + } + $prevconfig; + } + + # Deprecated name. + sub config (@) { + Configure (@_); + } + + # Issue a standard message for --version. + # + # The arguments are mostly the same as for Pod::Usage::pod2usage: + # + # - a number (exit value) + # - a string (lead in message) + # - a hash with options. See Pod::Usage for details. + # + sub VersionMessage(@) { + # Massage args. + my $pa = setup_pa_args("version", @_); + + my $v = $main::VERSION; + my $fh = $pa->{-output} || + ($pa->{-exitval} eq "NOEXIT" || $pa->{-exitval} < 2) ? \*STDOUT : \*STDERR; + + print $fh (defined($pa->{-message}) ? $pa->{-message} : (), + $0, defined $v ? " version $v" : (), + "\n", + "(", __PACKAGE__, "::", "GetOptions", + " version ", + defined($Getopt::Long::VERSION_STRING) + ? $Getopt::Long::VERSION_STRING : $VERSION, ";", + " Perl version ", + $] >= 5.006 ? sprintf("%vd", $^V) : $], + ")\n"); + exit($pa->{-exitval}) unless $pa->{-exitval} eq "NOEXIT"; + } + + # Issue a standard message for --help. + # + # The arguments are the same as for Pod::Usage::pod2usage: + # + # - a number (exit value) + # - a string (lead in message) + # - a hash with options. See Pod::Usage for details. + # + sub HelpMessage(@) { + eval { + require Pod::Usage; + import Pod::Usage; + 1; + } || die("Cannot provide help: cannot load Pod::Usage\n"); + + # Note that pod2usage will issue a warning if -exitval => NOEXIT. + pod2usage(setup_pa_args("help", @_)); + + } + + # Helper routine to set up a normalized hash ref to be used as + # argument to pod2usage. + sub setup_pa_args($@) { + my $tag = shift; # who's calling + + # If called by direct binding to an option, it will get the option + # name and value as arguments. Remove these, if so. + @_ = () if @_ == 2 && $_[0] eq $tag; + + my $pa; + if ( @_ > 1 ) { + $pa = { @_ }; + } + else { + $pa = shift || {}; + } + + # At this point, $pa can be a number (exit value), string + # (message) or hash with options. + + if ( UNIVERSAL::isa($pa, 'HASH') ) { + # Get rid of -msg vs. -message ambiguity. + $pa->{-message} = $pa->{-msg}; + delete($pa->{-msg}); + } + elsif ( $pa =~ /^-?\d+$/ ) { + $pa = { -exitval => $pa }; + } + else { + $pa = { -message => $pa }; + } + + # These are _our_ defaults. + $pa->{-verbose} = 0 unless exists($pa->{-verbose}); + $pa->{-exitval} = 0 unless exists($pa->{-exitval}); + $pa; + } + + # Sneak way to know what version the user requested. + sub VERSION { + $requested_version = $_[1]; + shift->SUPER::VERSION(@_); + } + + package Getopt::Long::CallBack; + + sub new { + my ($pkg, %atts) = @_; + bless { %atts }, $pkg; + } + + sub name { + my $self = shift; + ''.$self->{name}; + } + + use overload + # Treat this object as an ordinary string for legacy API. + '""' => \&name, + fallback => 1; + + 1; + + ################ Documentation ################ + + =head1 NAME + + Getopt::Long - Extended processing of command line options + + =head1 SYNOPSIS + + use Getopt::Long; + my $data = "file.dat"; + my $length = 24; + my $verbose; + GetOptions ("length=i" => \$length, # numeric + "file=s" => \$data, # string + "verbose" => \$verbose) # flag + or die("Error in command line arguments\n"); + + =head1 DESCRIPTION + + The Getopt::Long module implements an extended getopt function called + GetOptions(). It parses the command line from C<@ARGV>, recognizing + and removing specified options and their possible values. + + This function adheres to the POSIX syntax for command + line options, with GNU extensions. In general, this means that options + have long names instead of single letters, and are introduced with a + double dash "--". Support for bundling of command line options, as was + the case with the more traditional single-letter approach, is provided + but not enabled by default. + + =head1 Command Line Options, an Introduction + + Command line operated programs traditionally take their arguments from + the command line, for example filenames or other information that the + program needs to know. Besides arguments, these programs often take + command line I as well. Options are not necessary for the + program to work, hence the name 'option', but are used to modify its + default behaviour. For example, a program could do its job quietly, + but with a suitable option it could provide verbose information about + what it did. + + Command line options come in several flavours. Historically, they are + preceded by a single dash C<->, and consist of a single letter. + + -l -a -c + + Usually, these single-character options can be bundled: + + -lac + + Options can have values, the value is placed after the option + character. Sometimes with whitespace in between, sometimes not: + + -s 24 -s24 + + Due to the very cryptic nature of these options, another style was + developed that used long names. So instead of a cryptic C<-l> one + could use the more descriptive C<--long>. To distinguish between a + bundle of single-character options and a long one, two dashes are used + to precede the option name. Early implementations of long options used + a plus C<+> instead. Also, option values could be specified either + like + + --size=24 + + or + + --size 24 + + The C<+> form is now obsolete and strongly deprecated. + + =head1 Getting Started with Getopt::Long + + Getopt::Long is the Perl5 successor of C. This was the + first Perl module that provided support for handling the new style of + command line options, in particular long option names, hence the Perl5 + name Getopt::Long. This module also supports single-character options + and bundling. + + To use Getopt::Long from a Perl program, you must include the + following line in your Perl program: + + use Getopt::Long; + + This will load the core of the Getopt::Long module and prepare your + program for using it. Most of the actual Getopt::Long code is not + loaded until you really call one of its functions. + + In the default configuration, options names may be abbreviated to + uniqueness, case does not matter, and a single dash is sufficient, + even for long option names. Also, options may be placed between + non-option arguments. See L for more + details on how to configure Getopt::Long. + + =head2 Simple options + + The most simple options are the ones that take no values. Their mere + presence on the command line enables the option. Popular examples are: + + --all --verbose --quiet --debug + + Handling simple options is straightforward: + + my $verbose = ''; # option variable with default value (false) + my $all = ''; # option variable with default value (false) + GetOptions ('verbose' => \$verbose, 'all' => \$all); + + The call to GetOptions() parses the command line arguments that are + present in C<@ARGV> and sets the option variable to the value C<1> if + the option did occur on the command line. Otherwise, the option + variable is not touched. Setting the option value to true is often + called I the option. + + The option name as specified to the GetOptions() function is called + the option I. Later we'll see that this specification + can contain more than just the option name. The reference to the + variable is called the option I. + + GetOptions() will return a true value if the command line could be + processed successfully. Otherwise, it will write error messages using + die() and warn(), and return a false result. + + =head2 A little bit less simple options + + Getopt::Long supports two useful variants of simple options: + I options and I options. + + A negatable option is specified with an exclamation mark C after the + option name: + + my $verbose = ''; # option variable with default value (false) + GetOptions ('verbose!' => \$verbose); + + Now, using C<--verbose> on the command line will enable C<$verbose>, + as expected. But it is also allowed to use C<--noverbose>, which will + disable C<$verbose> by setting its value to C<0>. Using a suitable + default value, the program can find out whether C<$verbose> is false + by default, or disabled by using C<--noverbose>. + + An incremental option is specified with a plus C<+> after the + option name: + + my $verbose = ''; # option variable with default value (false) + GetOptions ('verbose+' => \$verbose); + + Using C<--verbose> on the command line will increment the value of + C<$verbose>. This way the program can keep track of how many times the + option occurred on the command line. For example, each occurrence of + C<--verbose> could increase the verbosity level of the program. + + =head2 Mixing command line option with other arguments + + Usually programs take command line options as well as other arguments, + for example, file names. It is good practice to always specify the + options first, and the other arguments last. Getopt::Long will, + however, allow the options and arguments to be mixed and 'filter out' + all the options before passing the rest of the arguments to the + program. To stop Getopt::Long from processing further arguments, + insert a double dash C<--> on the command line: + + --size 24 -- --all + + In this example, C<--all> will I be treated as an option, but + passed to the program unharmed, in C<@ARGV>. + + =head2 Options with values + + For options that take values it must be specified whether the option + value is required or not, and what kind of value the option expects. + + Three kinds of values are supported: integer numbers, floating point + numbers, and strings. + + If the option value is required, Getopt::Long will take the + command line argument that follows the option and assign this to the + option variable. If, however, the option value is specified as + optional, this will only be done if that value does not look like a + valid command line option itself. + + my $tag = ''; # option variable with default value + GetOptions ('tag=s' => \$tag); + + In the option specification, the option name is followed by an equals + sign C<=> and the letter C. The equals sign indicates that this + option requires a value. The letter C indicates that this value is + an arbitrary string. Other possible value types are C for integer + values, and C for floating point values. Using a colon C<:> instead + of the equals sign indicates that the option value is optional. In + this case, if no suitable value is supplied, string valued options get + an empty string C<''> assigned, while numeric options are set to C<0>. + + =head2 Options with multiple values + + Options sometimes take several values. For example, a program could + use multiple directories to search for library files: + + --library lib/stdlib --library lib/extlib + + To accomplish this behaviour, simply specify an array reference as the + destination for the option: + + GetOptions ("library=s" => \@libfiles); + + Alternatively, you can specify that the option can have multiple + values by adding a "@", and pass a scalar reference as the + destination: + + GetOptions ("library=s@" => \$libfiles); + + Used with the example above, C<@libfiles> (or C<@$libfiles>) would + contain two strings upon completion: C<"lib/stdlib"> and + C<"lib/extlib">, in that order. It is also possible to specify that + only integer or floating point numbers are acceptable values. + + Often it is useful to allow comma-separated lists of values as well as + multiple occurrences of the options. This is easy using Perl's split() + and join() operators: + + GetOptions ("library=s" => \@libfiles); + @libfiles = split(/,/,join(',',@libfiles)); + + Of course, it is important to choose the right separator string for + each purpose. + + Warning: What follows is an experimental feature. + + Options can take multiple values at once, for example + + --coordinates 52.2 16.4 --rgbcolor 255 255 149 + + This can be accomplished by adding a repeat specifier to the option + specification. Repeat specifiers are very similar to the C<{...}> + repeat specifiers that can be used with regular expression patterns. + For example, the above command line would be handled as follows: + + GetOptions('coordinates=f{2}' => \@coor, 'rgbcolor=i{3}' => \@color); + + The destination for the option must be an array or array reference. + + It is also possible to specify the minimal and maximal number of + arguments an option takes. C indicates an option that + takes at least two and at most 4 arguments. C indicates one + or more values; C indicates zero or more option values. + + =head2 Options with hash values + + If the option destination is a reference to a hash, the option will + take, as value, strings of the form IC<=>I. The value will + be stored with the specified key in the hash. + + GetOptions ("define=s" => \%defines); + + Alternatively you can use: + + GetOptions ("define=s%" => \$defines); + + When used with command line options: + + --define os=linux --define vendor=redhat + + the hash C<%defines> (or C<%$defines>) will contain two keys, C<"os"> + with value C<"linux"> and C<"vendor"> with value C<"redhat">. It is + also possible to specify that only integer or floating point numbers + are acceptable values. The keys are always taken to be strings. + + =head2 User-defined subroutines to handle options + + Ultimate control over what should be done when (actually: each time) + an option is encountered on the command line can be achieved by + designating a reference to a subroutine (or an anonymous subroutine) + as the option destination. When GetOptions() encounters the option, it + will call the subroutine with two or three arguments. The first + argument is the name of the option. (Actually, it is an object that + stringifies to the name of the option.) For a scalar or array destination, + the second argument is the value to be stored. For a hash destination, + the second argument is the key to the hash, and the third argument + the value to be stored. It is up to the subroutine to store the value, + or do whatever it thinks is appropriate. + + A trivial application of this mechanism is to implement options that + are related to each other. For example: + + my $verbose = ''; # option variable with default value (false) + GetOptions ('verbose' => \$verbose, + 'quiet' => sub { $verbose = 0 }); + + Here C<--verbose> and C<--quiet> control the same variable + C<$verbose>, but with opposite values. + + If the subroutine needs to signal an error, it should call die() with + the desired error message as its argument. GetOptions() will catch the + die(), issue the error message, and record that an error result must + be returned upon completion. + + If the text of the error message starts with an exclamation mark C + it is interpreted specially by GetOptions(). There is currently one + special command implemented: C will cause GetOptions() + to stop processing options, as if it encountered a double dash C<-->. + + In version 2.37 the first argument to the callback function was + changed from string to object. This was done to make room for + extensions and more detailed control. The object stringifies to the + option name so this change should not introduce compatibility + problems. + + Here is an example of how to access the option name and value from within + a subroutine: + + GetOptions ('opt=i' => \&handler); + sub handler { + my ($opt_name, $opt_value) = @_; + print("Option name is $opt_name and value is $opt_value\n"); + } + + =head2 Options with multiple names + + Often it is user friendly to supply alternate mnemonic names for + options. For example C<--height> could be an alternate name for + C<--length>. Alternate names can be included in the option + specification, separated by vertical bar C<|> characters. To implement + the above example: + + GetOptions ('length|height=f' => \$length); + + The first name is called the I name, the other names are + called I. When using a hash to store options, the key will + always be the primary name. + + Multiple alternate names are possible. + + =head2 Case and abbreviations + + Without additional configuration, GetOptions() will ignore the case of + option names, and allow the options to be abbreviated to uniqueness. + + GetOptions ('length|height=f' => \$length, "head" => \$head); + + This call will allow C<--l> and C<--L> for the length option, but + requires a least C<--hea> and C<--hei> for the head and height options. + + =head2 Summary of Option Specifications + + Each option specifier consists of two parts: the name specification + and the argument specification. + + The name specification contains the name of the option, optionally + followed by a list of alternative names separated by vertical bar + characters. + + length option name is "length" + length|size|l name is "length", aliases are "size" and "l" + + The argument specification is optional. If omitted, the option is + considered boolean, a value of 1 will be assigned when the option is + used on the command line. + + The argument specification can be + + =over 4 + + =item ! + + The option does not take an argument and may be negated by prefixing + it with "no" or "no-". E.g. C<"foo!"> will allow C<--foo> (a value of + 1 will be assigned) as well as C<--nofoo> and C<--no-foo> (a value of + 0 will be assigned). If the option has aliases, this applies to the + aliases as well. + + Using negation on a single letter option when bundling is in effect is + pointless and will result in a warning. + + =item + + + The option does not take an argument and will be incremented by 1 + every time it appears on the command line. E.g. C<"more+">, when used + with C<--more --more --more>, will increment the value three times, + resulting in a value of 3 (provided it was 0 or undefined at first). + + The C<+> specifier is ignored if the option destination is not a scalar. + + =item = I [ I ] [ I ] + + The option requires an argument of the given type. Supported types + are: + + =over 4 + + =item s + + String. An arbitrary sequence of characters. It is valid for the + argument to start with C<-> or C<-->. + + =item i + + Integer. An optional leading plus or minus sign, followed by a + sequence of digits. + + =item o + + Extended integer, Perl style. This can be either an optional leading + plus or minus sign, followed by a sequence of digits, or an octal + string (a zero, optionally followed by '0', '1', .. '7'), or a + hexadecimal string (C<0x> followed by '0' .. '9', 'a' .. 'f', case + insensitive), or a binary string (C<0b> followed by a series of '0' + and '1'). + + =item f + + Real number. For example C<3.14>, C<-6.23E24> and so on. + + =back + + The I can be C<@> or C<%> to specify that the option is + list or a hash valued. This is only needed when the destination for + the option value is not otherwise specified. It should be omitted when + not needed. + + The I specifies the number of values this option takes per + occurrence on the command line. It has the format C<{> [ I ] [ C<,> [ I ] ] C<}>. + + I denotes the minimal number of arguments. It defaults to 1 for + options with C<=> and to 0 for options with C<:>, see below. Note that + I overrules the C<=> / C<:> semantics. + + I denotes the maximum number of arguments. It must be at least + I. If I is omitted, I, there is no + upper bound to the number of argument values taken. + + =item : I [ I ] + + Like C<=>, but designates the argument as optional. + If omitted, an empty string will be assigned to string values options, + and the value zero to numeric options. + + Note that if a string argument starts with C<-> or C<-->, it will be + considered an option on itself. + + =item : I [ I ] + + Like C<:i>, but if the value is omitted, the I will be assigned. + + =item : + [ I ] + + Like C<:i>, but if the value is omitted, the current value for the + option will be incremented. + + =back + + =head1 Advanced Possibilities + + =head2 Object oriented interface + + Getopt::Long can be used in an object oriented way as well: + + use Getopt::Long; + $p = Getopt::Long::Parser->new; + $p->configure(...configuration options...); + if ($p->getoptions(...options descriptions...)) ... + if ($p->getoptionsfromarray( \@array, ...options descriptions...)) ... + + Configuration options can be passed to the constructor: + + $p = new Getopt::Long::Parser + config => [...configuration options...]; + + =head2 Thread Safety + + Getopt::Long is thread safe when using ithreads as of Perl 5.8. It is + I thread safe when using the older (experimental and now + obsolete) threads implementation that was added to Perl 5.005. + + =head2 Documentation and help texts + + Getopt::Long encourages the use of Pod::Usage to produce help + messages. For example: + + use Getopt::Long; + use Pod::Usage; + + my $man = 0; + my $help = 0; + + GetOptions('help|?' => \$help, man => \$man) or pod2usage(2); + pod2usage(1) if $help; + pod2usage(-exitval => 0, -verbose => 2) if $man; + + __END__ + + =head1 NAME + + sample - Using Getopt::Long and Pod::Usage + + =head1 SYNOPSIS + + sample [options] [file ...] + + Options: + -help brief help message + -man full documentation + + =head1 OPTIONS + + =over 8 + + =item B<-help> + + Print a brief help message and exits. + + =item B<-man> + + Prints the manual page and exits. + + =back + + =head1 DESCRIPTION + + B will read the given input file(s) and do something + useful with the contents thereof. + + =cut + + See L for details. + + =head2 Parsing options from an arbitrary array + + By default, GetOptions parses the options that are present in the + global array C<@ARGV>. A special entry C can be + used to parse options from an arbitrary array. + + use Getopt::Long qw(GetOptionsFromArray); + $ret = GetOptionsFromArray(\@myopts, ...); + + When used like this, options and their possible values are removed + from C<@myopts>, the global C<@ARGV> is not touched at all. + + The following two calls behave identically: + + $ret = GetOptions( ... ); + $ret = GetOptionsFromArray(\@ARGV, ... ); + + This also means that a first argument hash reference now becomes the + second argument: + + $ret = GetOptions(\%opts, ... ); + $ret = GetOptionsFromArray(\@ARGV, \%opts, ... ); + + =head2 Parsing options from an arbitrary string + + A special entry C can be used to parse options + from an arbitrary string. + + use Getopt::Long qw(GetOptionsFromString); + $ret = GetOptionsFromString($string, ...); + + The contents of the string are split into arguments using a call to + C. As with C, the + global C<@ARGV> is not touched. + + It is possible that, upon completion, not all arguments in the string + have been processed. C will, when called in list + context, return both the return status and an array reference to any + remaining arguments: + + ($ret, $args) = GetOptionsFromString($string, ... ); + + If any arguments remain, and C was not called in + list context, a message will be given and C will + return failure. + + As with GetOptionsFromArray, a first argument hash reference now + becomes the second argument. + + =head2 Storing options values in a hash + + Sometimes, for example when there are a lot of options, having a + separate variable for each of them can be cumbersome. GetOptions() + supports, as an alternative mechanism, storing options values in a + hash. + + To obtain this, a reference to a hash must be passed I to GetOptions(). For each option that is specified on the + command line, the option value will be stored in the hash with the + option name as key. Options that are not actually used on the command + line will not be put in the hash, on other words, + C (or defined()) can be used to test if an option + was used. The drawback is that warnings will be issued if the program + runs under C and uses C<$h{option}> without testing with + exists() or defined() first. + + my %h = (); + GetOptions (\%h, 'length=i'); # will store in $h{length} + + For options that take list or hash values, it is necessary to indicate + this by appending an C<@> or C<%> sign after the type: + + GetOptions (\%h, 'colours=s@'); # will push to @{$h{colours}} + + To make things more complicated, the hash may contain references to + the actual destinations, for example: + + my $len = 0; + my %h = ('length' => \$len); + GetOptions (\%h, 'length=i'); # will store in $len + + This example is fully equivalent with: + + my $len = 0; + GetOptions ('length=i' => \$len); # will store in $len + + Any mixture is possible. For example, the most frequently used options + could be stored in variables while all other options get stored in the + hash: + + my $verbose = 0; # frequently referred + my $debug = 0; # frequently referred + my %h = ('verbose' => \$verbose, 'debug' => \$debug); + GetOptions (\%h, 'verbose', 'debug', 'filter', 'size=i'); + if ( $verbose ) { ... } + if ( exists $h{filter} ) { ... option 'filter' was specified ... } + + =head2 Bundling + + With bundling it is possible to set several single-character options + at once. For example if C, C and C are all valid options, + + -vax + + will set all three. + + Getopt::Long supports three styles of bundling. To enable bundling, a + call to Getopt::Long::Configure is required. + + The simplest style of bundling can be enabled with: + + Getopt::Long::Configure ("bundling"); + + Configured this way, single-character options can be bundled but long + options B always start with a double dash C<--> to avoid + ambiguity. For example, when C, C, C and C are all valid + options, + + -vax + + will set C, C and C, but + + --vax + + will set C. + + The second style of bundling lifts this restriction. It can be enabled + with: + + Getopt::Long::Configure ("bundling_override"); + + Now, C<-vax> will set the option C. + + In all of the above cases, option values may be inserted in the + bundle. For example: + + -h24w80 + + is equivalent to + + -h 24 -w 80 + + A third style of bundling allows only values to be bundled with + options. It can be enabled with: + + Getopt::Long::Configure ("bundling_values"); + + Now, C<-h24> will set the option C to C<24>, but option bundles + like C<-vxa> and C<-h24w80> are flagged as errors. + + Enabling C will disable the other two styles of + bundling. + + When configured for bundling, single-character options are matched + case sensitive while long options are matched case insensitive. To + have the single-character options matched case insensitive as well, + use: + + Getopt::Long::Configure ("bundling", "ignorecase_always"); + + It goes without saying that bundling can be quite confusing. + + =head2 The lonesome dash + + Normally, a lone dash C<-> on the command line will not be considered + an option. Option processing will terminate (unless "permute" is + configured) and the dash will be left in C<@ARGV>. + + It is possible to get special treatment for a lone dash. This can be + achieved by adding an option specification with an empty name, for + example: + + GetOptions ('' => \$stdio); + + A lone dash on the command line will now be a legal option, and using + it will set variable C<$stdio>. + + =head2 Argument callback + + A special option 'name' C<< <> >> can be used to designate a subroutine + to handle non-option arguments. When GetOptions() encounters an + argument that does not look like an option, it will immediately call this + subroutine and passes it one parameter: the argument name. Well, actually + it is an object that stringifies to the argument name. + + For example: + + my $width = 80; + sub process { ... } + GetOptions ('width=i' => \$width, '<>' => \&process); + + When applied to the following command line: + + arg1 --width=72 arg2 --width=60 arg3 + + This will call + C while C<$width> is C<80>, + C while C<$width> is C<72>, and + C while C<$width> is C<60>. + + This feature requires configuration option B, see section + L. + + =head1 Configuring Getopt::Long + + Getopt::Long can be configured by calling subroutine + Getopt::Long::Configure(). This subroutine takes a list of quoted + strings, each specifying a configuration option to be enabled, e.g. + C, or disabled, e.g. C. Case does not + matter. Multiple calls to Configure() are possible. + + Alternatively, as of version 2.24, the configuration options may be + passed together with the C statement: + + use Getopt::Long qw(:config no_ignore_case bundling); + + The following options are available: + + =over 12 + + =item default + + This option causes all configuration options to be reset to their + default values. + + =item posix_default + + This option causes all configuration options to be reset to their + default values as if the environment variable POSIXLY_CORRECT had + been set. + + =item auto_abbrev + + Allow option names to be abbreviated to uniqueness. + Default is enabled unless environment variable + POSIXLY_CORRECT has been set, in which case C is disabled. + + =item getopt_compat + + Allow C<+> to start options. + Default is enabled unless environment variable + POSIXLY_CORRECT has been set, in which case C is disabled. + + =item gnu_compat + + C controls whether C<--opt=> is allowed, and what it should + do. Without C, C<--opt=> gives an error. With C, + C<--opt=> will give option C and empty value. + This is the way GNU getopt_long() does it. + + =item gnu_getopt + + This is a short way of setting C C C + C. With C, command line handling should be + fully compatible with GNU getopt_long(). + + =item require_order + + Whether command line arguments are allowed to be mixed with options. + Default is disabled unless environment variable + POSIXLY_CORRECT has been set, in which case C is enabled. + + See also C, which is the opposite of C. + + =item permute + + Whether command line arguments are allowed to be mixed with options. + Default is enabled unless environment variable + POSIXLY_CORRECT has been set, in which case C is disabled. + Note that C is the opposite of C. + + If C is enabled, this means that + + --foo arg1 --bar arg2 arg3 + + is equivalent to + + --foo --bar arg1 arg2 arg3 + + If an argument callback routine is specified, C<@ARGV> will always be + empty upon successful return of GetOptions() since all options have been + processed. The only exception is when C<--> is used: + + --foo arg1 --bar arg2 -- arg3 + + This will call the callback routine for arg1 and arg2, and then + terminate GetOptions() leaving C<"arg3"> in C<@ARGV>. + + If C is enabled, options processing + terminates when the first non-option is encountered. + + --foo arg1 --bar arg2 arg3 + + is equivalent to + + --foo -- arg1 --bar arg2 arg3 + + If C is also enabled, options processing will terminate + at the first unrecognized option, or non-option, whichever comes + first. + + =item bundling (default: disabled) + + Enabling this option will allow single-character options to be + bundled. To distinguish bundles from long option names, long options + I be introduced with C<--> and bundles with C<->. + + Note that, if you have options C, C and C, and + auto_abbrev enabled, possible arguments and option settings are: + + using argument sets option(s) + ------------------------------------------ + -a, --a a + -l, --l l + -al, -la, -ala, -all,... a, l + --al, --all all + + The surprising part is that C<--a> sets option C (due to auto + completion), not C. + + Note: disabling C also disables C. + + =item bundling_override (default: disabled) + + If C is enabled, bundling is enabled as with + C but now long option names override option bundles. + + Note: disabling C also disables C. + + B Using option bundling can easily lead to unexpected results, + especially when mixing long options and bundles. Caveat emptor. + + =item ignore_case (default: enabled) + + If enabled, case is ignored when matching option names. If, however, + bundling is enabled as well, single character options will be treated + case-sensitive. + + With C, option specifications for options that only + differ in case, e.g., C<"foo"> and C<"Foo">, will be flagged as + duplicates. + + Note: disabling C also disables C. + + =item ignore_case_always (default: disabled) + + When bundling is in effect, case is ignored on single-character + options also. + + Note: disabling C also disables C. + + =item auto_version (default:disabled) + + Automatically provide support for the B<--version> option if + the application did not specify a handler for this option itself. + + Getopt::Long will provide a standard version message that includes the + program name, its version (if $main::VERSION is defined), and the + versions of Getopt::Long and Perl. The message will be written to + standard output and processing will terminate. + + C will be enabled if the calling program explicitly + specified a version number higher than 2.32 in the C or + C statement. + + =item auto_help (default:disabled) + + Automatically provide support for the B<--help> and B<-?> options if + the application did not specify a handler for this option itself. + + Getopt::Long will provide a help message using module L. The + message, derived from the SYNOPSIS POD section, will be written to + standard output and processing will terminate. + + C will be enabled if the calling program explicitly + specified a version number higher than 2.32 in the C or + C statement. + + =item pass_through (default: disabled) + + With C anything that is unknown, ambiguous or supplied with + an invalid option will not be flagged as an error. Instead the unknown + option(s) will be passed to the catchall C<< <> >> if present, otherwise + through to C<@ARGV>. This makes it possible to write wrapper scripts that + process only part of the user supplied command line arguments, and pass the + remaining options to some other program. + + If C is enabled, options processing will terminate at the + first unrecognized option, or non-option, whichever comes first and all + remaining arguments are passed to C<@ARGV> instead of the catchall + C<< <> >> if present. However, if C is enabled instead, results + can become confusing. + + Note that the options terminator (default C<-->), if present, will + also be passed through in C<@ARGV>. + + =item prefix + + The string that starts options. If a constant string is not + sufficient, see C. + + =item prefix_pattern + + A Perl pattern that identifies the strings that introduce options. + Default is C<--|-|\+> unless environment variable + POSIXLY_CORRECT has been set, in which case it is C<--|->. + + =item long_prefix_pattern + + A Perl pattern that allows the disambiguation of long and short + prefixes. Default is C<-->. + + Typically you only need to set this if you are using nonstandard + prefixes and want some or all of them to have the same semantics as + '--' does under normal circumstances. + + For example, setting prefix_pattern to C<--|-|\+|\/> and + long_prefix_pattern to C<--|\/> would add Win32 style argument + handling. + + =item debug (default: disabled) + + Enable debugging output. + + =back + + =head1 Exportable Methods + + =over + + =item VersionMessage + + This subroutine provides a standard version message. Its argument can be: + + =over 4 + + =item * + + A string containing the text of a message to print I printing + the standard message. + + =item * + + A numeric value corresponding to the desired exit status. + + =item * + + A reference to a hash. + + =back + + If more than one argument is given then the entire argument list is + assumed to be a hash. If a hash is supplied (either as a reference or + as a list) it should contain one or more elements with the following + keys: + + =over 4 + + =item C<-message> + + =item C<-msg> + + The text of a message to print immediately prior to printing the + program's usage message. + + =item C<-exitval> + + The desired exit status to pass to the B function. + This should be an integer, or else the string "NOEXIT" to + indicate that control should simply be returned without + terminating the invoking process. + + =item C<-output> + + A reference to a filehandle, or the pathname of a file to which the + usage message should be written. The default is C<\*STDERR> unless the + exit value is less than 2 (in which case the default is C<\*STDOUT>). + + =back + + You cannot tie this routine directly to an option, e.g.: + + GetOptions("version" => \&VersionMessage); + + Use this instead: + + GetOptions("version" => sub { VersionMessage() }); + + =item HelpMessage + + This subroutine produces a standard help message, derived from the + program's POD section SYNOPSIS using L. It takes the same + arguments as VersionMessage(). In particular, you cannot tie it + directly to an option, e.g.: + + GetOptions("help" => \&HelpMessage); + + Use this instead: + + GetOptions("help" => sub { HelpMessage() }); + + =back + + =head1 Return values and Errors + + Configuration errors and errors in the option definitions are + signalled using die() and will terminate the calling program unless + the call to Getopt::Long::GetOptions() was embedded in C, or die() was trapped using C<$SIG{__DIE__}>. + + GetOptions returns true to indicate success. + It returns false when the function detected one or more errors during + option parsing. These errors are signalled using warn() and can be + trapped with C<$SIG{__WARN__}>. + + =head1 Legacy + + The earliest development of C started in 1990, with Perl + version 4. As a result, its development, and the development of + Getopt::Long, has gone through several stages. Since backward + compatibility has always been extremely important, the current version + of Getopt::Long still supports a lot of constructs that nowadays are + no longer necessary or otherwise unwanted. This section describes + briefly some of these 'features'. + + =head2 Default destinations + + When no destination is specified for an option, GetOptions will store + the resultant value in a global variable named CI, where + I is the primary name of this option. When a program executes + under C (recommended), these variables must be + pre-declared with our() or C. + + our $opt_length = 0; + GetOptions ('length=i'); # will store in $opt_length + + To yield a usable Perl variable, characters that are not part of the + syntax for variables are translated to underscores. For example, + C<--fpp-struct-return> will set the variable + C<$opt_fpp_struct_return>. Note that this variable resides in the + namespace of the calling program, not necessarily C
. For + example: + + GetOptions ("size=i", "sizes=i@"); + + with command line "-size 10 -sizes 24 -sizes 48" will perform the + equivalent of the assignments + + $opt_size = 10; + @opt_sizes = (24, 48); + + =head2 Alternative option starters + + A string of alternative option starter characters may be passed as the + first argument (or the first argument after a leading hash reference + argument). + + my $len = 0; + GetOptions ('/', 'length=i' => $len); + + Now the command line may look like: + + /length 24 -- arg + + Note that to terminate options processing still requires a double dash + C<-->. + + GetOptions() will not interpret a leading C<< "<>" >> as option starters + if the next argument is a reference. To force C<< "<" >> and C<< ">" >> as + option starters, use C<< "><" >>. Confusing? Well, B anyway. + + =head2 Configuration variables + + Previous versions of Getopt::Long used variables for the purpose of + configuring. Although manipulating these variables still work, it is + strongly encouraged to use the C routine that was introduced + in version 2.17. Besides, it is much easier. + + =head1 Tips and Techniques + + =head2 Pushing multiple values in a hash option + + Sometimes you want to combine the best of hashes and arrays. For + example, the command line: + + --list add=first --list add=second --list add=third + + where each successive 'list add' option will push the value of add + into array ref $list->{'add'}. The result would be like + + $list->{add} = [qw(first second third)]; + + This can be accomplished with a destination routine: + + GetOptions('list=s%' => + sub { push(@{$list{$_[1]}}, $_[2]) }); + + =head1 Troubleshooting + + =head2 GetOptions does not return a false result when an option is not supplied + + That's why they're called 'options'. + + =head2 GetOptions does not split the command line correctly + + The command line is not split by GetOptions, but by the command line + interpreter (CLI). On Unix, this is the shell. On Windows, it is + COMMAND.COM or CMD.EXE. Other operating systems have other CLIs. + + It is important to know that these CLIs may behave different when the + command line contains special characters, in particular quotes or + backslashes. For example, with Unix shells you can use single quotes + (C<'>) and double quotes (C<">) to group words together. The following + alternatives are equivalent on Unix: + + "two words" + 'two words' + two\ words + + In case of doubt, insert the following statement in front of your Perl + program: + + print STDERR (join("|",@ARGV),"\n"); + + to verify how your CLI passes the arguments to the program. + + =head2 Undefined subroutine &main::GetOptions called + + Are you running Windows, and did you write + + use GetOpt::Long; + + (note the capital 'O')? + + =head2 How do I put a "-?" option into a Getopt::Long? + + You can only obtain this using an alias, and Getopt::Long of at least + version 2.13. + + use Getopt::Long; + GetOptions ("help|?"); # -help and -? will both set $opt_help + + Other characters that can't appear in Perl identifiers are also supported + as aliases with Getopt::Long of at least version 2.39. + + As of version 2.32 Getopt::Long provides auto-help, a quick and easy way + to add the options --help and -? to your program, and handle them. + + See C in section L. + + =head1 AUTHOR + + Johan Vromans + + =head1 COPYRIGHT AND DISCLAIMER + + This program is Copyright 1990,2015 by Johan Vromans. + This program is free software; you can redistribute it and/or + modify it under the terms of the Perl Artistic License or the + GNU General Public License as published by the Free Software + Foundation; either version 2 of the License, or (at your option) any + later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + If you do not have a copy of the GNU General Public License write to + the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, + MA 02139, USA. + + =cut + +GETOPT_LONG + +$fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON'; + package JSON; + + + use strict; + use Carp (); + use base qw(Exporter); + @JSON::EXPORT = qw(from_json to_json jsonToObj objToJson encode_json decode_json); + + BEGIN { + $JSON::VERSION = '2.90'; + $JSON::DEBUG = 0 unless (defined $JSON::DEBUG); + $JSON::DEBUG = $ENV{ PERL_JSON_DEBUG } if exists $ENV{ PERL_JSON_DEBUG }; + } + + my $Module_XS = 'JSON::XS'; + my $Module_PP = 'JSON::PP'; + my $Module_bp = 'JSON::backportPP'; # included in JSON distribution + my $PP_Version = '2.27203'; + my $XS_Version = '2.34'; + + + # XS and PP common methods + + my @PublicMethods = qw/ + ascii latin1 utf8 pretty indent space_before space_after relaxed canonical allow_nonref + allow_blessed convert_blessed filter_json_object filter_json_single_key_object + shrink max_depth max_size encode decode decode_prefix allow_unknown + /; + + my @Properties = qw/ + ascii latin1 utf8 indent space_before space_after relaxed canonical allow_nonref + allow_blessed convert_blessed shrink max_depth max_size allow_unknown + /; + + my @XSOnlyMethods = qw/allow_tags/; # Currently nothing + + my @PPOnlyMethods = qw/ + indent_length sort_by + allow_singlequote allow_bignum loose allow_barekey escape_slash as_nonblessed + /; # JSON::PP specific + + + # used in _load_xs and _load_pp ($INSTALL_ONLY is not used currently) + my $_INSTALL_DONT_DIE = 1; # When _load_xs fails to load XS, don't die. + my $_INSTALL_ONLY = 2; # Don't call _set_methods() + my $_ALLOW_UNSUPPORTED = 0; + my $_UNIV_CONV_BLESSED = 0; + my $_USSING_bpPP = 0; + + + # Check the environment variable to decide worker module. + + unless ($JSON::Backend) { + $JSON::DEBUG and Carp::carp("Check used worker module..."); + + my $backend = exists $ENV{PERL_JSON_BACKEND} ? $ENV{PERL_JSON_BACKEND} : 1; + + if ($backend eq '1' or $backend =~ /JSON::XS\s*,\s*JSON::PP/) { + _load_xs($_INSTALL_DONT_DIE) or _load_pp(); + } + elsif ($backend eq '0' or $backend eq 'JSON::PP') { + _load_pp(); + } + elsif ($backend eq '2' or $backend eq 'JSON::XS') { + _load_xs(); + } + elsif ($backend eq 'JSON::backportPP') { + $_USSING_bpPP = 1; + _load_pp(); + } + else { + Carp::croak "The value of environmental variable 'PERL_JSON_BACKEND' is invalid."; + } + } + + + sub import { + my $pkg = shift; + my @what_to_export; + my $no_export; + + for my $tag (@_) { + if ($tag eq '-support_by_pp') { + if (!$_ALLOW_UNSUPPORTED++) { + JSON::Backend::XS + ->support_by_pp(@PPOnlyMethods) if ($JSON::Backend eq $Module_XS); + } + next; + } + elsif ($tag eq '-no_export') { + $no_export++, next; + } + elsif ( $tag eq '-convert_blessed_universally' ) { + eval q| + require B; + *UNIVERSAL::TO_JSON = sub { + my $b_obj = B::svref_2object( $_[0] ); + return $b_obj->isa('B::HV') ? { %{ $_[0] } } + : $b_obj->isa('B::AV') ? [ @{ $_[0] } ] + : undef + ; + } + | if ( !$_UNIV_CONV_BLESSED++ ); + next; + } + push @what_to_export, $tag; + } + + return if ($no_export); + + __PACKAGE__->export_to_level(1, $pkg, @what_to_export); + } + + + # OBSOLETED + + sub jsonToObj { + my $alternative = 'from_json'; + if (defined $_[0] and UNIVERSAL::isa($_[0], 'JSON')) { + shift @_; $alternative = 'decode'; + } + Carp::carp "'jsonToObj' will be obsoleted. Please use '$alternative' instead."; + return JSON::from_json(@_); + }; + + sub objToJson { + my $alternative = 'to_json'; + if (defined $_[0] and UNIVERSAL::isa($_[0], 'JSON')) { + shift @_; $alternative = 'encode'; + } + Carp::carp "'objToJson' will be obsoleted. Please use '$alternative' instead."; + JSON::to_json(@_); + }; + + + # INTERFACES + + sub to_json ($@) { + if ( + ref($_[0]) eq 'JSON' + or (@_ > 2 and $_[0] eq 'JSON') + ) { + Carp::croak "to_json should not be called as a method."; + } + my $json = JSON->new; + + if (@_ == 2 and ref $_[1] eq 'HASH') { + my $opt = $_[1]; + for my $method (keys %$opt) { + $json->$method( $opt->{$method} ); + } + } + + $json->encode($_[0]); + } + + + sub from_json ($@) { + if ( ref($_[0]) eq 'JSON' or $_[0] eq 'JSON' ) { + Carp::croak "from_json should not be called as a method."; + } + my $json = JSON->new; + + if (@_ == 2 and ref $_[1] eq 'HASH') { + my $opt = $_[1]; + for my $method (keys %$opt) { + $json->$method( $opt->{$method} ); + } + } + + return $json->decode( $_[0] ); + } + + + + sub true { $JSON::true } + + sub false { $JSON::false } + + sub null { undef; } + + + sub require_xs_version { $XS_Version; } + + sub backend { + my $proto = shift; + $JSON::Backend; + } + + #*module = *backend; + + + sub is_xs { + return $_[0]->backend eq $Module_XS; + } + + + sub is_pp { + return not $_[0]->is_xs; + } + + + sub pureperl_only_methods { @PPOnlyMethods; } + + + sub property { + my ($self, $name, $value) = @_; + + if (@_ == 1) { + my %props; + for $name (@Properties) { + my $method = 'get_' . $name; + if ($name eq 'max_size') { + my $value = $self->$method(); + $props{$name} = $value == 1 ? 0 : $value; + next; + } + $props{$name} = $self->$method(); + } + return \%props; + } + elsif (@_ > 3) { + Carp::croak('property() can take only the option within 2 arguments.'); + } + elsif (@_ == 2) { + if ( my $method = $self->can('get_' . $name) ) { + if ($name eq 'max_size') { + my $value = $self->$method(); + return $value == 1 ? 0 : $value; + } + $self->$method(); + } + } + else { + $self->$name($value); + } + + } + + + + # INTERNAL + + sub _load_xs { + my $opt = shift; + + $JSON::DEBUG and Carp::carp "Load $Module_XS."; + + # if called after install module, overload is disable.... why? + JSON::Boolean::_overrride_overload($Module_XS); + JSON::Boolean::_overrride_overload($Module_PP); + + eval qq| + use $Module_XS $XS_Version (); + |; + + if ($@) { + if (defined $opt and $opt & $_INSTALL_DONT_DIE) { + $JSON::DEBUG and Carp::carp "Can't load $Module_XS...($@)"; + return 0; + } + Carp::croak $@; + } + + unless (defined $opt and $opt & $_INSTALL_ONLY) { + _set_module( $JSON::Backend = $Module_XS ); + my $data = join("", ); # this code is from Jcode 2.xx. + close(DATA); + eval $data; + JSON::Backend::XS->init; + } + + return 1; + }; + + + sub _load_pp { + my $opt = shift; + my $backend = $_USSING_bpPP ? $Module_bp : $Module_PP; + + $JSON::DEBUG and Carp::carp "Load $backend."; + + # if called after install module, overload is disable.... why? + JSON::Boolean::_overrride_overload($Module_XS); + JSON::Boolean::_overrride_overload($backend); + + if ( $_USSING_bpPP ) { + eval qq| require $backend |; + } + else { + eval qq| use $backend $PP_Version () |; + } + + if ($@) { + if ( $backend eq $Module_PP ) { + $JSON::DEBUG and Carp::carp "Can't load $Module_PP ($@), so try to load $Module_bp"; + $_USSING_bpPP++; + $backend = $Module_bp; + JSON::Boolean::_overrride_overload($backend); + local $^W; # if PP installed but invalid version, backportPP redefines methods. + eval qq| require $Module_bp |; + } + Carp::croak $@ if $@; + } + + unless (defined $opt and $opt & $_INSTALL_ONLY) { + _set_module( $JSON::Backend = $Module_PP ); # even if backportPP, set $Backend with 'JSON::PP' + JSON::Backend::PP->init; + } + }; + + + sub _set_module { + return if defined $JSON::true; + + my $module = shift; + + local $^W; + no strict qw(refs); + + $JSON::true = ${"$module\::true"}; + $JSON::false = ${"$module\::false"}; + + push @JSON::ISA, $module; + if ( JSON->is_xs and JSON->backend->VERSION < 3 ) { + eval 'package JSON::PP::Boolean'; + push @{"$module\::Boolean::ISA"}, qw(JSON::PP::Boolean); + } + + *{"JSON::is_bool"} = \&{"$module\::is_bool"}; + + for my $method ($module eq $Module_XS ? @PPOnlyMethods : @XSOnlyMethods) { + *{"JSON::$method"} = sub { + Carp::carp("$method is not supported in $module."); + $_[0]; + }; + } + + return 1; + } + + + + # + # JSON Boolean + # + + package JSON::Boolean; + + my %Installed; + + sub _overrride_overload { + return; # this function is currently disable. + return if ($Installed{ $_[0] }++); + + my $boolean = $_[0] . '::Boolean'; + + eval sprintf(q| + package %s; + use overload ( + '""' => sub { ${$_[0]} == 1 ? 'true' : 'false' }, + 'eq' => sub { + my ($obj, $op) = ref ($_[0]) ? ($_[0], $_[1]) : ($_[1], $_[0]); + if ($op eq 'true' or $op eq 'false') { + return "$obj" eq 'true' ? 'true' eq $op : 'false' eq $op; + } + else { + return $obj ? 1 == $op : 0 == $op; + } + }, + ); + |, $boolean); + + if ($@) { Carp::croak $@; } + + if ( exists $INC{'JSON/XS.pm'} and $boolean eq 'JSON::XS::Boolean' ) { + local $^W; + my $true = do { bless \(my $dummy = 1), $boolean }; + my $false = do { bless \(my $dummy = 0), $boolean }; + *JSON::XS::true = sub () { $true }; + *JSON::XS::false = sub () { $false }; + } + elsif ( exists $INC{'JSON/PP.pm'} and $boolean eq 'JSON::PP::Boolean' ) { + local $^W; + my $true = do { bless \(my $dummy = 1), $boolean }; + my $false = do { bless \(my $dummy = 0), $boolean }; + *JSON::PP::true = sub { $true }; + *JSON::PP::false = sub { $false }; + } + + return 1; + } + + + # + # Helper classes for Backend Module (PP) + # + + package JSON::Backend::PP; + + sub init { + local $^W; + no strict qw(refs); # this routine may be called after JSON::Backend::XS init was called. + *{"JSON::decode_json"} = \&{"JSON::PP::decode_json"}; + *{"JSON::encode_json"} = \&{"JSON::PP::encode_json"}; + *{"JSON::PP::is_xs"} = sub { 0 }; + *{"JSON::PP::is_pp"} = sub { 1 }; + return 1; + } + + # + # To save memory, the below lines are read only when XS backend is used. + # + + package JSON; + + 1; + __DATA__ + + + # + # Helper classes for Backend Module (XS) + # + + package JSON::Backend::XS; + + use constant INDENT_LENGTH_FLAG => 15 << 12; + + use constant UNSUPPORTED_ENCODE_FLAG => { + ESCAPE_SLASH => 0x00000010, + ALLOW_BIGNUM => 0x00000020, + AS_NONBLESSED => 0x00000040, + EXPANDED => 0x10000000, # for developer's + }; + + use constant UNSUPPORTED_DECODE_FLAG => { + LOOSE => 0x00000001, + ALLOW_BIGNUM => 0x00000002, + ALLOW_BAREKEY => 0x00000004, + ALLOW_SINGLEQUOTE => 0x00000008, + EXPANDED => 0x20000000, # for developer's + }; + + + sub init { + local $^W; + no strict qw(refs); + *{"JSON::decode_json"} = \&{"JSON::XS::decode_json"}; + *{"JSON::encode_json"} = \&{"JSON::XS::encode_json"}; + *{"JSON::XS::is_xs"} = sub { 1 }; + *{"JSON::XS::is_pp"} = sub { 0 }; + return 1; + } + + + sub support_by_pp { + my ($class, @methods) = @_; + + local $^W; + no strict qw(refs); + + my $JSON_XS_encode_orignal = \&JSON::XS::encode; + my $JSON_XS_decode_orignal = \&JSON::XS::decode; + my $JSON_XS_incr_parse_orignal = \&JSON::XS::incr_parse; + + *JSON::XS::decode = \&JSON::Backend::XS::Supportable::_decode; + *JSON::XS::encode = \&JSON::Backend::XS::Supportable::_encode; + *JSON::XS::incr_parse = \&JSON::Backend::XS::Supportable::_incr_parse; + + *{JSON::XS::_original_decode} = $JSON_XS_decode_orignal; + *{JSON::XS::_original_encode} = $JSON_XS_encode_orignal; + *{JSON::XS::_original_incr_parse} = $JSON_XS_incr_parse_orignal; + + push @JSON::Backend::XS::Supportable::ISA, 'JSON'; + + my $pkg = 'JSON::Backend::XS::Supportable'; + + *{JSON::new} = sub { + my $proto = JSON::XS->new; $$proto = 0; + bless $proto, $pkg; + }; + + + for my $method (@methods) { + my $flag = uc($method); + my $type |= (UNSUPPORTED_ENCODE_FLAG->{$flag} || 0); + $type |= (UNSUPPORTED_DECODE_FLAG->{$flag} || 0); + + next unless($type); + + $pkg->_make_unsupported_method($method => $type); + } + + # push @{"JSON::XS::Boolean::ISA"}, qw(JSON::PP::Boolean); + # push @{"JSON::PP::Boolean::ISA"}, qw(JSON::Boolean); + + $JSON::DEBUG and Carp::carp("set -support_by_pp mode."); + + return 1; + } + + + + + # + # Helper classes for XS + # + + package JSON::Backend::XS::Supportable; + + $Carp::Internal{'JSON::Backend::XS::Supportable'} = 1; + + sub _make_unsupported_method { + my ($pkg, $method, $type) = @_; + + local $^W; + no strict qw(refs); + + *{"$pkg\::$method"} = sub { + local $^W; + if (defined $_[1] ? $_[1] : 1) { + ${$_[0]} |= $type; + } + else { + ${$_[0]} &= ~$type; + } + $_[0]; + }; + + *{"$pkg\::get_$method"} = sub { + ${$_[0]} & $type ? 1 : ''; + }; + + } + + + sub _set_for_pp { + JSON::_load_pp( $_INSTALL_ONLY ); + + my $type = shift; + my $pp = JSON::PP->new; + my $prop = $_[0]->property; + + for my $name (keys %$prop) { + $pp->$name( $prop->{$name} ? $prop->{$name} : 0 ); + } + + my $unsupported = $type eq 'encode' ? JSON::Backend::XS::UNSUPPORTED_ENCODE_FLAG + : JSON::Backend::XS::UNSUPPORTED_DECODE_FLAG; + my $flags = ${$_[0]} || 0; + + for my $name (keys %$unsupported) { + next if ($name eq 'EXPANDED'); # for developer's + my $enable = ($flags & $unsupported->{$name}) ? 1 : 0; + my $method = lc $name; + $pp->$method($enable); + } + + $pp->indent_length( $_[0]->get_indent_length ); + + return $pp; + } + + sub _encode { # using with PP encode + if (${$_[0]}) { + _set_for_pp('encode' => @_)->encode($_[1]); + } + else { + $_[0]->_original_encode( $_[1] ); + } + } + + + sub _decode { # if unsupported-flag is set, use PP + if (${$_[0]}) { + _set_for_pp('decode' => @_)->decode($_[1]); + } + else { + $_[0]->_original_decode( $_[1] ); + } + } + + + sub decode_prefix { # if unsupported-flag is set, use PP + _set_for_pp('decode' => @_)->decode_prefix($_[1]); + } + + + sub _incr_parse { + if (${$_[0]}) { + _set_for_pp('decode' => @_)->incr_parse($_[1]); + } + else { + $_[0]->_original_incr_parse( $_[1] ); + } + } + + + sub get_indent_length { + ${$_[0]} << 4 >> 16; + } + + + sub indent_length { + my $length = $_[1]; + + if (!defined $length or $length > 15 or $length < 0) { + Carp::carp "The acceptable range of indent_length() is 0 to 15."; + } + else { + local $^W; + $length <<= 12; + ${$_[0]} &= ~ JSON::Backend::XS::INDENT_LENGTH_FLAG; + ${$_[0]} |= $length; + *JSON::XS::encode = \&JSON::Backend::XS::Supportable::_encode; + } + + $_[0]; + } + + + 1; + __END__ + + =head1 NAME + + JSON - JSON (JavaScript Object Notation) encoder/decoder + + =head1 SYNOPSIS + + use JSON; # imports encode_json, decode_json, to_json and from_json. + + # simple and fast interfaces (expect/generate UTF-8) + + $utf8_encoded_json_text = encode_json $perl_hash_or_arrayref; + $perl_hash_or_arrayref = decode_json $utf8_encoded_json_text; + + # OO-interface + + $json = JSON->new->allow_nonref; + + $json_text = $json->encode( $perl_scalar ); + $perl_scalar = $json->decode( $json_text ); + + $pretty_printed = $json->pretty->encode( $perl_scalar ); # pretty-printing + + # If you want to use PP only support features, call with '-support_by_pp' + # When XS unsupported feature is enable, using PP (de|en)code instead of XS ones. + + use JSON -support_by_pp; + + # option-acceptable interfaces (expect/generate UNICODE by default) + + $json_text = to_json( $perl_scalar, { ascii => 1, pretty => 1 } ); + $perl_scalar = from_json( $json_text, { utf8 => 1 } ); + + # Between (en|de)code_json and (to|from)_json, if you want to write + # a code which communicates to an outer world (encoded in UTF-8), + # recommend to use (en|de)code_json. + + =head1 VERSION + + 2.90 + + This version is compatible with JSON::XS B<2.34> and later. + (Not yet compatble to JSON::XS B<3.0x>.) + + + =head1 NOTE + + JSON::PP was earlier included in the C distribution, but + has since Perl 5.14 been a core module. For this reason, + L was removed from the JSON distribution and can now + be found also in the Perl5 repository at + + =over + + =item * L + + =back + + (The newest JSON::PP version still exists in CPAN.) + + Instead, the C distribution will include JSON::backportPP + for backwards computability. JSON.pm should thus work as it did + before. + + =head1 DESCRIPTION + + *************************** CAUTION ************************************** + * * + * INCOMPATIBLE CHANGE (JSON::XS version 2.90) * + * * + * JSON.pm had patched JSON::XS::Boolean and JSON::PP::Boolean internally * + * on loading time for making these modules inherit JSON::Boolean. * + * But since JSON::XS v3.0 it use Types::Serialiser as boolean class. * + * Then now JSON.pm breaks boolean classe overload features and * + * -support_by_pp if JSON::XS v3.0 or later is installed. * + * * + * JSON::true and JSON::false returned JSON::Boolean objects. * + * For workaround, they return JSON::PP::Boolean objects in this version. * + * * + * isa_ok(JSON::true, 'JSON::PP::Boolean'); * + * * + * And it discards a feature: * + * * + * ok(JSON::true eq 'true'); * + * * + * In other word, JSON::PP::Boolean overload numeric only. * + * * + * ok( JSON::true == 1 ); * + * * + ************************************************************************** + + ************************** CAUTION ******************************** + * This is 'JSON module version 2' and there are many differences * + * to version 1.xx * + * Please check your applications using old version. * + * See to 'INCOMPATIBLE CHANGES TO OLD VERSION' * + ******************************************************************* + + JSON (JavaScript Object Notation) is a simple data format. + See to L and C(L). + + This module converts Perl data structures to JSON and vice versa using either + L or L. + + JSON::XS is the fastest and most proper JSON module on CPAN which must be + compiled and installed in your environment. + JSON::PP is a pure-Perl module which is bundled in this distribution and + has a strong compatibility to JSON::XS. + + This module try to use JSON::XS by default and fail to it, use JSON::PP instead. + So its features completely depend on JSON::XS or JSON::PP. + + See to L. + + To distinguish the module name 'JSON' and the format type JSON, + the former is quoted by CEE (its results vary with your using media), + and the latter is left just as it is. + + Module name : C + + Format type : JSON + + =head2 FEATURES + + =over + + =item * correct unicode handling + + This module (i.e. backend modules) knows how to handle Unicode, documents + how and when it does so, and even documents what "correct" means. + + Even though there are limitations, this feature is available since Perl version 5.6. + + JSON::XS requires Perl 5.8.2 (but works correctly in 5.8.8 or later), so in older versions + C should call JSON::PP as the backend which can be used since Perl 5.005. + + With Perl 5.8.x JSON::PP works, but from 5.8.0 to 5.8.2, because of a Perl side problem, + JSON::PP works slower in the versions. And in 5.005, the Unicode handling is not available. + See to L for more information. + + See also to L + and L. + + + =item * round-trip integrity + + When you serialise a perl data structure using only data types supported + by JSON and Perl, the deserialised data structure is identical on the Perl + level. (e.g. the string "2.0" doesn't suddenly become "2" just because + it looks like a number). There I minor exceptions to this, read the + L section below to learn about those. + + + =item * strict checking of JSON correctness + + There is no guessing, no generating of illegal JSON texts by default, + and only JSON is accepted as input by default (the latter is a security + feature). + + See to L and L. + + =item * fast + + This module returns a JSON::XS object itself if available. + Compared to other JSON modules and other serialisers such as Storable, + JSON::XS usually compares favorably in terms of speed, too. + + If not available, C returns a JSON::PP object instead of JSON::XS and + it is very slow as pure-Perl. + + =item * simple to use + + This module has both a simple functional interface as well as an + object oriented interface interface. + + =item * reasonably versatile output formats + + You can choose between the most compact guaranteed-single-line format possible + (nice for simple line-based protocols), a pure-ASCII format (for when your transport + is not 8-bit clean, still supports the whole Unicode range), or a pretty-printed + format (for when you want to read that stuff). Or you can combine those features + in whatever way you like. + + =back + + =head1 FUNCTIONAL INTERFACE + + Some documents are copied and modified from L. + C and C are additional functions. + + =head2 encode_json + + $json_text = encode_json $perl_scalar + + Converts the given Perl data structure to a UTF-8 encoded, binary string. + + This function call is functionally identical to: + + $json_text = JSON->new->utf8->encode($perl_scalar) + + =head2 decode_json + + $perl_scalar = decode_json $json_text + + The opposite of C: expects an UTF-8 (binary) string and tries + to parse that as an UTF-8 encoded JSON text, returning the resulting + reference. + + This function call is functionally identical to: + + $perl_scalar = JSON->new->utf8->decode($json_text) + + + =head2 to_json + + $json_text = to_json($perl_scalar) + + Converts the given Perl data structure to a json string. + + This function call is functionally identical to: + + $json_text = JSON->new->encode($perl_scalar) + + Takes a hash reference as the second. + + $json_text = to_json($perl_scalar, $flag_hashref) + + So, + + $json_text = to_json($perl_scalar, {utf8 => 1, pretty => 1}) + + equivalent to: + + $json_text = JSON->new->utf8(1)->pretty(1)->encode($perl_scalar) + + If you want to write a modern perl code which communicates to outer world, + you should use C (supposed that JSON data are encoded in UTF-8). + + =head2 from_json + + $perl_scalar = from_json($json_text) + + The opposite of C: expects a json string and tries + to parse it, returning the resulting reference. + + This function call is functionally identical to: + + $perl_scalar = JSON->decode($json_text) + + Takes a hash reference as the second. + + $perl_scalar = from_json($json_text, $flag_hashref) + + So, + + $perl_scalar = from_json($json_text, {utf8 => 1}) + + equivalent to: + + $perl_scalar = JSON->new->utf8(1)->decode($json_text) + + If you want to write a modern perl code which communicates to outer world, + you should use C (supposed that JSON data are encoded in UTF-8). + + =head2 JSON::is_bool + + $is_boolean = JSON::is_bool($scalar) + + Returns true if the passed scalar represents either JSON::true or + JSON::false, two constants that act like C<1> and C<0> respectively + and are also used to represent JSON C and C in Perl strings. + + =head2 JSON::true + + Returns JSON true value which is blessed object. + It C JSON::Boolean object. + + =head2 JSON::false + + Returns JSON false value which is blessed object. + It C JSON::Boolean object. + + =head2 JSON::null + + Returns C. + + See L, below, for more information on how JSON values are mapped to + Perl. + + =head1 HOW DO I DECODE A DATA FROM OUTER AND ENCODE TO OUTER + + This section supposes that your perl version is 5.8 or later. + + If you know a JSON text from an outer world - a network, a file content, and so on, + is encoded in UTF-8, you should use C or C module object + with C enable. And the decoded result will contain UNICODE characters. + + # from network + my $json = JSON->new->utf8; + my $json_text = CGI->new->param( 'json_data' ); + my $perl_scalar = $json->decode( $json_text ); + + # from file content + local $/; + open( my $fh, '<', 'json.data' ); + $json_text = <$fh>; + $perl_scalar = decode_json( $json_text ); + + If an outer data is not encoded in UTF-8, firstly you should C it. + + use Encode; + local $/; + open( my $fh, '<', 'json.data' ); + my $encoding = 'cp932'; + my $unicode_json_text = decode( $encoding, <$fh> ); # UNICODE + + # or you can write the below code. + # + # open( my $fh, "<:encoding($encoding)", 'json.data' ); + # $unicode_json_text = <$fh>; + + In this case, C<$unicode_json_text> is of course UNICODE string. + So you B use C nor C module object with C enable. + Instead of them, you use C module object with C disable or C. + + $perl_scalar = $json->utf8(0)->decode( $unicode_json_text ); + # or + $perl_scalar = from_json( $unicode_json_text ); + + Or C and C: + + $perl_scalar = decode_json( encode( 'utf8', $unicode_json_text ) ); + # this way is not efficient. + + And now, you want to convert your C<$perl_scalar> into JSON data and + send it to an outer world - a network or a file content, and so on. + + Your data usually contains UNICODE strings and you want the converted data to be encoded + in UTF-8, you should use C or C module object with C enable. + + print encode_json( $perl_scalar ); # to a network? file? or display? + # or + print $json->utf8->encode( $perl_scalar ); + + If C<$perl_scalar> does not contain UNICODE but C<$encoding>-encoded strings + for some reason, then its characters are regarded as B for perl + (because it does not concern with your $encoding). + You B use C nor C module object with C enable. + Instead of them, you use C module object with C disable or C. + Note that the resulted text is a UNICODE string but no problem to print it. + + # $perl_scalar contains $encoding encoded string values + $unicode_json_text = $json->utf8(0)->encode( $perl_scalar ); + # or + $unicode_json_text = to_json( $perl_scalar ); + # $unicode_json_text consists of characters less than 0x100 + print $unicode_json_text; + + Or C all string values and C: + + $perl_scalar->{ foo } = decode( $encoding, $perl_scalar->{ foo } ); + # ... do it to each string values, then encode_json + $json_text = encode_json( $perl_scalar ); + + This method is a proper way but probably not efficient. + + See to L, L. + + + =head1 COMMON OBJECT-ORIENTED INTERFACE + + =head2 new + + $json = JSON->new + + Returns a new C object inherited from either JSON::XS or JSON::PP + that can be used to de/encode JSON strings. + + All boolean flags described below are by default I. + + The mutators for flags all return the JSON object again and thus calls can + be chained: + + my $json = JSON->new->utf8->space_after->encode({a => [1,2]}) + => {"a": [1, 2]} + + =head2 ascii + + $json = $json->ascii([$enable]) + + $enabled = $json->get_ascii + + If $enable is true (or missing), then the encode method will not generate characters outside + the code range 0..127. Any Unicode characters outside that range will be escaped using either + a single \uXXXX or a double \uHHHH\uLLLLL escape sequence, as per RFC4627. + + If $enable is false, then the encode method will not escape Unicode characters unless + required by the JSON syntax or other flags. This results in a faster and more compact format. + + This feature depends on the used Perl version and environment. + + See to L if the backend is PP. + + JSON->new->ascii(1)->encode([chr 0x10401]) + => ["\ud801\udc01"] + + =head2 latin1 + + $json = $json->latin1([$enable]) + + $enabled = $json->get_latin1 + + If $enable is true (or missing), then the encode method will encode the resulting JSON + text as latin1 (or iso-8859-1), escaping any characters outside the code range 0..255. + + If $enable is false, then the encode method will not escape Unicode characters + unless required by the JSON syntax or other flags. + + JSON->new->latin1->encode (["\x{89}\x{abc}"] + => ["\x{89}\\u0abc"] # (perl syntax, U+abc escaped, U+89 not) + + =head2 utf8 + + $json = $json->utf8([$enable]) + + $enabled = $json->get_utf8 + + If $enable is true (or missing), then the encode method will encode the JSON result + into UTF-8, as required by many protocols, while the decode method expects to be handled + an UTF-8-encoded string. Please note that UTF-8-encoded strings do not contain any + characters outside the range 0..255, they are thus useful for bytewise/binary I/O. + + In future versions, enabling this option might enable autodetection of the UTF-16 and UTF-32 + encoding families, as described in RFC4627. + + If $enable is false, then the encode method will return the JSON string as a (non-encoded) + Unicode string, while decode expects thus a Unicode string. Any decoding or encoding + (e.g. to UTF-8 or UTF-16) needs to be done yourself, e.g. using the Encode module. + + + Example, output UTF-16BE-encoded JSON: + + use Encode; + $jsontext = encode "UTF-16BE", JSON::XS->new->encode ($object); + + Example, decode UTF-32LE-encoded JSON: + + use Encode; + $object = JSON::XS->new->decode (decode "UTF-32LE", $jsontext); + + See to L if the backend is PP. + + + =head2 pretty + + $json = $json->pretty([$enable]) + + This enables (or disables) all of the C, C and + C (and in the future possibly more) flags in one call to + generate the most readable (or most compact) form possible. + + Equivalent to: + + $json->indent->space_before->space_after + + The indent space length is three and JSON::XS cannot change the indent + space length. + + =head2 indent + + $json = $json->indent([$enable]) + + $enabled = $json->get_indent + + If C<$enable> is true (or missing), then the C method will use a multiline + format as output, putting every array member or object/hash key-value pair + into its own line, identifying them properly. + + If C<$enable> is false, no newlines or indenting will be produced, and the + resulting JSON text is guaranteed not to contain any C. + + This setting has no effect when decoding JSON texts. + + The indent space length is three. + With JSON::PP, you can also access C to change indent space length. + + + =head2 space_before + + $json = $json->space_before([$enable]) + + $enabled = $json->get_space_before + + If C<$enable> is true (or missing), then the C method will add an extra + optional space before the C<:> separating keys from values in JSON objects. + + If C<$enable> is false, then the C method will not add any extra + space at those places. + + This setting has no effect when decoding JSON texts. + + Example, space_before enabled, space_after and indent disabled: + + {"key" :"value"} + + + =head2 space_after + + $json = $json->space_after([$enable]) + + $enabled = $json->get_space_after + + If C<$enable> is true (or missing), then the C method will add an extra + optional space after the C<:> separating keys from values in JSON objects + and extra whitespace after the C<,> separating key-value pairs and array + members. + + If C<$enable> is false, then the C method will not add any extra + space at those places. + + This setting has no effect when decoding JSON texts. + + Example, space_before and indent disabled, space_after enabled: + + {"key": "value"} + + + =head2 relaxed + + $json = $json->relaxed([$enable]) + + $enabled = $json->get_relaxed + + If C<$enable> is true (or missing), then C will accept some + extensions to normal JSON syntax (see below). C will not be + affected in anyway. I. I suggest only to use this option to + parse application-specific files written by humans (configuration files, + resource files etc.) + + If C<$enable> is false (the default), then C will only accept + valid JSON texts. + + Currently accepted extensions are: + + =over 4 + + =item * list items can have an end-comma + + JSON I array elements and key-value pairs with commas. This + can be annoying if you write JSON texts manually and want to be able to + quickly append elements, so this extension accepts comma at the end of + such items not just between them: + + [ + 1, + 2, <- this comma not normally allowed + ] + { + "k1": "v1", + "k2": "v2", <- this comma not normally allowed + } + + =item * shell-style '#'-comments + + Whenever JSON allows whitespace, shell-style comments are additionally + allowed. They are terminated by the first carriage-return or line-feed + character, after which more white-space and comments are allowed. + + [ + 1, # this comment not allowed in JSON + # neither this one... + ] + + =back + + + =head2 canonical + + $json = $json->canonical([$enable]) + + $enabled = $json->get_canonical + + If C<$enable> is true (or missing), then the C method will output JSON objects + by sorting their keys. This is adding a comparatively high overhead. + + If C<$enable> is false, then the C method will output key-value + pairs in the order Perl stores them (which will likely change between runs + of the same script). + + This option is useful if you want the same data structure to be encoded as + the same JSON text (given the same overall settings). If it is disabled, + the same hash might be encoded differently even if contains the same data, + as key-value pairs have no inherent ordering in Perl. + + This setting has no effect when decoding JSON texts. + + =head2 allow_nonref + + $json = $json->allow_nonref([$enable]) + + $enabled = $json->get_allow_nonref + + If C<$enable> is true (or missing), then the C method can convert a + non-reference into its corresponding string, number or null JSON value, + which is an extension to RFC4627. Likewise, C will accept those JSON + values instead of croaking. + + If C<$enable> is false, then the C method will croak if it isn't + passed an arrayref or hashref, as JSON texts must either be an object + or array. Likewise, C will croak if given something that is not a + JSON object or array. + + JSON->new->allow_nonref->encode ("Hello, World!") + => "Hello, World!" + + =head2 allow_unknown + + $json = $json->allow_unknown ([$enable]) + + $enabled = $json->get_allow_unknown + + If $enable is true (or missing), then "encode" will *not* throw an + exception when it encounters values it cannot represent in JSON (for + example, filehandles) but instead will encode a JSON "null" value. + Note that blessed objects are not included here and are handled + separately by c. + + If $enable is false (the default), then "encode" will throw an + exception when it encounters anything it cannot encode as JSON. + + This option does not affect "decode" in any way, and it is + recommended to leave it off unless you know your communications + partner. + + =head2 allow_blessed + + $json = $json->allow_blessed([$enable]) + + $enabled = $json->get_allow_blessed + + If C<$enable> is true (or missing), then the C method will not + barf when it encounters a blessed reference. Instead, the value of the + B option will decide whether C (C + disabled or no C method found) or a representation of the + object (C enabled and C method found) is being + encoded. Has no effect on C. + + If C<$enable> is false (the default), then C will throw an + exception when it encounters a blessed object. + + + =head2 convert_blessed + + $json = $json->convert_blessed([$enable]) + + $enabled = $json->get_convert_blessed + + If C<$enable> is true (or missing), then C, upon encountering a + blessed object, will check for the availability of the C method + on the object's class. If found, it will be called in scalar context + and the resulting scalar will be encoded instead of the object. If no + C method is found, the value of C will decide what + to do. + + The C method may safely call die if it wants. If C + returns other blessed objects, those will be handled in the same + way. C must take care of not causing an endless recursion cycle + (== crash) in this case. The name of C was chosen because other + methods called by the Perl core (== not by the user of the object) are + usually in upper case letters and to avoid collisions with the C + function or method. + + This setting does not yet influence C in any way. + + If C<$enable> is false, then the C setting will decide what + to do when a blessed object is found. + + =over + + =item convert_blessed_universally mode + + If use C with C<-convert_blessed_universally>, the C + subroutine is defined as the below code: + + *UNIVERSAL::TO_JSON = sub { + my $b_obj = B::svref_2object( $_[0] ); + return $b_obj->isa('B::HV') ? { %{ $_[0] } } + : $b_obj->isa('B::AV') ? [ @{ $_[0] } ] + : undef + ; + } + + This will cause that C method converts simple blessed objects into + JSON objects as non-blessed object. + + JSON -convert_blessed_universally; + $json->allow_blessed->convert_blessed->encode( $blessed_object ) + + This feature is experimental and may be removed in the future. + + =back + + =head2 filter_json_object + + $json = $json->filter_json_object([$coderef]) + + When C<$coderef> is specified, it will be called from C each + time it decodes a JSON object. The only argument passed to the coderef + is a reference to the newly-created hash. If the code references returns + a single scalar (which need not be a reference), this value + (i.e. a copy of that scalar to avoid aliasing) is inserted into the + deserialised data structure. If it returns an empty list + (NOTE: I C, which is a valid scalar), the original deserialised + hash will be inserted. This setting can slow down decoding considerably. + + When C<$coderef> is omitted or undefined, any existing callback will + be removed and C will not change the deserialised hash in any + way. + + Example, convert all JSON objects into the integer 5: + + my $js = JSON->new->filter_json_object (sub { 5 }); + # returns [5] + $js->decode ('[{}]'); # the given subroutine takes a hash reference. + # throw an exception because allow_nonref is not enabled + # so a lone 5 is not allowed. + $js->decode ('{"a":1, "b":2}'); + + + =head2 filter_json_single_key_object + + $json = $json->filter_json_single_key_object($key [=> $coderef]) + + Works remotely similar to C, but is only called for + JSON objects having a single key named C<$key>. + + This C<$coderef> is called before the one specified via + C, if any. It gets passed the single value in the JSON + object. If it returns a single value, it will be inserted into the data + structure. If it returns nothing (not even C but the empty list), + the callback from C will be called next, as if no + single-key callback were specified. + + If C<$coderef> is omitted or undefined, the corresponding callback will be + disabled. There can only ever be one callback for a given key. + + As this callback gets called less often then the C + one, decoding speed will not usually suffer as much. Therefore, single-key + objects make excellent targets to serialise Perl objects into, especially + as single-key JSON objects are as close to the type-tagged value concept + as JSON gets (it's basically an ID/VALUE tuple). Of course, JSON does not + support this in any way, so you need to make sure your data never looks + like a serialised Perl hash. + + Typical names for the single object key are C<__class_whatever__>, or + C<$__dollars_are_rarely_used__$> or C<}ugly_brace_placement>, or even + things like C<__class_md5sum(classname)__>, to reduce the risk of clashing + with real hashes. + + Example, decode JSON objects of the form C<< { "__widget__" => } >> + into the corresponding C<< $WIDGET{} >> object: + + # return whatever is in $WIDGET{5}: + JSON + ->new + ->filter_json_single_key_object (__widget__ => sub { + $WIDGET{ $_[0] } + }) + ->decode ('{"__widget__": 5') + + # this can be used with a TO_JSON method in some "widget" class + # for serialisation to json: + sub WidgetBase::TO_JSON { + my ($self) = @_; + + unless ($self->{id}) { + $self->{id} = ..get..some..id..; + $WIDGET{$self->{id}} = $self; + } + + { __widget__ => $self->{id} } + } + + + =head2 shrink + + $json = $json->shrink([$enable]) + + $enabled = $json->get_shrink + + With JSON::XS, this flag resizes strings generated by either + C or C to their minimum size possible. This can save + memory when your JSON texts are either very very long or you have many + short strings. It will also try to downgrade any strings to octet-form + if possible: perl stores strings internally either in an encoding called + UTF-X or in octet-form. The latter cannot store everything but uses less + space in general (and some buggy Perl or C code might even rely on that + internal representation being used). + + With JSON::PP, it is noop about resizing strings but tries + C to the returned string by C. See to L. + + See to L and L. + + =head2 max_depth + + $json = $json->max_depth([$maximum_nesting_depth]) + + $max_depth = $json->get_max_depth + + Sets the maximum nesting level (default C<512>) accepted while encoding + or decoding. If a higher nesting level is detected in JSON text or a Perl + data structure, then the encoder and decoder will stop and croak at that + point. + + Nesting level is defined by number of hash- or arrayrefs that the encoder + needs to traverse to reach a given point or the number of C<{> or C<[> + characters without their matching closing parenthesis crossed to reach a + given character in a string. + + If no argument is given, the highest possible setting will be used, which + is rarely useful. + + Note that nesting is implemented by recursion in C. The default value has + been chosen to be as large as typical operating systems allow without + crashing. (JSON::XS) + + With JSON::PP as the backend, when a large value (100 or more) was set and + it de/encodes a deep nested object/text, it may raise a warning + 'Deep recursion on subroutine' at the perl runtime phase. + + See L for more info on why this is useful. + + =head2 max_size + + $json = $json->max_size([$maximum_string_size]) + + $max_size = $json->get_max_size + + Set the maximum length a JSON text may have (in bytes) where decoding is + being attempted. The default is C<0>, meaning no limit. When C + is called on a string that is longer then this many bytes, it will not + attempt to decode the string but throw an exception. This setting has no + effect on C (yet). + + If no argument is given, the limit check will be deactivated (same as when + C<0> is specified). + + See L, below, for more info on why this is useful. + + =head2 encode + + $json_text = $json->encode($perl_scalar) + + Converts the given Perl data structure (a simple scalar or a reference + to a hash or array) to its JSON representation. Simple scalars will be + converted into JSON string or number sequences, while references to arrays + become JSON arrays and references to hashes become JSON objects. Undefined + Perl values (e.g. C) become JSON C values. + References to the integers C<0> and C<1> are converted into C and C. + + =head2 decode + + $perl_scalar = $json->decode($json_text) + + The opposite of C: expects a JSON text and tries to parse it, + returning the resulting simple scalar or reference. Croaks on error. + + JSON numbers and strings become simple Perl scalars. JSON arrays become + Perl arrayrefs and JSON objects become Perl hashrefs. C becomes + C<1> (C), C becomes C<0> (C) and + C becomes C. + + =head2 decode_prefix + + ($perl_scalar, $characters) = $json->decode_prefix($json_text) + + This works like the C method, but instead of raising an exception + when there is trailing garbage after the first JSON object, it will + silently stop parsing there and return the number of characters consumed + so far. + + JSON->new->decode_prefix ("[1] the tail") + => ([], 3) + + See to L + + =head2 property + + $boolean = $json->property($property_name) + + Returns a boolean value about above some properties. + + The available properties are C, C, C, + C,C, C, C, C, + C, C, C, C, + C, C and C. + + $boolean = $json->property('utf8'); + => 0 + $json->utf8; + $boolean = $json->property('utf8'); + => 1 + + Sets the property with a given boolean value. + + $json = $json->property($property_name => $boolean); + + With no argument, it returns all the above properties as a hash reference. + + $flag_hashref = $json->property(); + + =head1 INCREMENTAL PARSING + + Most of this section are copied and modified from L. + + In some cases, there is the need for incremental parsing of JSON texts. + This module does allow you to parse a JSON stream incrementally. + It does so by accumulating text until it has a full JSON object, which + it then can decode. This process is similar to using C + to see if a full JSON object is available, but is much more efficient + (and can be implemented with a minimum of method calls). + + The backend module will only attempt to parse the JSON text once it is sure it + has enough text to get a decisive result, using a very simple but + truly incremental parser. This means that it sometimes won't stop as + early as the full parser, for example, it doesn't detect parenthesis + mismatches. The only thing it guarantees is that it starts decoding as + soon as a syntactically valid JSON text has been seen. This means you need + to set resource limits (e.g. C) to ensure the parser will stop + parsing in the presence if syntax errors. + + The following methods implement this incremental parser. + + =head2 incr_parse + + $json->incr_parse( [$string] ) # void context + + $obj_or_undef = $json->incr_parse( [$string] ) # scalar context + + @obj_or_empty = $json->incr_parse( [$string] ) # list context + + This is the central parsing function. It can both append new text and + extract objects from the stream accumulated so far (both of these + functions are optional). + + If C<$string> is given, then this string is appended to the already + existing JSON fragment stored in the C<$json> object. + + After that, if the function is called in void context, it will simply + return without doing anything further. This can be used to add more text + in as many chunks as you want. + + If the method is called in scalar context, then it will try to extract + exactly I JSON object. If that is successful, it will return this + object, otherwise it will return C. If there is a parse error, + this method will croak just as C would do (one can then use + C to skip the erroneous part). This is the most common way of + using the method. + + And finally, in list context, it will try to extract as many objects + from the stream as it can find and return them, or the empty list + otherwise. For this to work, there must be no separators between the JSON + objects or arrays, instead they must be concatenated back-to-back. If + an error occurs, an exception will be raised as in the scalar context + case. Note that in this case, any previously-parsed JSON texts will be + lost. + + Example: Parse some JSON arrays/objects in a given string and return them. + + my @objs = JSON->new->incr_parse ("[5][7][1,2]"); + + =head2 incr_text + + $lvalue_string = $json->incr_text + + This method returns the currently stored JSON fragment as an lvalue, that + is, you can manipulate it. This I works when a preceding call to + C in I successfully returned an object. Under + all other circumstances you must not call this function (I mean it. + although in simple tests it might actually work, it I fail under + real world conditions). As a special exception, you can also call this + method before having parsed anything. + + This function is useful in two cases: a) finding the trailing text after a + JSON object or b) parsing multiple JSON objects separated by non-JSON text + (such as commas). + + $json->incr_text =~ s/\s*,\s*//; + + In Perl 5.005, C attribute is not available. + You must write codes like the below: + + $string = $json->incr_text; + $string =~ s/\s*,\s*//; + $json->incr_text( $string ); + + =head2 incr_skip + + $json->incr_skip + + This will reset the state of the incremental parser and will remove the + parsed text from the input buffer. This is useful after C + died, in which case the input buffer and incremental parser state is left + unchanged, to skip the text parsed so far and to reset the parse state. + + =head2 incr_reset + + $json->incr_reset + + This completely resets the incremental parser, that is, after this call, + it will be as if the parser had never parsed anything. + + This is useful if you want to repeatedly parse JSON objects and want to + ignore any trailing data, which means you have to reset the parser after + each successful decode. + + See to L for examples. + + + =head1 JSON::PP SUPPORT METHODS + + The below methods are JSON::PP own methods, so when C works + with JSON::PP (i.e. the created object is a JSON::PP object), available. + See to L in detail. + + If you use C with additional C<-support_by_pp>, some methods + are available even with JSON::XS. See to L. + + BEING { $ENV{PERL_JSON_BACKEND} = 'JSON::XS' } + + use JSON -support_by_pp; + + my $json = JSON->new; + $json->allow_nonref->escape_slash->encode("/"); + + # functional interfaces too. + print to_json(["/"], {escape_slash => 1}); + print from_json('["foo"]', {utf8 => 1}); + + If you do not want to all functions but C<-support_by_pp>, + use C<-no_export>. + + use JSON -support_by_pp, -no_export; + # functional interfaces are not exported. + + =head2 allow_singlequote + + $json = $json->allow_singlequote([$enable]) + + If C<$enable> is true (or missing), then C will accept + any JSON strings quoted by single quotations that are invalid JSON + format. + + $json->allow_singlequote->decode({"foo":'bar'}); + $json->allow_singlequote->decode({'foo':"bar"}); + $json->allow_singlequote->decode({'foo':'bar'}); + + As same as the C option, this option may be used to parse + application-specific files written by humans. + + =head2 allow_barekey + + $json = $json->allow_barekey([$enable]) + + If C<$enable> is true (or missing), then C will accept + bare keys of JSON object that are invalid JSON format. + + As same as the C option, this option may be used to parse + application-specific files written by humans. + + $json->allow_barekey->decode('{foo:"bar"}'); + + =head2 allow_bignum + + $json = $json->allow_bignum([$enable]) + + If C<$enable> is true (or missing), then C will convert + the big integer Perl cannot handle as integer into a L + object and convert a floating number (any) into a L. + + On the contrary, C converts C objects and C + objects into JSON numbers with C enable. + + $json->allow_nonref->allow_blessed->allow_bignum; + $bigfloat = $json->decode('2.000000000000000000000000001'); + print $json->encode($bigfloat); + # => 2.000000000000000000000000001 + + See to L about the conversion of JSON number. + + =head2 loose + + $json = $json->loose([$enable]) + + The unescaped [\x00-\x1f\x22\x2f\x5c] strings are invalid in JSON strings + and the module doesn't allow to C to these (except for \x2f). + If C<$enable> is true (or missing), then C will accept these + unescaped strings. + + $json->loose->decode(qq|["abc + def"]|); + + See to L. + + =head2 escape_slash + + $json = $json->escape_slash([$enable]) + + According to JSON Grammar, I (U+002F) is escaped. But by default + JSON backend modules encode strings without escaping slash. + + If C<$enable> is true (or missing), then C will escape slashes. + + =head2 indent_length + + $json = $json->indent_length($length) + + With JSON::XS, The indent space length is 3 and cannot be changed. + With JSON::PP, it sets the indent space length with the given $length. + The default is 3. The acceptable range is 0 to 15. + + =head2 sort_by + + $json = $json->sort_by($function_name) + $json = $json->sort_by($subroutine_ref) + + If $function_name or $subroutine_ref are set, its sort routine are used. + + $js = $pc->sort_by(sub { $JSON::PP::a cmp $JSON::PP::b })->encode($obj); + # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|); + + $js = $pc->sort_by('own_sort')->encode($obj); + # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|); + + sub JSON::PP::own_sort { $JSON::PP::a cmp $JSON::PP::b } + + As the sorting routine runs in the JSON::PP scope, the given + subroutine name and the special variables C<$a>, C<$b> will begin + with 'JSON::PP::'. + + If $integer is set, then the effect is same as C on. + + See to L. + + =head1 MAPPING + + This section is copied from JSON::XS and modified to C. + JSON::XS and JSON::PP mapping mechanisms are almost equivalent. + + See to L. + + =head2 JSON -> PERL + + =over 4 + + =item object + + A JSON object becomes a reference to a hash in Perl. No ordering of object + keys is preserved (JSON does not preserver object key ordering itself). + + =item array + + A JSON array becomes a reference to an array in Perl. + + =item string + + A JSON string becomes a string scalar in Perl - Unicode codepoints in JSON + are represented by the same codepoints in the Perl string, so no manual + decoding is necessary. + + =item number + + A JSON number becomes either an integer, numeric (floating point) or + string scalar in perl, depending on its range and any fractional parts. On + the Perl level, there is no difference between those as Perl handles all + the conversion details, but an integer may take slightly less memory and + might represent more values exactly than floating point numbers. + + If the number consists of digits only, C will try to represent + it as an integer value. If that fails, it will try to represent it as + a numeric (floating point) value if that is possible without loss of + precision. Otherwise it will preserve the number as a string value (in + which case you lose roundtripping ability, as the JSON number will be + re-encoded to a JSON string). + + Numbers containing a fractional or exponential part will always be + represented as numeric (floating point) values, possibly at a loss of + precision (in which case you might lose perfect roundtripping ability, but + the JSON number will still be re-encoded as a JSON number). + + Note that precision is not accuracy - binary floating point values cannot + represent most decimal fractions exactly, and when converting from and to + floating point, C only guarantees precision up to but not including + the least significant bit. + + If the backend is JSON::PP and C is enable, the big integers + and the numeric can be optionally converted into L and + L objects. + + =item true, false + + These JSON atoms become C and C, + respectively. They are overloaded to act almost exactly like the numbers + C<1> and C<0>. You can check whether a scalar is a JSON boolean by using + the C function. + + print JSON::true + 1; + => 1 + + ok(JSON::true eq '1'); + ok(JSON::true == 1); + + C will install these missing overloading features to the backend modules. + + + =item null + + A JSON null atom becomes C in Perl. + + C returns C. + + =back + + + =head2 PERL -> JSON + + The mapping from Perl to JSON is slightly more difficult, as Perl is a + truly typeless language, so we can only guess which JSON type is meant by + a Perl value. + + =over 4 + + =item hash references + + Perl hash references become JSON objects. As there is no inherent ordering + in hash keys (or JSON objects), they will usually be encoded in a + pseudo-random order that can change between runs of the same program but + stays generally the same within a single run of a program. C + optionally sort the hash keys (determined by the I flag), so + the same data structure will serialise to the same JSON text (given same + settings and version of JSON::XS), but this incurs a runtime overhead + and is only rarely useful, e.g. when you want to compare some JSON text + against another for equality. + + In future, the ordered object feature will be added to JSON::PP using C mechanism. + + + =item array references + + Perl array references become JSON arrays. + + =item other references + + Other unblessed references are generally not allowed and will cause an + exception to be thrown, except for references to the integers C<0> and + C<1>, which get turned into C and C atoms in JSON. You can + also use C and C to improve readability. + + to_json [\0,JSON::true] # yields [false,true] + + =item JSON::true, JSON::false, JSON::null + + These special values become JSON true and JSON false values, + respectively. You can also use C<\1> and C<\0> directly if you want. + + JSON::null returns C. + + =item blessed objects + + Blessed objects are not directly representable in JSON. See the + C and C methods on various options on + how to deal with this: basically, you can choose between throwing an + exception, encoding the reference as if it weren't blessed, or provide + your own serialiser method. + + With C mode, C converts blessed + hash references or blessed array references (contains other blessed references) + into JSON members and arrays. + + use JSON -convert_blessed_universally; + JSON->new->allow_blessed->convert_blessed->encode( $blessed_object ); + + See to L. + + =item simple scalars + + Simple Perl scalars (any scalar that is not a reference) are the most + difficult objects to encode: JSON::XS and JSON::PP will encode undefined scalars as + JSON C values, scalars that have last been used in a string context + before encoding as JSON strings, and anything else as number value: + + # dump as number + encode_json [2] # yields [2] + encode_json [-3.0e17] # yields [-3e+17] + my $value = 5; encode_json [$value] # yields [5] + + # used as string, so dump as string + print $value; + encode_json [$value] # yields ["5"] + + # undef becomes null + encode_json [undef] # yields [null] + + You can force the type to be a string by stringifying it: + + my $x = 3.1; # some variable containing a number + "$x"; # stringified + $x .= ""; # another, more awkward way to stringify + print $x; # perl does it for you, too, quite often + + You can force the type to be a number by numifying it: + + my $x = "3"; # some variable containing a string + $x += 0; # numify it, ensuring it will be dumped as a number + $x *= 1; # same thing, the choice is yours. + + You can not currently force the type in other, less obscure, ways. + + Note that numerical precision has the same meaning as under Perl (so + binary to decimal conversion follows the same rules as in Perl, which + can differ to other languages). Also, your perl interpreter might expose + extensions to the floating point numbers of your platform, such as + infinities or NaN's - these cannot be represented in JSON, and it is an + error to pass those in. + + =item Big Number + + If the backend is JSON::PP and C is enable, + C converts C objects and C + objects into JSON numbers. + + + =back + + =head1 JSON and ECMAscript + + See to L. + + =head1 JSON and YAML + + JSON is not a subset of YAML. + See to L. + + + =head1 BACKEND MODULE DECISION + + When you use C, C tries to C JSON::XS. If this call failed, it will + C JSON::PP. The required JSON::XS version is I<2.2> or later. + + The C constructor method returns an object inherited from the backend module, + and JSON::XS object is a blessed scalar reference while JSON::PP is a blessed hash + reference. + + So, your program should not depend on the backend module, especially + returned objects should not be modified. + + my $json = JSON->new; # XS or PP? + $json->{stash} = 'this is xs object'; # this code may raise an error! + + To check the backend module, there are some methods - C, C and C. + + JSON->backend; # 'JSON::XS' or 'JSON::PP' + + JSON->backend->is_pp: # 0 or 1 + + JSON->backend->is_xs: # 1 or 0 + + $json->is_xs; # 1 or 0 + + $json->is_pp; # 0 or 1 + + + If you set an environment variable C, the calling action will be changed. + + =over + + =item PERL_JSON_BACKEND = 0 or PERL_JSON_BACKEND = 'JSON::PP' + + Always use JSON::PP + + =item PERL_JSON_BACKEND == 1 or PERL_JSON_BACKEND = 'JSON::XS,JSON::PP' + + (The default) Use compiled JSON::XS if it is properly compiled & installed, + otherwise use JSON::PP. + + =item PERL_JSON_BACKEND == 2 or PERL_JSON_BACKEND = 'JSON::XS' + + Always use compiled JSON::XS, die if it isn't properly compiled & installed. + + =item PERL_JSON_BACKEND = 'JSON::backportPP' + + Always use JSON::backportPP. + JSON::backportPP is JSON::PP back port module. + C includes JSON::backportPP instead of JSON::PP. + + =back + + These ideas come from L mechanism. + + example: + + BEGIN { $ENV{PERL_JSON_BACKEND} = 'JSON::PP' } + use JSON; # always uses JSON::PP + + In future, it may be able to specify another module. + + =head1 USE PP FEATURES EVEN THOUGH XS BACKEND + + Many methods are available with either JSON::XS or JSON::PP and + when the backend module is JSON::XS, if any JSON::PP specific (i.e. JSON::XS unsupported) + method is called, it will C and be noop. + + But If you C C passing the optional string C<-support_by_pp>, + it makes a part of those unsupported methods available. + This feature is achieved by using JSON::PP in C. + + BEGIN { $ENV{PERL_JSON_BACKEND} = 2 } # with JSON::XS + use JSON -support_by_pp; + my $json = JSON->new; + $json->allow_nonref->escape_slash->encode("/"); + + At this time, the returned object is a C + object (re-blessed XS object), and by checking JSON::XS unsupported flags + in de/encoding, can support some unsupported methods - C, C, + C, C, C and C. + + When any unsupported methods are not enable, C will be + used as is. The switch is achieved by changing the symbolic tables. + + C<-support_by_pp> is effective only when the backend module is JSON::XS + and it makes the de/encoding speed down a bit. + + See to L. + + =head1 INCOMPATIBLE CHANGES TO OLD VERSION + + There are big incompatibility between new version (2.00) and old (1.xx). + If you use old C 1.xx in your code, please check it. + + See to L + + =over + + =item jsonToObj and objToJson are obsoleted. + + Non Perl-style name C and C are obsoleted + (but not yet deleted from the source). + If you use these functions in your code, please replace them + with C and C. + + + =item Global variables are no longer available. + + C class variables - C<$JSON::AUTOCONVERT>, C<$JSON::BareKey>, etc... + - are not available any longer. + Instead, various features can be used through object methods. + + + =item Package JSON::Converter and JSON::Parser are deleted. + + Now C bundles with JSON::PP which can handle JSON more properly than them. + + =item Package JSON::NotString is deleted. + + There was C class which represents JSON value C, C, C + and numbers. It was deleted and replaced by C. + + C represents C and C. + + C does not represent C. + + C returns C. + + C makes L and L is-a relation + to L. + + =item function JSON::Number is obsoleted. + + C is now needless because JSON::XS and JSON::PP have + round-trip integrity. + + =item JSONRPC modules are deleted. + + Perl implementation of JSON-RPC protocol - C, C + and C are deleted in this distribution. + Instead of them, there is L which supports JSON-RPC protocol version 1.1. + + =back + + =head2 Transition ways from 1.xx to 2.xx. + + You should set C mode firstly, because + it is always successful for the below codes even with JSON::XS. + + use JSON -support_by_pp; + + =over + + =item Exported jsonToObj (simple) + + from_json($json_text); + + =item Exported objToJson (simple) + + to_json($perl_scalar); + + =item Exported jsonToObj (advanced) + + $flags = {allow_barekey => 1, allow_singlequote => 1}; + from_json($json_text, $flags); + + equivalent to: + + $JSON::BareKey = 1; + $JSON::QuotApos = 1; + jsonToObj($json_text); + + =item Exported objToJson (advanced) + + $flags = {allow_blessed => 1, allow_barekey => 1}; + to_json($perl_scalar, $flags); + + equivalent to: + + $JSON::BareKey = 1; + objToJson($perl_scalar); + + =item jsonToObj as object method + + $json->decode($json_text); + + =item objToJson as object method + + $json->encode($perl_scalar); + + =item new method with parameters + + The C method in 2.x takes any parameters no longer. + You can set parameters instead; + + $json = JSON->new->pretty; + + =item $JSON::Pretty, $JSON::Indent, $JSON::Delimiter + + If C is enable, that means C<$JSON::Pretty> flag set. And + C<$JSON::Delimiter> was substituted by C and C. + In conclusion: + + $json->indent->space_before->space_after; + + Equivalent to: + + $json->pretty; + + To change indent length, use C. + + (Only with JSON::PP, if C<-support_by_pp> is not used.) + + $json->pretty->indent_length(2)->encode($perl_scalar); + + =item $JSON::BareKey + + (Only with JSON::PP, if C<-support_by_pp> is not used.) + + $json->allow_barekey->decode($json_text) + + =item $JSON::ConvBlessed + + use C<-convert_blessed_universally>. See to L. + + =item $JSON::QuotApos + + (Only with JSON::PP, if C<-support_by_pp> is not used.) + + $json->allow_singlequote->decode($json_text) + + =item $JSON::SingleQuote + + Disable. C does not make such a invalid JSON string any longer. + + =item $JSON::KeySort + + $json->canonical->encode($perl_scalar) + + This is the ascii sort. + + If you want to use with your own sort routine, check the C method. + + (Only with JSON::PP, even if C<-support_by_pp> is used currently.) + + $json->sort_by($sort_routine_ref)->encode($perl_scalar) + + $json->sort_by(sub { $JSON::PP::a <=> $JSON::PP::b })->encode($perl_scalar) + + Can't access C<$a> and C<$b> but C<$JSON::PP::a> and C<$JSON::PP::b>. + + =item $JSON::SkipInvalid + + $json->allow_unknown + + =item $JSON::AUTOCONVERT + + Needless. C backend modules have the round-trip integrity. + + =item $JSON::UTF8 + + Needless because C (JSON::XS/JSON::PP) sets + the UTF8 flag on properly. + + # With UTF8-flagged strings + + $json->allow_nonref; + $str = chr(1000); # UTF8-flagged + + $json_text = $json->utf8(0)->encode($str); + utf8::is_utf8($json_text); + # true + $json_text = $json->utf8(1)->encode($str); + utf8::is_utf8($json_text); + # false + + $str = '"' . chr(1000) . '"'; # UTF8-flagged + + $perl_scalar = $json->utf8(0)->decode($str); + utf8::is_utf8($perl_scalar); + # true + $perl_scalar = $json->utf8(1)->decode($str); + # died because of 'Wide character in subroutine' + + See to L. + + =item $JSON::UnMapping + + Disable. See to L. + + =item $JSON::SelfConvert + + This option was deleted. + Instead of it, if a given blessed object has the C method, + C will be executed with C. + + $json->convert_blessed->encode($blessed_hashref_or_arrayref) + # if need, call allow_blessed + + Note that it was C in old version, but now not C but C. + + =back + + =head1 TODO + + =over + + =item example programs + + =back + + =head1 THREADS + + No test with JSON::PP. If with JSON::XS, See to L. + + + =head1 BUGS + + Please report bugs relevant to C to Emakamaka[at]cpan.orgE. + + + =head1 SEE ALSO + + Most of the document is copied and modified from JSON::XS doc. + + L, L + + C(L) + + =head1 AUTHOR + + Makamaka Hannyaharamitu, Emakamaka[at]cpan.orgE + + JSON::XS was written by Marc Lehmann + + The release of this new version owes to the courtesy of Marc Lehmann. + + + =head1 COPYRIGHT AND LICENSE + + Copyright 2005-2013 by Makamaka Hannyaharamitu + + This library is free software; you can redistribute it and/or modify + it under the same terms as Perl itself. + + =cut + +JSON + +$fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP'; + package JSON::PP; + + # JSON-2.0 + + use 5.005; + use strict; + use base qw(Exporter); + use overload (); + + use Carp (); + use B (); + #use Devel::Peek; + + $JSON::PP::VERSION = '2.27203'; + + @JSON::PP::EXPORT = qw(encode_json decode_json from_json to_json); + + # instead of hash-access, i tried index-access for speed. + # but this method is not faster than what i expected. so it will be changed. + + use constant P_ASCII => 0; + use constant P_LATIN1 => 1; + use constant P_UTF8 => 2; + use constant P_INDENT => 3; + use constant P_CANONICAL => 4; + use constant P_SPACE_BEFORE => 5; + use constant P_SPACE_AFTER => 6; + use constant P_ALLOW_NONREF => 7; + use constant P_SHRINK => 8; + use constant P_ALLOW_BLESSED => 9; + use constant P_CONVERT_BLESSED => 10; + use constant P_RELAXED => 11; + + use constant P_LOOSE => 12; + use constant P_ALLOW_BIGNUM => 13; + use constant P_ALLOW_BAREKEY => 14; + use constant P_ALLOW_SINGLEQUOTE => 15; + use constant P_ESCAPE_SLASH => 16; + use constant P_AS_NONBLESSED => 17; + + use constant P_ALLOW_UNKNOWN => 18; + + use constant OLD_PERL => $] < 5.008 ? 1 : 0; + + BEGIN { + my @xs_compati_bit_properties = qw( + latin1 ascii utf8 indent canonical space_before space_after allow_nonref shrink + allow_blessed convert_blessed relaxed allow_unknown + ); + my @pp_bit_properties = qw( + allow_singlequote allow_bignum loose + allow_barekey escape_slash as_nonblessed + ); + + # Perl version check, Unicode handling is enable? + # Helper module sets @JSON::PP::_properties. + if ($] < 5.008 ) { + my $helper = $] >= 5.006 ? 'JSON::PP::Compat5006' : 'JSON::PP::Compat5005'; + eval qq| require $helper |; + if ($@) { Carp::croak $@; } + } + + for my $name (@xs_compati_bit_properties, @pp_bit_properties) { + my $flag_name = 'P_' . uc($name); + + eval qq/ + sub $name { + my \$enable = defined \$_[1] ? \$_[1] : 1; + + if (\$enable) { + \$_[0]->{PROPS}->[$flag_name] = 1; + } + else { + \$_[0]->{PROPS}->[$flag_name] = 0; + } + + \$_[0]; + } + + sub get_$name { + \$_[0]->{PROPS}->[$flag_name] ? 1 : ''; + } + /; + } + + } + + + + # Functions + + my %encode_allow_method + = map {($_ => 1)} qw/utf8 pretty allow_nonref latin1 self_encode escape_slash + allow_blessed convert_blessed indent indent_length allow_bignum + as_nonblessed + /; + my %decode_allow_method + = map {($_ => 1)} qw/utf8 allow_nonref loose allow_singlequote allow_bignum + allow_barekey max_size relaxed/; + + + my $JSON; # cache + + sub encode_json ($) { # encode + ($JSON ||= __PACKAGE__->new->utf8)->encode(@_); + } + + + sub decode_json { # decode + ($JSON ||= __PACKAGE__->new->utf8)->decode(@_); + } + + # Obsoleted + + sub to_json($) { + Carp::croak ("JSON::PP::to_json has been renamed to encode_json."); + } + + + sub from_json($) { + Carp::croak ("JSON::PP::from_json has been renamed to decode_json."); + } + + + # Methods + + sub new { + my $class = shift; + my $self = { + max_depth => 512, + max_size => 0, + indent => 0, + FLAGS => 0, + fallback => sub { encode_error('Invalid value. JSON can only reference.') }, + indent_length => 3, + }; + + bless $self, $class; + } + + + sub encode { + return $_[0]->PP_encode_json($_[1]); + } + + + sub decode { + return $_[0]->PP_decode_json($_[1], 0x00000000); + } + + + sub decode_prefix { + return $_[0]->PP_decode_json($_[1], 0x00000001); + } + + + # accessor + + + # pretty printing + + sub pretty { + my ($self, $v) = @_; + my $enable = defined $v ? $v : 1; + + if ($enable) { # indent_length(3) for JSON::XS compatibility + $self->indent(1)->indent_length(3)->space_before(1)->space_after(1); + } + else { + $self->indent(0)->space_before(0)->space_after(0); + } + + $self; + } + + # etc + + sub max_depth { + my $max = defined $_[1] ? $_[1] : 0x80000000; + $_[0]->{max_depth} = $max; + $_[0]; + } + + + sub get_max_depth { $_[0]->{max_depth}; } + + + sub max_size { + my $max = defined $_[1] ? $_[1] : 0; + $_[0]->{max_size} = $max; + $_[0]; + } + + + sub get_max_size { $_[0]->{max_size}; } + + + sub filter_json_object { + $_[0]->{cb_object} = defined $_[1] ? $_[1] : 0; + $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0; + $_[0]; + } + + sub filter_json_single_key_object { + if (@_ > 1) { + $_[0]->{cb_sk_object}->{$_[1]} = $_[2]; + } + $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0; + $_[0]; + } + + sub indent_length { + if (!defined $_[1] or $_[1] > 15 or $_[1] < 0) { + Carp::carp "The acceptable range of indent_length() is 0 to 15."; + } + else { + $_[0]->{indent_length} = $_[1]; + } + $_[0]; + } + + sub get_indent_length { + $_[0]->{indent_length}; + } + + sub sort_by { + $_[0]->{sort_by} = defined $_[1] ? $_[1] : 1; + $_[0]; + } + + sub allow_bigint { + Carp::carp("allow_bigint() is obsoleted. use allow_bignum() insted."); + } + + ############################### + + ### + ### Perl => JSON + ### + + + { # Convert + + my $max_depth; + my $indent; + my $ascii; + my $latin1; + my $utf8; + my $space_before; + my $space_after; + my $canonical; + my $allow_blessed; + my $convert_blessed; + + my $indent_length; + my $escape_slash; + my $bignum; + my $as_nonblessed; + + my $depth; + my $indent_count; + my $keysort; + + + sub PP_encode_json { + my $self = shift; + my $obj = shift; + + $indent_count = 0; + $depth = 0; + + my $idx = $self->{PROPS}; + + ($ascii, $latin1, $utf8, $indent, $canonical, $space_before, $space_after, $allow_blessed, + $convert_blessed, $escape_slash, $bignum, $as_nonblessed) + = @{$idx}[P_ASCII .. P_SPACE_AFTER, P_ALLOW_BLESSED, P_CONVERT_BLESSED, + P_ESCAPE_SLASH, P_ALLOW_BIGNUM, P_AS_NONBLESSED]; + + ($max_depth, $indent_length) = @{$self}{qw/max_depth indent_length/}; + + $keysort = $canonical ? sub { $a cmp $b } : undef; + + if ($self->{sort_by}) { + $keysort = ref($self->{sort_by}) eq 'CODE' ? $self->{sort_by} + : $self->{sort_by} =~ /\D+/ ? $self->{sort_by} + : sub { $a cmp $b }; + } + + encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)") + if(!ref $obj and !$idx->[ P_ALLOW_NONREF ]); + + my $str = $self->object_to_json($obj); + + $str .= "\n" if ( $indent ); # JSON::XS 2.26 compatible + + unless ($ascii or $latin1 or $utf8) { + utf8::upgrade($str); + } + + if ($idx->[ P_SHRINK ]) { + utf8::downgrade($str, 1); + } + + return $str; + } + + + sub object_to_json { + my ($self, $obj) = @_; + my $type = ref($obj); + + if($type eq 'HASH'){ + return $self->hash_to_json($obj); + } + elsif($type eq 'ARRAY'){ + return $self->array_to_json($obj); + } + elsif ($type) { # blessed object? + if (blessed($obj)) { + + return $self->value_to_json($obj) if ( $obj->isa('JSON::PP::Boolean') ); + + if ( $convert_blessed and $obj->can('TO_JSON') ) { + my $result = $obj->TO_JSON(); + if ( defined $result and ref( $result ) ) { + if ( refaddr( $obj ) eq refaddr( $result ) ) { + encode_error( sprintf( + "%s::TO_JSON method returned same object as was passed instead of a new one", + ref $obj + ) ); + } + } + + return $self->object_to_json( $result ); + } + + return "$obj" if ( $bignum and _is_bignum($obj) ); + return $self->blessed_to_json($obj) if ($allow_blessed and $as_nonblessed); # will be removed. + + encode_error( sprintf("encountered object '%s', but neither allow_blessed " + . "nor convert_blessed settings are enabled", $obj) + ) unless ($allow_blessed); + + return 'null'; + } + else { + return $self->value_to_json($obj); + } + } + else{ + return $self->value_to_json($obj); + } + } + + + sub hash_to_json { + my ($self, $obj) = @_; + my @res; + + encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)") + if (++$depth > $max_depth); + + my ($pre, $post) = $indent ? $self->_up_indent() : ('', ''); + my $del = ($space_before ? ' ' : '') . ':' . ($space_after ? ' ' : ''); + + for my $k ( _sort( $obj ) ) { + if ( OLD_PERL ) { utf8::decode($k) } # key for Perl 5.6 / be optimized + push @res, string_to_json( $self, $k ) + . $del + . ( $self->object_to_json( $obj->{$k} ) || $self->value_to_json( $obj->{$k} ) ); + } + + --$depth; + $self->_down_indent() if ($indent); + + return '{' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . '}'; + } + + + sub array_to_json { + my ($self, $obj) = @_; + my @res; + + encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)") + if (++$depth > $max_depth); + + my ($pre, $post) = $indent ? $self->_up_indent() : ('', ''); + + for my $v (@$obj){ + push @res, $self->object_to_json($v) || $self->value_to_json($v); + } + + --$depth; + $self->_down_indent() if ($indent); + + return '[' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . ']'; + } + + + sub value_to_json { + my ($self, $value) = @_; + + return 'null' if(!defined $value); + + my $b_obj = B::svref_2object(\$value); # for round trip problem + my $flags = $b_obj->FLAGS; + + return $value # as is + if $flags & ( B::SVp_IOK | B::SVp_NOK ) and !( $flags & B::SVp_POK ); # SvTYPE is IV or NV? + + my $type = ref($value); + + if(!$type){ + return string_to_json($self, $value); + } + elsif( blessed($value) and $value->isa('JSON::PP::Boolean') ){ + return $$value == 1 ? 'true' : 'false'; + } + elsif ($type) { + if ((overload::StrVal($value) =~ /=(\w+)/)[0]) { + return $self->value_to_json("$value"); + } + + if ($type eq 'SCALAR' and defined $$value) { + return $$value eq '1' ? 'true' + : $$value eq '0' ? 'false' + : $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ? 'null' + : encode_error("cannot encode reference to scalar"); + } + + if ( $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ) { + return 'null'; + } + else { + if ( $type eq 'SCALAR' or $type eq 'REF' ) { + encode_error("cannot encode reference to scalar"); + } + else { + encode_error("encountered $value, but JSON can only represent references to arrays or hashes"); + } + } + + } + else { + return $self->{fallback}->($value) + if ($self->{fallback} and ref($self->{fallback}) eq 'CODE'); + return 'null'; + } + + } + + + my %esc = ( + "\n" => '\n', + "\r" => '\r', + "\t" => '\t', + "\f" => '\f', + "\b" => '\b', + "\"" => '\"', + "\\" => '\\\\', + "\'" => '\\\'', + ); + + + sub string_to_json { + my ($self, $arg) = @_; + + $arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g; + $arg =~ s/\//\\\//g if ($escape_slash); + $arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg; + + if ($ascii) { + $arg = JSON_PP_encode_ascii($arg); + } + + if ($latin1) { + $arg = JSON_PP_encode_latin1($arg); + } + + if ($utf8) { + utf8::encode($arg); + } + + return '"' . $arg . '"'; + } + + + sub blessed_to_json { + my $reftype = reftype($_[1]) || ''; + if ($reftype eq 'HASH') { + return $_[0]->hash_to_json($_[1]); + } + elsif ($reftype eq 'ARRAY') { + return $_[0]->array_to_json($_[1]); + } + else { + return 'null'; + } + } + + + sub encode_error { + my $error = shift; + Carp::croak "$error"; + } + + + sub _sort { + defined $keysort ? (sort $keysort (keys %{$_[0]})) : keys %{$_[0]}; + } + + + sub _up_indent { + my $self = shift; + my $space = ' ' x $indent_length; + + my ($pre,$post) = ('',''); + + $post = "\n" . $space x $indent_count; + + $indent_count++; + + $pre = "\n" . $space x $indent_count; + + return ($pre,$post); + } + + + sub _down_indent { $indent_count--; } + + + sub PP_encode_box { + { + depth => $depth, + indent_count => $indent_count, + }; + } + + } # Convert + + + sub _encode_ascii { + join('', + map { + $_ <= 127 ? + chr($_) : + $_ <= 65535 ? + sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_)); + } unpack('U*', $_[0]) + ); + } + + + sub _encode_latin1 { + join('', + map { + $_ <= 255 ? + chr($_) : + $_ <= 65535 ? + sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_)); + } unpack('U*', $_[0]) + ); + } + + + sub _encode_surrogates { # from perlunicode + my $uni = $_[0] - 0x10000; + return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00); + } + + + sub _is_bignum { + $_[0]->isa('Math::BigInt') or $_[0]->isa('Math::BigFloat'); + } + + + + # + # JSON => Perl + # + + my $max_intsize; + + BEGIN { + my $checkint = 1111; + for my $d (5..64) { + $checkint .= 1; + my $int = eval qq| $checkint |; + if ($int =~ /[eE]/) { + $max_intsize = $d - 1; + last; + } + } + } + + { # PARSE + + my %escapes = ( # by Jeremy Muhlich + b => "\x8", + t => "\x9", + n => "\xA", + f => "\xC", + r => "\xD", + '\\' => '\\', + '"' => '"', + '/' => '/', + ); + + my $text; # json data + my $at; # offset + my $ch; # 1chracter + my $len; # text length (changed according to UTF8 or NON UTF8) + # INTERNAL + my $depth; # nest counter + my $encoding; # json text encoding + my $is_valid_utf8; # temp variable + my $utf8_len; # utf8 byte length + # FLAGS + my $utf8; # must be utf8 + my $max_depth; # max nest nubmer of objects and arrays + my $max_size; + my $relaxed; + my $cb_object; + my $cb_sk_object; + + my $F_HOOK; + + my $allow_bigint; # using Math::BigInt + my $singlequote; # loosely quoting + my $loose; # + my $allow_barekey; # bareKey + + # $opt flag + # 0x00000001 .... decode_prefix + # 0x10000000 .... incr_parse + + sub PP_decode_json { + my ($self, $opt); # $opt is an effective flag during this decode_json. + + ($self, $text, $opt) = @_; + + ($at, $ch, $depth) = (0, '', 0); + + if ( !defined $text or ref $text ) { + decode_error("malformed JSON string, neither array, object, number, string or atom"); + } + + my $idx = $self->{PROPS}; + + ($utf8, $relaxed, $loose, $allow_bigint, $allow_barekey, $singlequote) + = @{$idx}[P_UTF8, P_RELAXED, P_LOOSE .. P_ALLOW_SINGLEQUOTE]; + + if ( $utf8 ) { + utf8::downgrade( $text, 1 ) or Carp::croak("Wide character in subroutine entry"); + } + else { + utf8::upgrade( $text ); + } + + $len = length $text; + + ($max_depth, $max_size, $cb_object, $cb_sk_object, $F_HOOK) + = @{$self}{qw/max_depth max_size cb_object cb_sk_object F_HOOK/}; + + if ($max_size > 1) { + use bytes; + my $bytes = length $text; + decode_error( + sprintf("attempted decode of JSON text of %s bytes size, but max_size is set to %s" + , $bytes, $max_size), 1 + ) if ($bytes > $max_size); + } + + # Currently no effect + # should use regexp + my @octets = unpack('C4', $text); + $encoding = ( $octets[0] and $octets[1]) ? 'UTF-8' + : (!$octets[0] and $octets[1]) ? 'UTF-16BE' + : (!$octets[0] and !$octets[1]) ? 'UTF-32BE' + : ( $octets[2] ) ? 'UTF-16LE' + : (!$octets[2] ) ? 'UTF-32LE' + : 'unknown'; + + white(); # remove head white space + + my $valid_start = defined $ch; # Is there a first character for JSON structure? + + my $result = value(); + + return undef if ( !$result && ( $opt & 0x10000000 ) ); # for incr_parse + + decode_error("malformed JSON string, neither array, object, number, string or atom") unless $valid_start; + + if ( !$idx->[ P_ALLOW_NONREF ] and !ref $result ) { + decode_error( + 'JSON text must be an object or array (but found number, string, true, false or null,' + . ' use allow_nonref to allow this)', 1); + } + + Carp::croak('something wrong.') if $len < $at; # we won't arrive here. + + my $consumed = defined $ch ? $at - 1 : $at; # consumed JSON text length + + white(); # remove tail white space + + if ( $ch ) { + return ( $result, $consumed ) if ($opt & 0x00000001); # all right if decode_prefix + decode_error("garbage after JSON object"); + } + + ( $opt & 0x00000001 ) ? ( $result, $consumed ) : $result; + } + + + sub next_chr { + return $ch = undef if($at >= $len); + $ch = substr($text, $at++, 1); + } + + + sub value { + white(); + return if(!defined $ch); + return object() if($ch eq '{'); + return array() if($ch eq '['); + return string() if($ch eq '"' or ($singlequote and $ch eq "'")); + return number() if($ch =~ /[0-9]/ or $ch eq '-'); + return word(); + } + + sub string { + my ($i, $s, $t, $u); + my $utf16; + my $is_utf8; + + ($is_valid_utf8, $utf8_len) = ('', 0); + + $s = ''; # basically UTF8 flag on + + if($ch eq '"' or ($singlequote and $ch eq "'")){ + my $boundChar = $ch; + + OUTER: while( defined(next_chr()) ){ + + if($ch eq $boundChar){ + next_chr(); + + if ($utf16) { + decode_error("missing low surrogate character in surrogate pair"); + } + + utf8::decode($s) if($is_utf8); + + return $s; + } + elsif($ch eq '\\'){ + next_chr(); + if(exists $escapes{$ch}){ + $s .= $escapes{$ch}; + } + elsif($ch eq 'u'){ # UNICODE handling + my $u = ''; + + for(1..4){ + $ch = next_chr(); + last OUTER if($ch !~ /[0-9a-fA-F]/); + $u .= $ch; + } + + # U+D800 - U+DBFF + if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/) { # UTF-16 high surrogate? + $utf16 = $u; + } + # U+DC00 - U+DFFF + elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/) { # UTF-16 low surrogate? + unless (defined $utf16) { + decode_error("missing high surrogate character in surrogate pair"); + } + $is_utf8 = 1; + $s .= JSON_PP_decode_surrogates($utf16, $u) || next; + $utf16 = undef; + } + else { + if (defined $utf16) { + decode_error("surrogate pair expected"); + } + + if ( ( my $hex = hex( $u ) ) > 127 ) { + $is_utf8 = 1; + $s .= JSON_PP_decode_unicode($u) || next; + } + else { + $s .= chr $hex; + } + } + + } + else{ + unless ($loose) { + $at -= 2; + decode_error('illegal backslash escape sequence in string'); + } + $s .= $ch; + } + } + else{ + + if ( ord $ch > 127 ) { + if ( $utf8 ) { + unless( $ch = is_valid_utf8($ch) ) { + $at -= 1; + decode_error("malformed UTF-8 character in JSON string"); + } + else { + $at += $utf8_len - 1; + } + } + else { + utf8::encode( $ch ); + } + + $is_utf8 = 1; + } + + if (!$loose) { + if ($ch =~ /[\x00-\x1f\x22\x5c]/) { # '/' ok + $at--; + decode_error('invalid character encountered while parsing JSON string'); + } + } + + $s .= $ch; + } + } + } + + decode_error("unexpected end of string while parsing JSON string"); + } + + + sub white { + while( defined $ch ){ + if($ch le ' '){ + next_chr(); + } + elsif($ch eq '/'){ + next_chr(); + if(defined $ch and $ch eq '/'){ + 1 while(defined(next_chr()) and $ch ne "\n" and $ch ne "\r"); + } + elsif(defined $ch and $ch eq '*'){ + next_chr(); + while(1){ + if(defined $ch){ + if($ch eq '*'){ + if(defined(next_chr()) and $ch eq '/'){ + next_chr(); + last; + } + } + else{ + next_chr(); + } + } + else{ + decode_error("Unterminated comment"); + } + } + next; + } + else{ + $at--; + decode_error("malformed JSON string, neither array, object, number, string or atom"); + } + } + else{ + if ($relaxed and $ch eq '#') { # correctly? + pos($text) = $at; + $text =~ /\G([^\n]*(?:\r\n|\r|\n|$))/g; + $at = pos($text); + next_chr; + next; + } + + last; + } + } + } + + + sub array { + my $a = $_[0] || []; # you can use this code to use another array ref object. + + decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)') + if (++$depth > $max_depth); + + next_chr(); + white(); + + if(defined $ch and $ch eq ']'){ + --$depth; + next_chr(); + return $a; + } + else { + while(defined($ch)){ + push @$a, value(); + + white(); + + if (!defined $ch) { + last; + } + + if($ch eq ']'){ + --$depth; + next_chr(); + return $a; + } + + if($ch ne ','){ + last; + } + + next_chr(); + white(); + + if ($relaxed and $ch eq ']') { + --$depth; + next_chr(); + return $a; + } + + } + } + + decode_error(", or ] expected while parsing array"); + } + + + sub object { + my $o = $_[0] || {}; # you can use this code to use another hash ref object. + my $k; + + decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)') + if (++$depth > $max_depth); + next_chr(); + white(); + + if(defined $ch and $ch eq '}'){ + --$depth; + next_chr(); + if ($F_HOOK) { + return _json_object_hook($o); + } + return $o; + } + else { + while (defined $ch) { + $k = ($allow_barekey and $ch ne '"' and $ch ne "'") ? bareKey() : string(); + white(); + + if(!defined $ch or $ch ne ':'){ + $at--; + decode_error("':' expected"); + } + + next_chr(); + $o->{$k} = value(); + white(); + + last if (!defined $ch); + + if($ch eq '}'){ + --$depth; + next_chr(); + if ($F_HOOK) { + return _json_object_hook($o); + } + return $o; + } + + if($ch ne ','){ + last; + } + + next_chr(); + white(); + + if ($relaxed and $ch eq '}') { + --$depth; + next_chr(); + if ($F_HOOK) { + return _json_object_hook($o); + } + return $o; + } + + } + + } + + $at--; + decode_error(", or } expected while parsing object/hash"); + } + + + sub bareKey { # doesn't strictly follow Standard ECMA-262 3rd Edition + my $key; + while($ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){ + $key .= $ch; + next_chr(); + } + return $key; + } + + + sub word { + my $word = substr($text,$at-1,4); + + if($word eq 'true'){ + $at += 3; + next_chr; + return $JSON::PP::true; + } + elsif($word eq 'null'){ + $at += 3; + next_chr; + return undef; + } + elsif($word eq 'fals'){ + $at += 3; + if(substr($text,$at,1) eq 'e'){ + $at++; + next_chr; + return $JSON::PP::false; + } + } + + $at--; # for decode_error report + + decode_error("'null' expected") if ($word =~ /^n/); + decode_error("'true' expected") if ($word =~ /^t/); + decode_error("'false' expected") if ($word =~ /^f/); + decode_error("malformed JSON string, neither array, object, number, string or atom"); + } + + + sub number { + my $n = ''; + my $v; + + # According to RFC4627, hex or oct digts are invalid. + if($ch eq '0'){ + my $peek = substr($text,$at,1); + my $hex = $peek =~ /[xX]/; # 0 or 1 + + if($hex){ + decode_error("malformed number (leading zero must not be followed by another digit)"); + ($n) = ( substr($text, $at+1) =~ /^([0-9a-fA-F]+)/); + } + else{ # oct + ($n) = ( substr($text, $at) =~ /^([0-7]+)/); + if (defined $n and length $n > 1) { + decode_error("malformed number (leading zero must not be followed by another digit)"); + } + } + + if(defined $n and length($n)){ + if (!$hex and length($n) == 1) { + decode_error("malformed number (leading zero must not be followed by another digit)"); + } + $at += length($n) + $hex; + next_chr; + return $hex ? hex($n) : oct($n); + } + } + + if($ch eq '-'){ + $n = '-'; + next_chr; + if (!defined $ch or $ch !~ /\d/) { + decode_error("malformed number (no digits after initial minus)"); + } + } + + while(defined $ch and $ch =~ /\d/){ + $n .= $ch; + next_chr; + } + + if(defined $ch and $ch eq '.'){ + $n .= '.'; + + next_chr; + if (!defined $ch or $ch !~ /\d/) { + decode_error("malformed number (no digits after decimal point)"); + } + else { + $n .= $ch; + } + + while(defined(next_chr) and $ch =~ /\d/){ + $n .= $ch; + } + } + + if(defined $ch and ($ch eq 'e' or $ch eq 'E')){ + $n .= $ch; + next_chr; + + if(defined($ch) and ($ch eq '+' or $ch eq '-')){ + $n .= $ch; + next_chr; + if (!defined $ch or $ch =~ /\D/) { + decode_error("malformed number (no digits after exp sign)"); + } + $n .= $ch; + } + elsif(defined($ch) and $ch =~ /\d/){ + $n .= $ch; + } + else { + decode_error("malformed number (no digits after exp sign)"); + } + + while(defined(next_chr) and $ch =~ /\d/){ + $n .= $ch; + } + + } + + $v .= $n; + + if ($v !~ /[.eE]/ and length $v > $max_intsize) { + if ($allow_bigint) { # from Adam Sussman + require Math::BigInt; + return Math::BigInt->new($v); + } + else { + return "$v"; + } + } + elsif ($allow_bigint) { + require Math::BigFloat; + return Math::BigFloat->new($v); + } + + return 0+$v; + } + + + sub is_valid_utf8 { + + $utf8_len = $_[0] =~ /[\x00-\x7F]/ ? 1 + : $_[0] =~ /[\xC2-\xDF]/ ? 2 + : $_[0] =~ /[\xE0-\xEF]/ ? 3 + : $_[0] =~ /[\xF0-\xF4]/ ? 4 + : 0 + ; + + return unless $utf8_len; + + my $is_valid_utf8 = substr($text, $at - 1, $utf8_len); + + return ( $is_valid_utf8 =~ /^(?: + [\x00-\x7F] + |[\xC2-\xDF][\x80-\xBF] + |[\xE0][\xA0-\xBF][\x80-\xBF] + |[\xE1-\xEC][\x80-\xBF][\x80-\xBF] + |[\xED][\x80-\x9F][\x80-\xBF] + |[\xEE-\xEF][\x80-\xBF][\x80-\xBF] + |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF] + |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF] + |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF] + )$/x ) ? $is_valid_utf8 : ''; + } + + + sub decode_error { + my $error = shift; + my $no_rep = shift; + my $str = defined $text ? substr($text, $at) : ''; + my $mess = ''; + my $type = $] >= 5.008 ? 'U*' + : $] < 5.006 ? 'C*' + : utf8::is_utf8( $str ) ? 'U*' # 5.6 + : 'C*' + ; + + for my $c ( unpack( $type, $str ) ) { # emulate pv_uni_display() ? + $mess .= $c == 0x07 ? '\a' + : $c == 0x09 ? '\t' + : $c == 0x0a ? '\n' + : $c == 0x0d ? '\r' + : $c == 0x0c ? '\f' + : $c < 0x20 ? sprintf('\x{%x}', $c) + : $c == 0x5c ? '\\\\' + : $c < 0x80 ? chr($c) + : sprintf('\x{%x}', $c) + ; + if ( length $mess >= 20 ) { + $mess .= '...'; + last; + } + } + + unless ( length $mess ) { + $mess = '(end of string)'; + } + + Carp::croak ( + $no_rep ? "$error" : "$error, at character offset $at (before \"$mess\")" + ); + + } + + + sub _json_object_hook { + my $o = $_[0]; + my @ks = keys %{$o}; + + if ( $cb_sk_object and @ks == 1 and exists $cb_sk_object->{ $ks[0] } and ref $cb_sk_object->{ $ks[0] } ) { + my @val = $cb_sk_object->{ $ks[0] }->( $o->{$ks[0]} ); + if (@val == 1) { + return $val[0]; + } + } + + my @val = $cb_object->($o) if ($cb_object); + if (@val == 0 or @val > 1) { + return $o; + } + else { + return $val[0]; + } + } + + + sub PP_decode_box { + { + text => $text, + at => $at, + ch => $ch, + len => $len, + depth => $depth, + encoding => $encoding, + is_valid_utf8 => $is_valid_utf8, + }; + } + + } # PARSE + + + sub _decode_surrogates { # from perlunicode + my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00); + my $un = pack('U*', $uni); + utf8::encode( $un ); + return $un; + } + + + sub _decode_unicode { + my $un = pack('U', hex shift); + utf8::encode( $un ); + return $un; + } + + # + # Setup for various Perl versions (the code from JSON::PP58) + # + + BEGIN { + + unless ( defined &utf8::is_utf8 ) { + require Encode; + *utf8::is_utf8 = *Encode::is_utf8; + } + + if ( $] >= 5.008 ) { + *JSON::PP::JSON_PP_encode_ascii = \&_encode_ascii; + *JSON::PP::JSON_PP_encode_latin1 = \&_encode_latin1; + *JSON::PP::JSON_PP_decode_surrogates = \&_decode_surrogates; + *JSON::PP::JSON_PP_decode_unicode = \&_decode_unicode; + } + + if ($] >= 5.008 and $] < 5.008003) { # join() in 5.8.0 - 5.8.2 is broken. + package JSON::PP; + require subs; + subs->import('join'); + eval q| + sub join { + return '' if (@_ < 2); + my $j = shift; + my $str = shift; + for (@_) { $str .= $j . $_; } + return $str; + } + |; + } + + + sub JSON::PP::incr_parse { + local $Carp::CarpLevel = 1; + ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ ); + } + + + sub JSON::PP::incr_skip { + ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip; + } + + + sub JSON::PP::incr_reset { + ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset; + } + + eval q{ + sub JSON::PP::incr_text : lvalue { + $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new; + + if ( $_[0]->{_incr_parser}->{incr_parsing} ) { + Carp::croak("incr_text can not be called when the incremental parser already started parsing"); + } + $_[0]->{_incr_parser}->{incr_text}; + } + } if ( $] >= 5.006 ); + + } # Setup for various Perl versions (the code from JSON::PP58) + + + ############################### + # Utilities + # + + BEGIN { + eval 'require Scalar::Util'; + unless($@){ + *JSON::PP::blessed = \&Scalar::Util::blessed; + *JSON::PP::reftype = \&Scalar::Util::reftype; + *JSON::PP::refaddr = \&Scalar::Util::refaddr; + } + else{ # This code is from Sclar::Util. + # warn $@; + eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }'; + *JSON::PP::blessed = sub { + local($@, $SIG{__DIE__}, $SIG{__WARN__}); + ref($_[0]) ? eval { $_[0]->a_sub_not_likely_to_be_here } : undef; + }; + my %tmap = qw( + B::NULL SCALAR + B::HV HASH + B::AV ARRAY + B::CV CODE + B::IO IO + B::GV GLOB + B::REGEXP REGEXP + ); + *JSON::PP::reftype = sub { + my $r = shift; + + return undef unless length(ref($r)); + + my $t = ref(B::svref_2object($r)); + + return + exists $tmap{$t} ? $tmap{$t} + : length(ref($$r)) ? 'REF' + : 'SCALAR'; + }; + *JSON::PP::refaddr = sub { + return undef unless length(ref($_[0])); + + my $addr; + if(defined(my $pkg = blessed($_[0]))) { + $addr .= bless $_[0], 'Scalar::Util::Fake'; + bless $_[0], $pkg; + } + else { + $addr .= $_[0] + } + + $addr =~ /0x(\w+)/; + local $^W; + #no warnings 'portable'; + hex($1); + } + } + } + + + # shamely copied and modified from JSON::XS code. + + $JSON::PP::true = do { bless \(my $dummy = 1), "JSON::PP::Boolean" }; + $JSON::PP::false = do { bless \(my $dummy = 0), "JSON::PP::Boolean" }; + + sub is_bool { defined $_[0] and UNIVERSAL::isa($_[0], "JSON::PP::Boolean"); } + + sub true { $JSON::PP::true } + sub false { $JSON::PP::false } + sub null { undef; } + + ############################### + + package JSON::PP::Boolean; + + use overload ( + "0+" => sub { ${$_[0]} }, + "++" => sub { $_[0] = ${$_[0]} + 1 }, + "--" => sub { $_[0] = ${$_[0]} - 1 }, + fallback => 1, + ); + + + ############################### + + package JSON::PP::IncrParser; + + use strict; + + use constant INCR_M_WS => 0; # initial whitespace skipping + use constant INCR_M_STR => 1; # inside string + use constant INCR_M_BS => 2; # inside backslash + use constant INCR_M_JSON => 3; # outside anything, count nesting + use constant INCR_M_C0 => 4; + use constant INCR_M_C1 => 5; + + $JSON::PP::IncrParser::VERSION = '1.01'; + + my $unpack_format = $] < 5.006 ? 'C*' : 'U*'; + + sub new { + my ( $class ) = @_; + + bless { + incr_nest => 0, + incr_text => undef, + incr_parsing => 0, + incr_p => 0, + }, $class; + } + + + sub incr_parse { + my ( $self, $coder, $text ) = @_; + + $self->{incr_text} = '' unless ( defined $self->{incr_text} ); + + if ( defined $text ) { + if ( utf8::is_utf8( $text ) and !utf8::is_utf8( $self->{incr_text} ) ) { + utf8::upgrade( $self->{incr_text} ) ; + utf8::decode( $self->{incr_text} ) ; + } + $self->{incr_text} .= $text; + } + + + my $max_size = $coder->get_max_size; + + if ( defined wantarray ) { + + $self->{incr_mode} = INCR_M_WS unless defined $self->{incr_mode}; + + if ( wantarray ) { + my @ret; + + $self->{incr_parsing} = 1; + + do { + push @ret, $self->_incr_parse( $coder, $self->{incr_text} ); + + unless ( !$self->{incr_nest} and $self->{incr_mode} == INCR_M_JSON ) { + $self->{incr_mode} = INCR_M_WS if $self->{incr_mode} != INCR_M_STR; + } + + } until ( length $self->{incr_text} >= $self->{incr_p} ); + + $self->{incr_parsing} = 0; + + return @ret; + } + else { # in scalar context + $self->{incr_parsing} = 1; + my $obj = $self->_incr_parse( $coder, $self->{incr_text} ); + $self->{incr_parsing} = 0 if defined $obj; # pointed by Martin J. Evans + return $obj ? $obj : undef; # $obj is an empty string, parsing was completed. + } + + } + + } + + + sub _incr_parse { + my ( $self, $coder, $text, $skip ) = @_; + my $p = $self->{incr_p}; + my $restore = $p; + + my @obj; + my $len = length $text; + + if ( $self->{incr_mode} == INCR_M_WS ) { + while ( $len > $p ) { + my $s = substr( $text, $p, 1 ); + $p++ and next if ( 0x20 >= unpack($unpack_format, $s) ); + $self->{incr_mode} = INCR_M_JSON; + last; + } + } + + while ( $len > $p ) { + my $s = substr( $text, $p++, 1 ); + + if ( $s eq '"' ) { + if (substr( $text, $p - 2, 1 ) eq '\\' ) { + next; + } + + if ( $self->{incr_mode} != INCR_M_STR ) { + $self->{incr_mode} = INCR_M_STR; + } + else { + $self->{incr_mode} = INCR_M_JSON; + unless ( $self->{incr_nest} ) { + last; + } + } + } + + if ( $self->{incr_mode} == INCR_M_JSON ) { + + if ( $s eq '[' or $s eq '{' ) { + if ( ++$self->{incr_nest} > $coder->get_max_depth ) { + Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)'); + } + } + elsif ( $s eq ']' or $s eq '}' ) { + last if ( --$self->{incr_nest} <= 0 ); + } + elsif ( $s eq '#' ) { + while ( $len > $p ) { + last if substr( $text, $p++, 1 ) eq "\n"; + } + } + + } + + } + + $self->{incr_p} = $p; + + return if ( $self->{incr_mode} == INCR_M_STR and not $self->{incr_nest} ); + return if ( $self->{incr_mode} == INCR_M_JSON and $self->{incr_nest} > 0 ); + + return '' unless ( length substr( $self->{incr_text}, 0, $p ) ); + + local $Carp::CarpLevel = 2; + + $self->{incr_p} = $restore; + $self->{incr_c} = $p; + + my ( $obj, $tail ) = $coder->PP_decode_json( substr( $self->{incr_text}, 0, $p ), 0x10000001 ); + + $self->{incr_text} = substr( $self->{incr_text}, $p ); + $self->{incr_p} = 0; + + return $obj || ''; + } + + + sub incr_text { + if ( $_[0]->{incr_parsing} ) { + Carp::croak("incr_text can not be called when the incremental parser already started parsing"); + } + $_[0]->{incr_text}; + } + + + sub incr_skip { + my $self = shift; + $self->{incr_text} = substr( $self->{incr_text}, $self->{incr_c} ); + $self->{incr_p} = 0; + } + + + sub incr_reset { + my $self = shift; + $self->{incr_text} = undef; + $self->{incr_p} = 0; + $self->{incr_mode} = 0; + $self->{incr_nest} = 0; + $self->{incr_parsing} = 0; + } + + ############################### + + + 1; + __END__ + =pod + + =head1 NAME + + JSON::PP - JSON::XS compatible pure-Perl module. + + =head1 SYNOPSIS + + use JSON::PP; + + # exported functions, they croak on error + # and expect/generate UTF-8 + + $utf8_encoded_json_text = encode_json $perl_hash_or_arrayref; + $perl_hash_or_arrayref = decode_json $utf8_encoded_json_text; + + # OO-interface + + $coder = JSON::PP->new->ascii->pretty->allow_nonref; + + $json_text = $json->encode( $perl_scalar ); + $perl_scalar = $json->decode( $json_text ); + + $pretty_printed = $json->pretty->encode( $perl_scalar ); # pretty-printing + + # Note that JSON version 2.0 and above will automatically use + # JSON::XS or JSON::PP, so you should be able to just: + + use JSON; + + + =head1 VERSION + + 2.27202 + + L 2.27 (~2.30) compatible. + + =head1 NOTE + + JSON::PP had been inculded in JSON distribution (CPAN module). + It was a perl core module in Perl 5.14. + + =head1 DESCRIPTION + + This module is L compatible pure Perl module. + (Perl 5.8 or later is recommended) + + JSON::XS is the fastest and most proper JSON module on CPAN. + It is written by Marc Lehmann in C, so must be compiled and + installed in the used environment. + + JSON::PP is a pure-Perl module and has compatibility to JSON::XS. + + + =head2 FEATURES + + =over + + =item * correct unicode handling + + This module knows how to handle Unicode (depending on Perl version). + + See to L and L. + + + =item * round-trip integrity + + When you serialise a perl data structure using only data types supported + by JSON and Perl, the deserialised data structure is identical on the Perl + level. (e.g. the string "2.0" doesn't suddenly become "2" just because + it looks like a number). There I minor exceptions to this, read the + MAPPING section below to learn about those. + + + =item * strict checking of JSON correctness + + There is no guessing, no generating of illegal JSON texts by default, + and only JSON is accepted as input by default (the latter is a security feature). + But when some options are set, loose chcking features are available. + + =back + + =head1 FUNCTIONAL INTERFACE + + Some documents are copied and modified from L. + + =head2 encode_json + + $json_text = encode_json $perl_scalar + + Converts the given Perl data structure to a UTF-8 encoded, binary string. + + This function call is functionally identical to: + + $json_text = JSON::PP->new->utf8->encode($perl_scalar) + + =head2 decode_json + + $perl_scalar = decode_json $json_text + + The opposite of C: expects an UTF-8 (binary) string and tries + to parse that as an UTF-8 encoded JSON text, returning the resulting + reference. + + This function call is functionally identical to: + + $perl_scalar = JSON::PP->new->utf8->decode($json_text) + + =head2 JSON::PP::is_bool + + $is_boolean = JSON::PP::is_bool($scalar) + + Returns true if the passed scalar represents either JSON::PP::true or + JSON::PP::false, two constants that act like C<1> and C<0> respectively + and are also used to represent JSON C and C in Perl strings. + + =head2 JSON::PP::true + + Returns JSON true value which is blessed object. + It C JSON::PP::Boolean object. + + =head2 JSON::PP::false + + Returns JSON false value which is blessed object. + It C JSON::PP::Boolean object. + + =head2 JSON::PP::null + + Returns C. + + See L, below, for more information on how JSON values are mapped to + Perl. + + + =head1 HOW DO I DECODE A DATA FROM OUTER AND ENCODE TO OUTER + + This section supposes that your perl vresion is 5.8 or later. + + If you know a JSON text from an outer world - a network, a file content, and so on, + is encoded in UTF-8, you should use C or C module object + with C enable. And the decoded result will contain UNICODE characters. + + # from network + my $json = JSON::PP->new->utf8; + my $json_text = CGI->new->param( 'json_data' ); + my $perl_scalar = $json->decode( $json_text ); + + # from file content + local $/; + open( my $fh, '<', 'json.data' ); + $json_text = <$fh>; + $perl_scalar = decode_json( $json_text ); + + If an outer data is not encoded in UTF-8, firstly you should C it. + + use Encode; + local $/; + open( my $fh, '<', 'json.data' ); + my $encoding = 'cp932'; + my $unicode_json_text = decode( $encoding, <$fh> ); # UNICODE + + # or you can write the below code. + # + # open( my $fh, "<:encoding($encoding)", 'json.data' ); + # $unicode_json_text = <$fh>; + + In this case, C<$unicode_json_text> is of course UNICODE string. + So you B use C nor C module object with C enable. + Instead of them, you use C module object with C disable. + + $perl_scalar = $json->utf8(0)->decode( $unicode_json_text ); + + Or C and C: + + $perl_scalar = decode_json( encode( 'utf8', $unicode_json_text ) ); + # this way is not efficient. + + And now, you want to convert your C<$perl_scalar> into JSON data and + send it to an outer world - a network or a file content, and so on. + + Your data usually contains UNICODE strings and you want the converted data to be encoded + in UTF-8, you should use C or C module object with C enable. + + print encode_json( $perl_scalar ); # to a network? file? or display? + # or + print $json->utf8->encode( $perl_scalar ); + + If C<$perl_scalar> does not contain UNICODE but C<$encoding>-encoded strings + for some reason, then its characters are regarded as B for perl + (because it does not concern with your $encoding). + You B use C nor C module object with C enable. + Instead of them, you use C module object with C disable. + Note that the resulted text is a UNICODE string but no problem to print it. + + # $perl_scalar contains $encoding encoded string values + $unicode_json_text = $json->utf8(0)->encode( $perl_scalar ); + # $unicode_json_text consists of characters less than 0x100 + print $unicode_json_text; + + Or C all string values and C: + + $perl_scalar->{ foo } = decode( $encoding, $perl_scalar->{ foo } ); + # ... do it to each string values, then encode_json + $json_text = encode_json( $perl_scalar ); + + This method is a proper way but probably not efficient. + + See to L, L. + + + =head1 METHODS + + Basically, check to L or L. + + =head2 new + + $json = JSON::PP->new + + Rturns a new JSON::PP object that can be used to de/encode JSON + strings. + + All boolean flags described below are by default I. + + The mutators for flags all return the JSON object again and thus calls can + be chained: + + my $json = JSON::PP->new->utf8->space_after->encode({a => [1,2]}) + => {"a": [1, 2]} + + =head2 ascii + + $json = $json->ascii([$enable]) + + $enabled = $json->get_ascii + + If $enable is true (or missing), then the encode method will not generate characters outside + the code range 0..127. Any Unicode characters outside that range will be escaped using either + a single \uXXXX or a double \uHHHH\uLLLLL escape sequence, as per RFC4627. + (See to L). + + In Perl 5.005, there is no character having high value (more than 255). + See to L. + + If $enable is false, then the encode method will not escape Unicode characters unless + required by the JSON syntax or other flags. This results in a faster and more compact format. + + JSON::PP->new->ascii(1)->encode([chr 0x10401]) + => ["\ud801\udc01"] + + =head2 latin1 + + $json = $json->latin1([$enable]) + + $enabled = $json->get_latin1 + + If $enable is true (or missing), then the encode method will encode the resulting JSON + text as latin1 (or iso-8859-1), escaping any characters outside the code range 0..255. + + If $enable is false, then the encode method will not escape Unicode characters + unless required by the JSON syntax or other flags. + + JSON::XS->new->latin1->encode (["\x{89}\x{abc}"] + => ["\x{89}\\u0abc"] # (perl syntax, U+abc escaped, U+89 not) + + See to L. + + =head2 utf8 + + $json = $json->utf8([$enable]) + + $enabled = $json->get_utf8 + + If $enable is true (or missing), then the encode method will encode the JSON result + into UTF-8, as required by many protocols, while the decode method expects to be handled + an UTF-8-encoded string. Please note that UTF-8-encoded strings do not contain any + characters outside the range 0..255, they are thus useful for bytewise/binary I/O. + + (In Perl 5.005, any character outside the range 0..255 does not exist. + See to L.) + + In future versions, enabling this option might enable autodetection of the UTF-16 and UTF-32 + encoding families, as described in RFC4627. + + If $enable is false, then the encode method will return the JSON string as a (non-encoded) + Unicode string, while decode expects thus a Unicode string. Any decoding or encoding + (e.g. to UTF-8 or UTF-16) needs to be done yourself, e.g. using the Encode module. + + Example, output UTF-16BE-encoded JSON: + + use Encode; + $jsontext = encode "UTF-16BE", JSON::PP->new->encode ($object); + + Example, decode UTF-32LE-encoded JSON: + + use Encode; + $object = JSON::PP->new->decode (decode "UTF-32LE", $jsontext); + + + =head2 pretty + + $json = $json->pretty([$enable]) + + This enables (or disables) all of the C, C and + C flags in one call to generate the most readable + (or most compact) form possible. + + Equivalent to: + + $json->indent->space_before->space_after + + =head2 indent + + $json = $json->indent([$enable]) + + $enabled = $json->get_indent + + The default indent space length is three. + You can use C to change the length. + + =head2 space_before + + $json = $json->space_before([$enable]) + + $enabled = $json->get_space_before + + If C<$enable> is true (or missing), then the C method will add an extra + optional space before the C<:> separating keys from values in JSON objects. + + If C<$enable> is false, then the C method will not add any extra + space at those places. + + This setting has no effect when decoding JSON texts. + + Example, space_before enabled, space_after and indent disabled: + + {"key" :"value"} + + =head2 space_after + + $json = $json->space_after([$enable]) + + $enabled = $json->get_space_after + + If C<$enable> is true (or missing), then the C method will add an extra + optional space after the C<:> separating keys from values in JSON objects + and extra whitespace after the C<,> separating key-value pairs and array + members. + + If C<$enable> is false, then the C method will not add any extra + space at those places. + + This setting has no effect when decoding JSON texts. + + Example, space_before and indent disabled, space_after enabled: + + {"key": "value"} + + =head2 relaxed + + $json = $json->relaxed([$enable]) + + $enabled = $json->get_relaxed + + If C<$enable> is true (or missing), then C will accept some + extensions to normal JSON syntax (see below). C will not be + affected in anyway. I. I suggest only to use this option to + parse application-specific files written by humans (configuration files, + resource files etc.) + + If C<$enable> is false (the default), then C will only accept + valid JSON texts. + + Currently accepted extensions are: + + =over 4 + + =item * list items can have an end-comma + + JSON I array elements and key-value pairs with commas. This + can be annoying if you write JSON texts manually and want to be able to + quickly append elements, so this extension accepts comma at the end of + such items not just between them: + + [ + 1, + 2, <- this comma not normally allowed + ] + { + "k1": "v1", + "k2": "v2", <- this comma not normally allowed + } + + =item * shell-style '#'-comments + + Whenever JSON allows whitespace, shell-style comments are additionally + allowed. They are terminated by the first carriage-return or line-feed + character, after which more white-space and comments are allowed. + + [ + 1, # this comment not allowed in JSON + # neither this one... + ] + + =back + + =head2 canonical + + $json = $json->canonical([$enable]) + + $enabled = $json->get_canonical + + If C<$enable> is true (or missing), then the C method will output JSON objects + by sorting their keys. This is adding a comparatively high overhead. + + If C<$enable> is false, then the C method will output key-value + pairs in the order Perl stores them (which will likely change between runs + of the same script). + + This option is useful if you want the same data structure to be encoded as + the same JSON text (given the same overall settings). If it is disabled, + the same hash might be encoded differently even if contains the same data, + as key-value pairs have no inherent ordering in Perl. + + This setting has no effect when decoding JSON texts. + + If you want your own sorting routine, you can give a code referece + or a subroutine name to C. See to C. + + =head2 allow_nonref + + $json = $json->allow_nonref([$enable]) + + $enabled = $json->get_allow_nonref + + If C<$enable> is true (or missing), then the C method can convert a + non-reference into its corresponding string, number or null JSON value, + which is an extension to RFC4627. Likewise, C will accept those JSON + values instead of croaking. + + If C<$enable> is false, then the C method will croak if it isn't + passed an arrayref or hashref, as JSON texts must either be an object + or array. Likewise, C will croak if given something that is not a + JSON object or array. + + JSON::PP->new->allow_nonref->encode ("Hello, World!") + => "Hello, World!" + + =head2 allow_unknown + + $json = $json->allow_unknown ([$enable]) + + $enabled = $json->get_allow_unknown + + If $enable is true (or missing), then "encode" will *not* throw an + exception when it encounters values it cannot represent in JSON (for + example, filehandles) but instead will encode a JSON "null" value. + Note that blessed objects are not included here and are handled + separately by c. + + If $enable is false (the default), then "encode" will throw an + exception when it encounters anything it cannot encode as JSON. + + This option does not affect "decode" in any way, and it is + recommended to leave it off unless you know your communications + partner. + + =head2 allow_blessed + + $json = $json->allow_blessed([$enable]) + + $enabled = $json->get_allow_blessed + + If C<$enable> is true (or missing), then the C method will not + barf when it encounters a blessed reference. Instead, the value of the + B option will decide whether C (C + disabled or no C method found) or a representation of the + object (C enabled and C method found) is being + encoded. Has no effect on C. + + If C<$enable> is false (the default), then C will throw an + exception when it encounters a blessed object. + + =head2 convert_blessed + + $json = $json->convert_blessed([$enable]) + + $enabled = $json->get_convert_blessed + + If C<$enable> is true (or missing), then C, upon encountering a + blessed object, will check for the availability of the C method + on the object's class. If found, it will be called in scalar context + and the resulting scalar will be encoded instead of the object. If no + C method is found, the value of C will decide what + to do. + + The C method may safely call die if it wants. If C + returns other blessed objects, those will be handled in the same + way. C must take care of not causing an endless recursion cycle + (== crash) in this case. The name of C was chosen because other + methods called by the Perl core (== not by the user of the object) are + usually in upper case letters and to avoid collisions with the C + function or method. + + This setting does not yet influence C in any way. + + If C<$enable> is false, then the C setting will decide what + to do when a blessed object is found. + + =head2 filter_json_object + + $json = $json->filter_json_object([$coderef]) + + When C<$coderef> is specified, it will be called from C each + time it decodes a JSON object. The only argument passed to the coderef + is a reference to the newly-created hash. If the code references returns + a single scalar (which need not be a reference), this value + (i.e. a copy of that scalar to avoid aliasing) is inserted into the + deserialised data structure. If it returns an empty list + (NOTE: I C, which is a valid scalar), the original deserialised + hash will be inserted. This setting can slow down decoding considerably. + + When C<$coderef> is omitted or undefined, any existing callback will + be removed and C will not change the deserialised hash in any + way. + + Example, convert all JSON objects into the integer 5: + + my $js = JSON::PP->new->filter_json_object (sub { 5 }); + # returns [5] + $js->decode ('[{}]'); # the given subroutine takes a hash reference. + # throw an exception because allow_nonref is not enabled + # so a lone 5 is not allowed. + $js->decode ('{"a":1, "b":2}'); + + =head2 filter_json_single_key_object + + $json = $json->filter_json_single_key_object($key [=> $coderef]) + + Works remotely similar to C, but is only called for + JSON objects having a single key named C<$key>. + + This C<$coderef> is called before the one specified via + C, if any. It gets passed the single value in the JSON + object. If it returns a single value, it will be inserted into the data + structure. If it returns nothing (not even C but the empty list), + the callback from C will be called next, as if no + single-key callback were specified. + + If C<$coderef> is omitted or undefined, the corresponding callback will be + disabled. There can only ever be one callback for a given key. + + As this callback gets called less often then the C + one, decoding speed will not usually suffer as much. Therefore, single-key + objects make excellent targets to serialise Perl objects into, especially + as single-key JSON objects are as close to the type-tagged value concept + as JSON gets (it's basically an ID/VALUE tuple). Of course, JSON does not + support this in any way, so you need to make sure your data never looks + like a serialised Perl hash. + + Typical names for the single object key are C<__class_whatever__>, or + C<$__dollars_are_rarely_used__$> or C<}ugly_brace_placement>, or even + things like C<__class_md5sum(classname)__>, to reduce the risk of clashing + with real hashes. + + Example, decode JSON objects of the form C<< { "__widget__" => } >> + into the corresponding C<< $WIDGET{} >> object: + + # return whatever is in $WIDGET{5}: + JSON::PP + ->new + ->filter_json_single_key_object (__widget__ => sub { + $WIDGET{ $_[0] } + }) + ->decode ('{"__widget__": 5') + + # this can be used with a TO_JSON method in some "widget" class + # for serialisation to json: + sub WidgetBase::TO_JSON { + my ($self) = @_; + + unless ($self->{id}) { + $self->{id} = ..get..some..id..; + $WIDGET{$self->{id}} = $self; + } + + { __widget__ => $self->{id} } + } + + =head2 shrink + + $json = $json->shrink([$enable]) + + $enabled = $json->get_shrink + + In JSON::XS, this flag resizes strings generated by either + C or C to their minimum size possible. + It will also try to downgrade any strings to octet-form if possible. + + In JSON::PP, it is noop about resizing strings but tries + C to the returned string by C. + See to L. + + See to L + + =head2 max_depth + + $json = $json->max_depth([$maximum_nesting_depth]) + + $max_depth = $json->get_max_depth + + Sets the maximum nesting level (default C<512>) accepted while encoding + or decoding. If a higher nesting level is detected in JSON text or a Perl + data structure, then the encoder and decoder will stop and croak at that + point. + + Nesting level is defined by number of hash- or arrayrefs that the encoder + needs to traverse to reach a given point or the number of C<{> or C<[> + characters without their matching closing parenthesis crossed to reach a + given character in a string. + + If no argument is given, the highest possible setting will be used, which + is rarely useful. + + See L for more info on why this is useful. + + When a large value (100 or more) was set and it de/encodes a deep nested object/text, + it may raise a warning 'Deep recursion on subroutin' at the perl runtime phase. + + =head2 max_size + + $json = $json->max_size([$maximum_string_size]) + + $max_size = $json->get_max_size + + Set the maximum length a JSON text may have (in bytes) where decoding is + being attempted. The default is C<0>, meaning no limit. When C + is called on a string that is longer then this many bytes, it will not + attempt to decode the string but throw an exception. This setting has no + effect on C (yet). + + If no argument is given, the limit check will be deactivated (same as when + C<0> is specified). + + See L for more info on why this is useful. + + =head2 encode + + $json_text = $json->encode($perl_scalar) + + Converts the given Perl data structure (a simple scalar or a reference + to a hash or array) to its JSON representation. Simple scalars will be + converted into JSON string or number sequences, while references to arrays + become JSON arrays and references to hashes become JSON objects. Undefined + Perl values (e.g. C) become JSON C values. + References to the integers C<0> and C<1> are converted into C and C. + + =head2 decode + + $perl_scalar = $json->decode($json_text) + + The opposite of C: expects a JSON text and tries to parse it, + returning the resulting simple scalar or reference. Croaks on error. + + JSON numbers and strings become simple Perl scalars. JSON arrays become + Perl arrayrefs and JSON objects become Perl hashrefs. C becomes + C<1> (C), C becomes C<0> (C) and + C becomes C. + + =head2 decode_prefix + + ($perl_scalar, $characters) = $json->decode_prefix($json_text) + + This works like the C method, but instead of raising an exception + when there is trailing garbage after the first JSON object, it will + silently stop parsing there and return the number of characters consumed + so far. + + JSON->new->decode_prefix ("[1] the tail") + => ([], 3) + + =head1 INCREMENTAL PARSING + + Most of this section are copied and modified from L. + + In some cases, there is the need for incremental parsing of JSON texts. + This module does allow you to parse a JSON stream incrementally. + It does so by accumulating text until it has a full JSON object, which + it then can decode. This process is similar to using C + to see if a full JSON object is available, but is much more efficient + (and can be implemented with a minimum of method calls). + + This module will only attempt to parse the JSON text once it is sure it + has enough text to get a decisive result, using a very simple but + truly incremental parser. This means that it sometimes won't stop as + early as the full parser, for example, it doesn't detect parenthese + mismatches. The only thing it guarantees is that it starts decoding as + soon as a syntactically valid JSON text has been seen. This means you need + to set resource limits (e.g. C) to ensure the parser will stop + parsing in the presence if syntax errors. + + The following methods implement this incremental parser. + + =head2 incr_parse + + $json->incr_parse( [$string] ) # void context + + $obj_or_undef = $json->incr_parse( [$string] ) # scalar context + + @obj_or_empty = $json->incr_parse( [$string] ) # list context + + This is the central parsing function. It can both append new text and + extract objects from the stream accumulated so far (both of these + functions are optional). + + If C<$string> is given, then this string is appended to the already + existing JSON fragment stored in the C<$json> object. + + After that, if the function is called in void context, it will simply + return without doing anything further. This can be used to add more text + in as many chunks as you want. + + If the method is called in scalar context, then it will try to extract + exactly I JSON object. If that is successful, it will return this + object, otherwise it will return C. If there is a parse error, + this method will croak just as C would do (one can then use + C to skip the errornous part). This is the most common way of + using the method. + + And finally, in list context, it will try to extract as many objects + from the stream as it can find and return them, or the empty list + otherwise. For this to work, there must be no separators between the JSON + objects or arrays, instead they must be concatenated back-to-back. If + an error occurs, an exception will be raised as in the scalar context + case. Note that in this case, any previously-parsed JSON texts will be + lost. + + Example: Parse some JSON arrays/objects in a given string and return them. + + my @objs = JSON->new->incr_parse ("[5][7][1,2]"); + + =head2 incr_text + + $lvalue_string = $json->incr_text + + This method returns the currently stored JSON fragment as an lvalue, that + is, you can manipulate it. This I works when a preceding call to + C in I successfully returned an object. Under + all other circumstances you must not call this function (I mean it. + although in simple tests it might actually work, it I fail under + real world conditions). As a special exception, you can also call this + method before having parsed anything. + + This function is useful in two cases: a) finding the trailing text after a + JSON object or b) parsing multiple JSON objects separated by non-JSON text + (such as commas). + + $json->incr_text =~ s/\s*,\s*//; + + In Perl 5.005, C attribute is not available. + You must write codes like the below: + + $string = $json->incr_text; + $string =~ s/\s*,\s*//; + $json->incr_text( $string ); + + =head2 incr_skip + + $json->incr_skip + + This will reset the state of the incremental parser and will remove the + parsed text from the input buffer. This is useful after C + died, in which case the input buffer and incremental parser state is left + unchanged, to skip the text parsed so far and to reset the parse state. + + =head2 incr_reset + + $json->incr_reset + + This completely resets the incremental parser, that is, after this call, + it will be as if the parser had never parsed anything. + + This is useful if you want ot repeatedly parse JSON objects and want to + ignore any trailing data, which means you have to reset the parser after + each successful decode. + + See to L for examples. + + + =head1 JSON::PP OWN METHODS + + =head2 allow_singlequote + + $json = $json->allow_singlequote([$enable]) + + If C<$enable> is true (or missing), then C will accept + JSON strings quoted by single quotations that are invalid JSON + format. + + $json->allow_singlequote->decode({"foo":'bar'}); + $json->allow_singlequote->decode({'foo':"bar"}); + $json->allow_singlequote->decode({'foo':'bar'}); + + As same as the C option, this option may be used to parse + application-specific files written by humans. + + + =head2 allow_barekey + + $json = $json->allow_barekey([$enable]) + + If C<$enable> is true (or missing), then C will accept + bare keys of JSON object that are invalid JSON format. + + As same as the C option, this option may be used to parse + application-specific files written by humans. + + $json->allow_barekey->decode('{foo:"bar"}'); + + =head2 allow_bignum + + $json = $json->allow_bignum([$enable]) + + If C<$enable> is true (or missing), then C will convert + the big integer Perl cannot handle as integer into a L + object and convert a floating number (any) into a L. + + On the contary, C converts C objects and C + objects into JSON numbers with C enable. + + $json->allow_nonref->allow_blessed->allow_bignum; + $bigfloat = $json->decode('2.000000000000000000000000001'); + print $json->encode($bigfloat); + # => 2.000000000000000000000000001 + + See to L aboout the normal conversion of JSON number. + + =head2 loose + + $json = $json->loose([$enable]) + + The unescaped [\x00-\x1f\x22\x2f\x5c] strings are invalid in JSON strings + and the module doesn't allow to C to these (except for \x2f). + If C<$enable> is true (or missing), then C will accept these + unescaped strings. + + $json->loose->decode(qq|["abc + def"]|); + + See L. + + =head2 escape_slash + + $json = $json->escape_slash([$enable]) + + According to JSON Grammar, I (U+002F) is escaped. But default + JSON::PP (as same as JSON::XS) encodes strings without escaping slash. + + If C<$enable> is true (or missing), then C will escape slashes. + + =head2 indent_length + + $json = $json->indent_length($length) + + JSON::XS indent space length is 3 and cannot be changed. + JSON::PP set the indent space length with the given $length. + The default is 3. The acceptable range is 0 to 15. + + =head2 sort_by + + $json = $json->sort_by($function_name) + $json = $json->sort_by($subroutine_ref) + + If $function_name or $subroutine_ref are set, its sort routine are used + in encoding JSON objects. + + $js = $pc->sort_by(sub { $JSON::PP::a cmp $JSON::PP::b })->encode($obj); + # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|); + + $js = $pc->sort_by('own_sort')->encode($obj); + # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|); + + sub JSON::PP::own_sort { $JSON::PP::a cmp $JSON::PP::b } + + As the sorting routine runs in the JSON::PP scope, the given + subroutine name and the special variables C<$a>, C<$b> will begin + 'JSON::PP::'. + + If $integer is set, then the effect is same as C on. + + =head1 INTERNAL + + For developers. + + =over + + =item PP_encode_box + + Returns + + { + depth => $depth, + indent_count => $indent_count, + } + + + =item PP_decode_box + + Returns + + { + text => $text, + at => $at, + ch => $ch, + len => $len, + depth => $depth, + encoding => $encoding, + is_valid_utf8 => $is_valid_utf8, + }; + + =back + + =head1 MAPPING + + This section is copied from JSON::XS and modified to C. + JSON::XS and JSON::PP mapping mechanisms are almost equivalent. + + See to L. + + =head2 JSON -> PERL + + =over 4 + + =item object + + A JSON object becomes a reference to a hash in Perl. No ordering of object + keys is preserved (JSON does not preserver object key ordering itself). + + =item array + + A JSON array becomes a reference to an array in Perl. + + =item string + + A JSON string becomes a string scalar in Perl - Unicode codepoints in JSON + are represented by the same codepoints in the Perl string, so no manual + decoding is necessary. + + =item number + + A JSON number becomes either an integer, numeric (floating point) or + string scalar in perl, depending on its range and any fractional parts. On + the Perl level, there is no difference between those as Perl handles all + the conversion details, but an integer may take slightly less memory and + might represent more values exactly than floating point numbers. + + If the number consists of digits only, C will try to represent + it as an integer value. If that fails, it will try to represent it as + a numeric (floating point) value if that is possible without loss of + precision. Otherwise it will preserve the number as a string value (in + which case you lose roundtripping ability, as the JSON number will be + re-encoded toa JSON string). + + Numbers containing a fractional or exponential part will always be + represented as numeric (floating point) values, possibly at a loss of + precision (in which case you might lose perfect roundtripping ability, but + the JSON number will still be re-encoded as a JSON number). + + Note that precision is not accuracy - binary floating point values cannot + represent most decimal fractions exactly, and when converting from and to + floating point, C only guarantees precision up to but not including + the leats significant bit. + + When C is enable, the big integers + and the numeric can be optionally converted into L and + L objects. + + =item true, false + + These JSON atoms become C and C, + respectively. They are overloaded to act almost exactly like the numbers + C<1> and C<0>. You can check wether a scalar is a JSON boolean by using + the C function. + + print JSON::PP::true . "\n"; + => true + print JSON::PP::true + 1; + => 1 + + ok(JSON::true eq '1'); + ok(JSON::true == 1); + + C will install these missing overloading features to the backend modules. + + + =item null + + A JSON null atom becomes C in Perl. + + C returns C. + + =back + + + =head2 PERL -> JSON + + The mapping from Perl to JSON is slightly more difficult, as Perl is a + truly typeless language, so we can only guess which JSON type is meant by + a Perl value. + + =over 4 + + =item hash references + + Perl hash references become JSON objects. As there is no inherent ordering + in hash keys (or JSON objects), they will usually be encoded in a + pseudo-random order that can change between runs of the same program but + stays generally the same within a single run of a program. C + optionally sort the hash keys (determined by the I flag), so + the same datastructure will serialise to the same JSON text (given same + settings and version of JSON::XS), but this incurs a runtime overhead + and is only rarely useful, e.g. when you want to compare some JSON text + against another for equality. + + + =item array references + + Perl array references become JSON arrays. + + =item other references + + Other unblessed references are generally not allowed and will cause an + exception to be thrown, except for references to the integers C<0> and + C<1>, which get turned into C and C atoms in JSON. You can + also use C and C to improve readability. + + to_json [\0,JSON::PP::true] # yields [false,true] + + =item JSON::PP::true, JSON::PP::false, JSON::PP::null + + These special values become JSON true and JSON false values, + respectively. You can also use C<\1> and C<\0> directly if you want. + + JSON::PP::null returns C. + + =item blessed objects + + Blessed objects are not directly representable in JSON. See the + C and C methods on various options on + how to deal with this: basically, you can choose between throwing an + exception, encoding the reference as if it weren't blessed, or provide + your own serialiser method. + + See to L. + + =item simple scalars + + Simple Perl scalars (any scalar that is not a reference) are the most + difficult objects to encode: JSON::XS and JSON::PP will encode undefined scalars as + JSON C values, scalars that have last been used in a string context + before encoding as JSON strings, and anything else as number value: + + # dump as number + encode_json [2] # yields [2] + encode_json [-3.0e17] # yields [-3e+17] + my $value = 5; encode_json [$value] # yields [5] + + # used as string, so dump as string + print $value; + encode_json [$value] # yields ["5"] + + # undef becomes null + encode_json [undef] # yields [null] + + You can force the type to be a string by stringifying it: + + my $x = 3.1; # some variable containing a number + "$x"; # stringified + $x .= ""; # another, more awkward way to stringify + print $x; # perl does it for you, too, quite often + + You can force the type to be a number by numifying it: + + my $x = "3"; # some variable containing a string + $x += 0; # numify it, ensuring it will be dumped as a number + $x *= 1; # same thing, the choise is yours. + + You can not currently force the type in other, less obscure, ways. + + Note that numerical precision has the same meaning as under Perl (so + binary to decimal conversion follows the same rules as in Perl, which + can differ to other languages). Also, your perl interpreter might expose + extensions to the floating point numbers of your platform, such as + infinities or NaN's - these cannot be represented in JSON, and it is an + error to pass those in. + + =item Big Number + + When C is enable, + C converts C objects and C + objects into JSON numbers. + + + =back + + =head1 UNICODE HANDLING ON PERLS + + If you do not know about Unicode on Perl well, + please check L. + + =head2 Perl 5.8 and later + + Perl can handle Unicode and the JSON::PP de/encode methods also work properly. + + $json->allow_nonref->encode(chr hex 3042); + $json->allow_nonref->encode(chr hex 12345); + + Reuturns C<"\u3042"> and C<"\ud808\udf45"> respectively. + + $json->allow_nonref->decode('"\u3042"'); + $json->allow_nonref->decode('"\ud808\udf45"'); + + Returns UTF-8 encoded strings with UTF8 flag, regarded as C and C. + + Note that the versions from Perl 5.8.0 to 5.8.2, Perl built-in C was broken, + so JSON::PP wraps the C with a subroutine. Thus JSON::PP works slow in the versions. + + + =head2 Perl 5.6 + + Perl can handle Unicode and the JSON::PP de/encode methods also work. + + =head2 Perl 5.005 + + Perl 5.005 is a byte sementics world -- all strings are sequences of bytes. + That means the unicode handling is not available. + + In encoding, + + $json->allow_nonref->encode(chr hex 3042); # hex 3042 is 12354. + $json->allow_nonref->encode(chr hex 12345); # hex 12345 is 74565. + + Returns C and C, as C takes a value more than 255, it treats + as C<$value % 256>, so the above codes are equivalent to : + + $json->allow_nonref->encode(chr 66); + $json->allow_nonref->encode(chr 69); + + In decoding, + + $json->decode('"\u00e3\u0081\u0082"'); + + The returned is a byte sequence C<0xE3 0x81 0x82> for UTF-8 encoded + japanese character (C). + And if it is represented in Unicode code point, C. + + Next, + + $json->decode('"\u3042"'); + + We ordinary expect the returned value is a Unicode character C. + But here is 5.005 world. This is C<0xE3 0x81 0x82>. + + $json->decode('"\ud808\udf45"'); + + This is not a character C but bytes - C<0xf0 0x92 0x8d 0x85>. + + + =head1 TODO + + =over + + =item speed + + =item memory saving + + =back + + + =head1 SEE ALSO + + Most of the document are copied and modified from JSON::XS doc. + + L + + RFC4627 (L) + + =head1 AUTHOR + + Makamaka Hannyaharamitu, Emakamaka[at]cpan.orgE + + + =head1 COPYRIGHT AND LICENSE + + Copyright 2007-2013 by Makamaka Hannyaharamitu + + This library is free software; you can redistribute it and/or modify + it under the same terms as Perl itself. + + =cut +JSON_PP + +$fatpacked{"JSON/PP/Boolean.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP_BOOLEAN'; + =head1 NAME + + JSON::PP::Boolean - dummy module providing JSON::PP::Boolean + + =head1 SYNOPSIS + + # do not "use" yourself + + =head1 DESCRIPTION + + This module exists only to provide overload resolution for Storable and similar modules. See + L for more info about this class. + + =cut + + use JSON::PP (); + use strict; + + 1; + + =head1 AUTHOR + + This idea is from L written by Marc Lehmann + + =cut + +JSON_PP_BOOLEAN + +$fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_BACKPORTPP'; + package # This is JSON::backportPP + JSON::PP; + + # JSON-2.0 + + use 5.005; + use strict; + use base qw(Exporter); + use overload (); + + use Carp (); + use B (); + #use Devel::Peek; + + use vars qw($VERSION); + $VERSION = '2.27204'; + + @JSON::PP::EXPORT = qw(encode_json decode_json from_json to_json); + + # instead of hash-access, i tried index-access for speed. + # but this method is not faster than what i expected. so it will be changed. + + use constant P_ASCII => 0; + use constant P_LATIN1 => 1; + use constant P_UTF8 => 2; + use constant P_INDENT => 3; + use constant P_CANONICAL => 4; + use constant P_SPACE_BEFORE => 5; + use constant P_SPACE_AFTER => 6; + use constant P_ALLOW_NONREF => 7; + use constant P_SHRINK => 8; + use constant P_ALLOW_BLESSED => 9; + use constant P_CONVERT_BLESSED => 10; + use constant P_RELAXED => 11; + + use constant P_LOOSE => 12; + use constant P_ALLOW_BIGNUM => 13; + use constant P_ALLOW_BAREKEY => 14; + use constant P_ALLOW_SINGLEQUOTE => 15; + use constant P_ESCAPE_SLASH => 16; + use constant P_AS_NONBLESSED => 17; + + use constant P_ALLOW_UNKNOWN => 18; + + use constant OLD_PERL => $] < 5.008 ? 1 : 0; + + BEGIN { + my @xs_compati_bit_properties = qw( + latin1 ascii utf8 indent canonical space_before space_after allow_nonref shrink + allow_blessed convert_blessed relaxed allow_unknown + ); + my @pp_bit_properties = qw( + allow_singlequote allow_bignum loose + allow_barekey escape_slash as_nonblessed + ); + + # Perl version check, Unicode handling is enable? + # Helper module sets @JSON::PP::_properties. + if ($] < 5.008 ) { + my $helper = $] >= 5.006 ? 'JSON::backportPP::Compat5006' : 'JSON::backportPP::Compat5005'; + eval qq| require $helper |; + if ($@) { Carp::croak $@; } + } + + for my $name (@xs_compati_bit_properties, @pp_bit_properties) { + my $flag_name = 'P_' . uc($name); + + eval qq/ + sub $name { + my \$enable = defined \$_[1] ? \$_[1] : 1; + + if (\$enable) { + \$_[0]->{PROPS}->[$flag_name] = 1; + } + else { + \$_[0]->{PROPS}->[$flag_name] = 0; + } + + \$_[0]; + } + + sub get_$name { + \$_[0]->{PROPS}->[$flag_name] ? 1 : ''; + } + /; + } + + } + + + + # Functions + + my %encode_allow_method + = map {($_ => 1)} qw/utf8 pretty allow_nonref latin1 self_encode escape_slash + allow_blessed convert_blessed indent indent_length allow_bignum + as_nonblessed + /; + my %decode_allow_method + = map {($_ => 1)} qw/utf8 allow_nonref loose allow_singlequote allow_bignum + allow_barekey max_size relaxed/; + + + my $JSON; # cache + + sub encode_json ($) { # encode + ($JSON ||= __PACKAGE__->new->utf8)->encode(@_); + } + + + sub decode_json { # decode + ($JSON ||= __PACKAGE__->new->utf8)->decode(@_); + } + + # Obsoleted + + sub to_json($) { + Carp::croak ("JSON::PP::to_json has been renamed to encode_json."); + } + + + sub from_json($) { + Carp::croak ("JSON::PP::from_json has been renamed to decode_json."); + } + + + # Methods + + sub new { + my $class = shift; + my $self = { + max_depth => 512, + max_size => 0, + indent => 0, + FLAGS => 0, + fallback => sub { encode_error('Invalid value. JSON can only reference.') }, + indent_length => 3, + }; + + bless $self, $class; + } + + + sub encode { + return $_[0]->PP_encode_json($_[1]); + } + + + sub decode { + return $_[0]->PP_decode_json($_[1], 0x00000000); + } + + + sub decode_prefix { + return $_[0]->PP_decode_json($_[1], 0x00000001); + } + + + # accessor + + + # pretty printing + + sub pretty { + my ($self, $v) = @_; + my $enable = defined $v ? $v : 1; + + if ($enable) { # indent_length(3) for JSON::XS compatibility + $self->indent(1)->indent_length(3)->space_before(1)->space_after(1); + } + else { + $self->indent(0)->space_before(0)->space_after(0); + } + + $self; + } + + # etc + + sub max_depth { + my $max = defined $_[1] ? $_[1] : 0x80000000; + $_[0]->{max_depth} = $max; + $_[0]; + } + + + sub get_max_depth { $_[0]->{max_depth}; } + + + sub max_size { + my $max = defined $_[1] ? $_[1] : 0; + $_[0]->{max_size} = $max; + $_[0]; + } + + + sub get_max_size { $_[0]->{max_size}; } + + + sub filter_json_object { + $_[0]->{cb_object} = defined $_[1] ? $_[1] : 0; + $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0; + $_[0]; + } + + sub filter_json_single_key_object { + if (@_ > 1) { + $_[0]->{cb_sk_object}->{$_[1]} = $_[2]; + } + $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0; + $_[0]; + } + + sub indent_length { + if (!defined $_[1] or $_[1] > 15 or $_[1] < 0) { + Carp::carp "The acceptable range of indent_length() is 0 to 15."; + } + else { + $_[0]->{indent_length} = $_[1]; + } + $_[0]; + } + + sub get_indent_length { + $_[0]->{indent_length}; + } + + sub sort_by { + $_[0]->{sort_by} = defined $_[1] ? $_[1] : 1; + $_[0]; + } + + sub allow_bigint { + Carp::carp("allow_bigint() is obsoleted. use allow_bignum() insted."); + } + + ############################### + + ### + ### Perl => JSON + ### + + + { # Convert + + my $max_depth; + my $indent; + my $ascii; + my $latin1; + my $utf8; + my $space_before; + my $space_after; + my $canonical; + my $allow_blessed; + my $convert_blessed; + + my $indent_length; + my $escape_slash; + my $bignum; + my $as_nonblessed; + + my $depth; + my $indent_count; + my $keysort; + + + sub PP_encode_json { + my $self = shift; + my $obj = shift; + + $indent_count = 0; + $depth = 0; + + my $idx = $self->{PROPS}; + + ($ascii, $latin1, $utf8, $indent, $canonical, $space_before, $space_after, $allow_blessed, + $convert_blessed, $escape_slash, $bignum, $as_nonblessed) + = @{$idx}[P_ASCII .. P_SPACE_AFTER, P_ALLOW_BLESSED, P_CONVERT_BLESSED, + P_ESCAPE_SLASH, P_ALLOW_BIGNUM, P_AS_NONBLESSED]; + + ($max_depth, $indent_length) = @{$self}{qw/max_depth indent_length/}; + + $keysort = $canonical ? sub { $a cmp $b } : undef; + + if ($self->{sort_by}) { + $keysort = ref($self->{sort_by}) eq 'CODE' ? $self->{sort_by} + : $self->{sort_by} =~ /\D+/ ? $self->{sort_by} + : sub { $a cmp $b }; + } + + encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)") + if(!ref $obj and !$idx->[ P_ALLOW_NONREF ]); + + my $str = $self->object_to_json($obj); + + $str .= "\n" if ( $indent ); # JSON::XS 2.26 compatible + + unless ($ascii or $latin1 or $utf8) { + utf8::upgrade($str); + } + + if ($idx->[ P_SHRINK ]) { + utf8::downgrade($str, 1); + } + + return $str; + } + + + sub object_to_json { + my ($self, $obj) = @_; + my $type = ref($obj); + + if($type eq 'HASH'){ + return $self->hash_to_json($obj); + } + elsif($type eq 'ARRAY'){ + return $self->array_to_json($obj); + } + elsif ($type) { # blessed object? + if (blessed($obj)) { + + return $self->value_to_json($obj) if ( $obj->isa('JSON::PP::Boolean') ); + + if ( $convert_blessed and $obj->can('TO_JSON') ) { + my $result = $obj->TO_JSON(); + if ( defined $result and ref( $result ) ) { + if ( refaddr( $obj ) eq refaddr( $result ) ) { + encode_error( sprintf( + "%s::TO_JSON method returned same object as was passed instead of a new one", + ref $obj + ) ); + } + } + + return $self->object_to_json( $result ); + } + + return "$obj" if ( $bignum and _is_bignum($obj) ); + return $self->blessed_to_json($obj) if ($allow_blessed and $as_nonblessed); # will be removed. + + encode_error( sprintf("encountered object '%s', but neither allow_blessed " + . "nor convert_blessed settings are enabled", $obj) + ) unless ($allow_blessed); + + return 'null'; + } + else { + return $self->value_to_json($obj); + } + } + else{ + return $self->value_to_json($obj); + } + } + + + sub hash_to_json { + my ($self, $obj) = @_; + my @res; + + encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)") + if (++$depth > $max_depth); + + my ($pre, $post) = $indent ? $self->_up_indent() : ('', ''); + my $del = ($space_before ? ' ' : '') . ':' . ($space_after ? ' ' : ''); + + for my $k ( _sort( $obj ) ) { + if ( OLD_PERL ) { utf8::decode($k) } # key for Perl 5.6 / be optimized + push @res, string_to_json( $self, $k ) + . $del + . ( $self->object_to_json( $obj->{$k} ) || $self->value_to_json( $obj->{$k} ) ); + } + + --$depth; + $self->_down_indent() if ($indent); + + return '{' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . '}'; + } + + + sub array_to_json { + my ($self, $obj) = @_; + my @res; + + encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)") + if (++$depth > $max_depth); + + my ($pre, $post) = $indent ? $self->_up_indent() : ('', ''); + + for my $v (@$obj){ + push @res, $self->object_to_json($v) || $self->value_to_json($v); + } + + --$depth; + $self->_down_indent() if ($indent); + + return '[' . ( @res ? $pre : '' ) . ( @res ? join( ",$pre", @res ) . $post : '' ) . ']'; + } + + + sub value_to_json { + my ($self, $value) = @_; + + return 'null' if(!defined $value); + + my $b_obj = B::svref_2object(\$value); # for round trip problem + my $flags = $b_obj->FLAGS; + + return $value # as is + if $flags & ( B::SVp_IOK | B::SVp_NOK ) and !( $flags & B::SVp_POK ); # SvTYPE is IV or NV? + + my $type = ref($value); + + if(!$type){ + return string_to_json($self, $value); + } + elsif( blessed($value) and $value->isa('JSON::PP::Boolean') ){ + return $$value == 1 ? 'true' : 'false'; + } + elsif ($type) { + if ((overload::StrVal($value) =~ /=(\w+)/)[0]) { + return $self->value_to_json("$value"); + } + + if ($type eq 'SCALAR' and defined $$value) { + return $$value eq '1' ? 'true' + : $$value eq '0' ? 'false' + : $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ? 'null' + : encode_error("cannot encode reference to scalar"); + } + + if ( $self->{PROPS}->[ P_ALLOW_UNKNOWN ] ) { + return 'null'; + } + else { + if ( $type eq 'SCALAR' or $type eq 'REF' ) { + encode_error("cannot encode reference to scalar"); + } + else { + encode_error("encountered $value, but JSON can only represent references to arrays or hashes"); + } + } + + } + else { + return $self->{fallback}->($value) + if ($self->{fallback} and ref($self->{fallback}) eq 'CODE'); + return 'null'; + } + + } + + + my %esc = ( + "\n" => '\n', + "\r" => '\r', + "\t" => '\t', + "\f" => '\f', + "\b" => '\b', + "\"" => '\"', + "\\" => '\\\\', + "\'" => '\\\'', + ); + + + sub string_to_json { + my ($self, $arg) = @_; + + $arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g; + $arg =~ s/\//\\\//g if ($escape_slash); + $arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg; + + if ($ascii) { + $arg = JSON_PP_encode_ascii($arg); + } + + if ($latin1) { + $arg = JSON_PP_encode_latin1($arg); + } + + if ($utf8) { + utf8::encode($arg); + } + + return '"' . $arg . '"'; + } + + + sub blessed_to_json { + my $reftype = reftype($_[1]) || ''; + if ($reftype eq 'HASH') { + return $_[0]->hash_to_json($_[1]); + } + elsif ($reftype eq 'ARRAY') { + return $_[0]->array_to_json($_[1]); + } + else { + return 'null'; + } + } + + + sub encode_error { + my $error = shift; + Carp::croak "$error"; + } + + + sub _sort { + defined $keysort ? (sort $keysort (keys %{$_[0]})) : keys %{$_[0]}; + } + + + sub _up_indent { + my $self = shift; + my $space = ' ' x $indent_length; + + my ($pre,$post) = ('',''); + + $post = "\n" . $space x $indent_count; + + $indent_count++; + + $pre = "\n" . $space x $indent_count; + + return ($pre,$post); + } + + + sub _down_indent { $indent_count--; } + + + sub PP_encode_box { + { + depth => $depth, + indent_count => $indent_count, + }; + } + + } # Convert + + + sub _encode_ascii { + join('', + map { + $_ <= 127 ? + chr($_) : + $_ <= 65535 ? + sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_)); + } unpack('U*', $_[0]) + ); + } + + + sub _encode_latin1 { + join('', + map { + $_ <= 255 ? + chr($_) : + $_ <= 65535 ? + sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_)); + } unpack('U*', $_[0]) + ); + } + + + sub _encode_surrogates { # from perlunicode + my $uni = $_[0] - 0x10000; + return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00); + } + + + sub _is_bignum { + $_[0]->isa('Math::BigInt') or $_[0]->isa('Math::BigFloat'); + } + + + + # + # JSON => Perl + # + + my $max_intsize; + + BEGIN { + my $checkint = 1111; + for my $d (5..64) { + $checkint .= 1; + my $int = eval qq| $checkint |; + if ($int =~ /[eE]/) { + $max_intsize = $d - 1; + last; + } + } + } + + { # PARSE + + my %escapes = ( # by Jeremy Muhlich + b => "\x8", + t => "\x9", + n => "\xA", + f => "\xC", + r => "\xD", + '\\' => '\\', + '"' => '"', + '/' => '/', + ); + + my $text; # json data + my $at; # offset + my $ch; # 1chracter + my $len; # text length (changed according to UTF8 or NON UTF8) + # INTERNAL + my $depth; # nest counter + my $encoding; # json text encoding + my $is_valid_utf8; # temp variable + my $utf8_len; # utf8 byte length + # FLAGS + my $utf8; # must be utf8 + my $max_depth; # max nest number of objects and arrays + my $max_size; + my $relaxed; + my $cb_object; + my $cb_sk_object; + + my $F_HOOK; + + my $allow_bigint; # using Math::BigInt + my $singlequote; # loosely quoting + my $loose; # + my $allow_barekey; # bareKey + + # $opt flag + # 0x00000001 .... decode_prefix + # 0x10000000 .... incr_parse + + sub PP_decode_json { + my ($self, $opt); # $opt is an effective flag during this decode_json. + + ($self, $text, $opt) = @_; + + ($at, $ch, $depth) = (0, '', 0); + + if ( !defined $text or ref $text ) { + decode_error("malformed JSON string, neither array, object, number, string or atom"); + } + + my $idx = $self->{PROPS}; + + ($utf8, $relaxed, $loose, $allow_bigint, $allow_barekey, $singlequote) + = @{$idx}[P_UTF8, P_RELAXED, P_LOOSE .. P_ALLOW_SINGLEQUOTE]; + + if ( $utf8 ) { + utf8::downgrade( $text, 1 ) or Carp::croak("Wide character in subroutine entry"); + } + else { + utf8::upgrade( $text ); + } + + $len = length $text; + + ($max_depth, $max_size, $cb_object, $cb_sk_object, $F_HOOK) + = @{$self}{qw/max_depth max_size cb_object cb_sk_object F_HOOK/}; + + if ($max_size > 1) { + use bytes; + my $bytes = length $text; + decode_error( + sprintf("attempted decode of JSON text of %s bytes size, but max_size is set to %s" + , $bytes, $max_size), 1 + ) if ($bytes > $max_size); + } + + # Currently no effect + # should use regexp + my @octets = unpack('C4', $text); + $encoding = ( $octets[0] and $octets[1]) ? 'UTF-8' + : (!$octets[0] and $octets[1]) ? 'UTF-16BE' + : (!$octets[0] and !$octets[1]) ? 'UTF-32BE' + : ( $octets[2] ) ? 'UTF-16LE' + : (!$octets[2] ) ? 'UTF-32LE' + : 'unknown'; + + white(); # remove head white space + + my $valid_start = defined $ch; # Is there a first character for JSON structure? + + my $result = value(); + + return undef if ( !$result && ( $opt & 0x10000000 ) ); # for incr_parse + + decode_error("malformed JSON string, neither array, object, number, string or atom") unless $valid_start; + + if ( !$idx->[ P_ALLOW_NONREF ] and !ref $result ) { + decode_error( + 'JSON text must be an object or array (but found number, string, true, false or null,' + . ' use allow_nonref to allow this)', 1); + } + + Carp::croak('something wrong.') if $len < $at; # we won't arrive here. + + my $consumed = defined $ch ? $at - 1 : $at; # consumed JSON text length + + white(); # remove tail white space + + if ( $ch ) { + return ( $result, $consumed ) if ($opt & 0x00000001); # all right if decode_prefix + decode_error("garbage after JSON object"); + } + + ( $opt & 0x00000001 ) ? ( $result, $consumed ) : $result; + } + + + sub next_chr { + return $ch = undef if($at >= $len); + $ch = substr($text, $at++, 1); + } + + + sub value { + white(); + return if(!defined $ch); + return object() if($ch eq '{'); + return array() if($ch eq '['); + return string() if($ch eq '"' or ($singlequote and $ch eq "'")); + return number() if($ch =~ /[0-9]/ or $ch eq '-'); + return word(); + } + + sub string { + my ($i, $s, $t, $u); + my $utf16; + my $is_utf8; + + ($is_valid_utf8, $utf8_len) = ('', 0); + + $s = ''; # basically UTF8 flag on + + if($ch eq '"' or ($singlequote and $ch eq "'")){ + my $boundChar = $ch; + + OUTER: while( defined(next_chr()) ){ + + if($ch eq $boundChar){ + next_chr(); + + if ($utf16) { + decode_error("missing low surrogate character in surrogate pair"); + } + + utf8::decode($s) if($is_utf8); + + return $s; + } + elsif($ch eq '\\'){ + next_chr(); + if(exists $escapes{$ch}){ + $s .= $escapes{$ch}; + } + elsif($ch eq 'u'){ # UNICODE handling + my $u = ''; + + for(1..4){ + $ch = next_chr(); + last OUTER if($ch !~ /[0-9a-fA-F]/); + $u .= $ch; + } + + # U+D800 - U+DBFF + if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/) { # UTF-16 high surrogate? + $utf16 = $u; + } + # U+DC00 - U+DFFF + elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/) { # UTF-16 low surrogate? + unless (defined $utf16) { + decode_error("missing high surrogate character in surrogate pair"); + } + $is_utf8 = 1; + $s .= JSON_PP_decode_surrogates($utf16, $u) || next; + $utf16 = undef; + } + else { + if (defined $utf16) { + decode_error("surrogate pair expected"); + } + + if ( ( my $hex = hex( $u ) ) > 127 ) { + $is_utf8 = 1; + $s .= JSON_PP_decode_unicode($u) || next; + } + else { + $s .= chr $hex; + } + } + + } + else{ + unless ($loose) { + $at -= 2; + decode_error('illegal backslash escape sequence in string'); + } + $s .= $ch; + } + } + else{ + + if ( ord $ch > 127 ) { + if ( $utf8 ) { + unless( $ch = is_valid_utf8($ch) ) { + $at -= 1; + decode_error("malformed UTF-8 character in JSON string"); + } + else { + $at += $utf8_len - 1; + } + } + else { + utf8::encode( $ch ); + } + + $is_utf8 = 1; + } + + if (!$loose) { + if ($ch =~ /[\x00-\x1f\x22\x5c]/) { # '/' ok + $at--; + decode_error('invalid character encountered while parsing JSON string'); + } + } + + $s .= $ch; + } + } + } + + decode_error("unexpected end of string while parsing JSON string"); + } + + + sub white { + while( defined $ch ){ + if($ch le ' '){ + next_chr(); + } + elsif($ch eq '/'){ + next_chr(); + if(defined $ch and $ch eq '/'){ + 1 while(defined(next_chr()) and $ch ne "\n" and $ch ne "\r"); + } + elsif(defined $ch and $ch eq '*'){ + next_chr(); + while(1){ + if(defined $ch){ + if($ch eq '*'){ + if(defined(next_chr()) and $ch eq '/'){ + next_chr(); + last; + } + } + else{ + next_chr(); + } + } + else{ + decode_error("Unterminated comment"); + } + } + next; + } + else{ + $at--; + decode_error("malformed JSON string, neither array, object, number, string or atom"); + } + } + else{ + if ($relaxed and $ch eq '#') { # correctly? + pos($text) = $at; + $text =~ /\G([^\n]*(?:\r\n|\r|\n|$))/g; + $at = pos($text); + next_chr; + next; + } + + last; + } + } + } + + + sub array { + my $a = $_[0] || []; # you can use this code to use another array ref object. + + decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)') + if (++$depth > $max_depth); + + next_chr(); + white(); + + if(defined $ch and $ch eq ']'){ + --$depth; + next_chr(); + return $a; + } + else { + while(defined($ch)){ + push @$a, value(); + + white(); + + if (!defined $ch) { + last; + } + + if($ch eq ']'){ + --$depth; + next_chr(); + return $a; + } + + if($ch ne ','){ + last; + } + + next_chr(); + white(); + + if ($relaxed and $ch eq ']') { + --$depth; + next_chr(); + return $a; + } + + } + } + + decode_error(", or ] expected while parsing array"); + } + + + sub object { + my $o = $_[0] || {}; # you can use this code to use another hash ref object. + my $k; + + decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)') + if (++$depth > $max_depth); + next_chr(); + white(); + + if(defined $ch and $ch eq '}'){ + --$depth; + next_chr(); + if ($F_HOOK) { + return _json_object_hook($o); + } + return $o; + } + else { + while (defined $ch) { + $k = ($allow_barekey and $ch ne '"' and $ch ne "'") ? bareKey() : string(); + white(); + + if(!defined $ch or $ch ne ':'){ + $at--; + decode_error("':' expected"); + } + + next_chr(); + $o->{$k} = value(); + white(); + + last if (!defined $ch); + + if($ch eq '}'){ + --$depth; + next_chr(); + if ($F_HOOK) { + return _json_object_hook($o); + } + return $o; + } + + if($ch ne ','){ + last; + } + + next_chr(); + white(); + + if ($relaxed and $ch eq '}') { + --$depth; + next_chr(); + if ($F_HOOK) { + return _json_object_hook($o); + } + return $o; + } + + } + + } + + $at--; + decode_error(", or } expected while parsing object/hash"); + } + + + sub bareKey { # doesn't strictly follow Standard ECMA-262 3rd Edition + my $key; + while($ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){ + $key .= $ch; + next_chr(); + } + return $key; + } + + + sub word { + my $word = substr($text,$at-1,4); + + if($word eq 'true'){ + $at += 3; + next_chr; + return $JSON::PP::true; + } + elsif($word eq 'null'){ + $at += 3; + next_chr; + return undef; + } + elsif($word eq 'fals'){ + $at += 3; + if(substr($text,$at,1) eq 'e'){ + $at++; + next_chr; + return $JSON::PP::false; + } + } + + $at--; # for decode_error report + + decode_error("'null' expected") if ($word =~ /^n/); + decode_error("'true' expected") if ($word =~ /^t/); + decode_error("'false' expected") if ($word =~ /^f/); + decode_error("malformed JSON string, neither array, object, number, string or atom"); + } + + + sub number { + my $n = ''; + my $v; + + # According to RFC4627, hex or oct digits are invalid. + if($ch eq '0'){ + my $peek = substr($text,$at,1); + my $hex = $peek =~ /[xX]/; # 0 or 1 + + if($hex){ + decode_error("malformed number (leading zero must not be followed by another digit)"); + ($n) = ( substr($text, $at+1) =~ /^([0-9a-fA-F]+)/); + } + else{ # oct + ($n) = ( substr($text, $at) =~ /^([0-7]+)/); + if (defined $n and length $n > 1) { + decode_error("malformed number (leading zero must not be followed by another digit)"); + } + } + + if(defined $n and length($n)){ + if (!$hex and length($n) == 1) { + decode_error("malformed number (leading zero must not be followed by another digit)"); + } + $at += length($n) + $hex; + next_chr; + return $hex ? hex($n) : oct($n); + } + } + + if($ch eq '-'){ + $n = '-'; + next_chr; + if (!defined $ch or $ch !~ /\d/) { + decode_error("malformed number (no digits after initial minus)"); + } + } + + while(defined $ch and $ch =~ /\d/){ + $n .= $ch; + next_chr; + } + + if(defined $ch and $ch eq '.'){ + $n .= '.'; + + next_chr; + if (!defined $ch or $ch !~ /\d/) { + decode_error("malformed number (no digits after decimal point)"); + } + else { + $n .= $ch; + } + + while(defined(next_chr) and $ch =~ /\d/){ + $n .= $ch; + } + } + + if(defined $ch and ($ch eq 'e' or $ch eq 'E')){ + $n .= $ch; + next_chr; + + if(defined($ch) and ($ch eq '+' or $ch eq '-')){ + $n .= $ch; + next_chr; + if (!defined $ch or $ch =~ /\D/) { + decode_error("malformed number (no digits after exp sign)"); + } + $n .= $ch; + } + elsif(defined($ch) and $ch =~ /\d/){ + $n .= $ch; + } + else { + decode_error("malformed number (no digits after exp sign)"); + } + + while(defined(next_chr) and $ch =~ /\d/){ + $n .= $ch; + } + + } + + $v .= $n; + + if ($v !~ /[.eE]/ and length $v > $max_intsize) { + if ($allow_bigint) { # from Adam Sussman + require Math::BigInt; + return Math::BigInt->new($v); + } + else { + return "$v"; + } + } + elsif ($allow_bigint) { + require Math::BigFloat; + return Math::BigFloat->new($v); + } + + return 0+$v; + } + + + sub is_valid_utf8 { + + $utf8_len = $_[0] =~ /[\x00-\x7F]/ ? 1 + : $_[0] =~ /[\xC2-\xDF]/ ? 2 + : $_[0] =~ /[\xE0-\xEF]/ ? 3 + : $_[0] =~ /[\xF0-\xF4]/ ? 4 + : 0 + ; + + return unless $utf8_len; + + my $is_valid_utf8 = substr($text, $at - 1, $utf8_len); + + return ( $is_valid_utf8 =~ /^(?: + [\x00-\x7F] + |[\xC2-\xDF][\x80-\xBF] + |[\xE0][\xA0-\xBF][\x80-\xBF] + |[\xE1-\xEC][\x80-\xBF][\x80-\xBF] + |[\xED][\x80-\x9F][\x80-\xBF] + |[\xEE-\xEF][\x80-\xBF][\x80-\xBF] + |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF] + |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF] + |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF] + )$/x ) ? $is_valid_utf8 : ''; + } + + + sub decode_error { + my $error = shift; + my $no_rep = shift; + my $str = defined $text ? substr($text, $at) : ''; + my $mess = ''; + my $type = $] >= 5.008 ? 'U*' + : $] < 5.006 ? 'C*' + : utf8::is_utf8( $str ) ? 'U*' # 5.6 + : 'C*' + ; + + for my $c ( unpack( $type, $str ) ) { # emulate pv_uni_display() ? + $mess .= $c == 0x07 ? '\a' + : $c == 0x09 ? '\t' + : $c == 0x0a ? '\n' + : $c == 0x0d ? '\r' + : $c == 0x0c ? '\f' + : $c < 0x20 ? sprintf('\x{%x}', $c) + : $c == 0x5c ? '\\\\' + : $c < 0x80 ? chr($c) + : sprintf('\x{%x}', $c) + ; + if ( length $mess >= 20 ) { + $mess .= '...'; + last; + } + } + + unless ( length $mess ) { + $mess = '(end of string)'; + } + + Carp::croak ( + $no_rep ? "$error" : "$error, at character offset $at (before \"$mess\")" + ); + + } + + + sub _json_object_hook { + my $o = $_[0]; + my @ks = keys %{$o}; + + if ( $cb_sk_object and @ks == 1 and exists $cb_sk_object->{ $ks[0] } and ref $cb_sk_object->{ $ks[0] } ) { + my @val = $cb_sk_object->{ $ks[0] }->( $o->{$ks[0]} ); + if (@val == 1) { + return $val[0]; + } + } + + my @val = $cb_object->($o) if ($cb_object); + if (@val == 0 or @val > 1) { + return $o; + } + else { + return $val[0]; + } + } + + + sub PP_decode_box { + { + text => $text, + at => $at, + ch => $ch, + len => $len, + depth => $depth, + encoding => $encoding, + is_valid_utf8 => $is_valid_utf8, + }; + } + + } # PARSE + + + sub _decode_surrogates { # from perlunicode + my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00); + my $un = pack('U*', $uni); + utf8::encode( $un ); + return $un; + } + + + sub _decode_unicode { + my $un = pack('U', hex shift); + utf8::encode( $un ); + return $un; + } + + # + # Setup for various Perl versions (the code from JSON::PP58) + # + + BEGIN { + + unless ( defined &utf8::is_utf8 ) { + require Encode; + *utf8::is_utf8 = *Encode::is_utf8; + } + + if ( $] >= 5.008 ) { + *JSON::PP::JSON_PP_encode_ascii = \&_encode_ascii; + *JSON::PP::JSON_PP_encode_latin1 = \&_encode_latin1; + *JSON::PP::JSON_PP_decode_surrogates = \&_decode_surrogates; + *JSON::PP::JSON_PP_decode_unicode = \&_decode_unicode; + } + + if ($] >= 5.008 and $] < 5.008003) { # join() in 5.8.0 - 5.8.2 is broken. + package # hide from PAUSE + JSON::PP; + require subs; + subs->import('join'); + eval q| + sub join { + return '' if (@_ < 2); + my $j = shift; + my $str = shift; + for (@_) { $str .= $j . $_; } + return $str; + } + |; + } + + + sub JSON::PP::incr_parse { + local $Carp::CarpLevel = 1; + ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ ); + } + + + sub JSON::PP::incr_skip { + ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip; + } + + + sub JSON::PP::incr_reset { + ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset; + } + + eval q{ + sub JSON::PP::incr_text : lvalue { + $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new; + + if ( $_[0]->{_incr_parser}->{incr_parsing} ) { + Carp::croak("incr_text can not be called when the incremental parser already started parsing"); + } + $_[0]->{_incr_parser}->{incr_text}; + } + } if ( $] >= 5.006 ); + + } # Setup for various Perl versions (the code from JSON::PP58) + + + ############################### + # Utilities + # + + BEGIN { + eval 'require Scalar::Util'; + unless($@){ + *JSON::PP::blessed = \&Scalar::Util::blessed; + *JSON::PP::reftype = \&Scalar::Util::reftype; + *JSON::PP::refaddr = \&Scalar::Util::refaddr; + } + else{ # This code is from Scalar::Util. + # warn $@; + eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }'; + *JSON::PP::blessed = sub { + local($@, $SIG{__DIE__}, $SIG{__WARN__}); + ref($_[0]) ? eval { $_[0]->a_sub_not_likely_to_be_here } : undef; + }; + my %tmap = qw( + B::NULL SCALAR + B::HV HASH + B::AV ARRAY + B::CV CODE + B::IO IO + B::GV GLOB + B::REGEXP REGEXP + ); + *JSON::PP::reftype = sub { + my $r = shift; + + return undef unless length(ref($r)); + + my $t = ref(B::svref_2object($r)); + + return + exists $tmap{$t} ? $tmap{$t} + : length(ref($$r)) ? 'REF' + : 'SCALAR'; + }; + *JSON::PP::refaddr = sub { + return undef unless length(ref($_[0])); + + my $addr; + if(defined(my $pkg = blessed($_[0]))) { + $addr .= bless $_[0], 'Scalar::Util::Fake'; + bless $_[0], $pkg; + } + else { + $addr .= $_[0] + } + + $addr =~ /0x(\w+)/; + local $^W; + #no warnings 'portable'; + hex($1); + } + } + } + + + # shamelessly copied and modified from JSON::XS code. + + unless ( $INC{'JSON/PP.pm'} ) { + eval q| + package + JSON::PP::Boolean; + + use overload ( + "0+" => sub { ${$_[0]} }, + "++" => sub { $_[0] = ${$_[0]} + 1 }, + "--" => sub { $_[0] = ${$_[0]} - 1 }, + fallback => 1, + ); + |; + } + + $JSON::PP::true = do { bless \(my $dummy = 1), "JSON::PP::Boolean" }; + $JSON::PP::false = do { bless \(my $dummy = 0), "JSON::PP::Boolean" }; + + sub is_bool { defined $_[0] and UNIVERSAL::isa($_[0], "JSON::PP::Boolean"); } + + sub true { $JSON::PP::true } + sub false { $JSON::PP::false } + sub null { undef; } + + ############################### + + ############################### + + package # hide from PAUSE + JSON::PP::IncrParser; + + use strict; + + use constant INCR_M_WS => 0; # initial whitespace skipping + use constant INCR_M_STR => 1; # inside string + use constant INCR_M_BS => 2; # inside backslash + use constant INCR_M_JSON => 3; # outside anything, count nesting + use constant INCR_M_C0 => 4; + use constant INCR_M_C1 => 5; + + use vars qw($VERSION); + $VERSION = '1.01'; + + my $unpack_format = $] < 5.006 ? 'C*' : 'U*'; + + sub new { + my ( $class ) = @_; + + bless { + incr_nest => 0, + incr_text => undef, + incr_parsing => 0, + incr_p => 0, + }, $class; + } + + + sub incr_parse { + my ( $self, $coder, $text ) = @_; + + $self->{incr_text} = '' unless ( defined $self->{incr_text} ); + + if ( defined $text ) { + if ( utf8::is_utf8( $text ) and !utf8::is_utf8( $self->{incr_text} ) ) { + utf8::upgrade( $self->{incr_text} ) ; + utf8::decode( $self->{incr_text} ) ; + } + $self->{incr_text} .= $text; + } + + + my $max_size = $coder->get_max_size; + + if ( defined wantarray ) { + + $self->{incr_mode} = INCR_M_WS unless defined $self->{incr_mode}; + + if ( wantarray ) { + my @ret; + + $self->{incr_parsing} = 1; + + do { + push @ret, $self->_incr_parse( $coder, $self->{incr_text} ); + + unless ( !$self->{incr_nest} and $self->{incr_mode} == INCR_M_JSON ) { + $self->{incr_mode} = INCR_M_WS if $self->{incr_mode} != INCR_M_STR; + } + + } until ( length $self->{incr_text} >= $self->{incr_p} ); + + $self->{incr_parsing} = 0; + + return @ret; + } + else { # in scalar context + $self->{incr_parsing} = 1; + my $obj = $self->_incr_parse( $coder, $self->{incr_text} ); + $self->{incr_parsing} = 0 if defined $obj; # pointed by Martin J. Evans + return $obj ? $obj : undef; # $obj is an empty string, parsing was completed. + } + + } + + } + + + sub _incr_parse { + my ( $self, $coder, $text, $skip ) = @_; + my $p = $self->{incr_p}; + my $restore = $p; + + my @obj; + my $len = length $text; + + if ( $self->{incr_mode} == INCR_M_WS ) { + while ( $len > $p ) { + my $s = substr( $text, $p, 1 ); + $p++ and next if ( 0x20 >= unpack($unpack_format, $s) ); + $self->{incr_mode} = INCR_M_JSON; + last; + } + } + + while ( $len > $p ) { + my $s = substr( $text, $p++, 1 ); + + if ( $s eq '"' ) { + if (substr( $text, $p - 2, 1 ) eq '\\' ) { + next; + } + + if ( $self->{incr_mode} != INCR_M_STR ) { + $self->{incr_mode} = INCR_M_STR; + } + else { + $self->{incr_mode} = INCR_M_JSON; + unless ( $self->{incr_nest} ) { + last; + } + } + } + + if ( $self->{incr_mode} == INCR_M_JSON ) { + + if ( $s eq '[' or $s eq '{' ) { + if ( ++$self->{incr_nest} > $coder->get_max_depth ) { + Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)'); + } + } + elsif ( $s eq ']' or $s eq '}' ) { + last if ( --$self->{incr_nest} <= 0 ); + } + elsif ( $s eq '#' ) { + while ( $len > $p ) { + last if substr( $text, $p++, 1 ) eq "\n"; + } + } + + } + + } + + $self->{incr_p} = $p; + + return if ( $self->{incr_mode} == INCR_M_STR and not $self->{incr_nest} ); + return if ( $self->{incr_mode} == INCR_M_JSON and $self->{incr_nest} > 0 ); + + return '' unless ( length substr( $self->{incr_text}, 0, $p ) ); + + local $Carp::CarpLevel = 2; + + $self->{incr_p} = $restore; + $self->{incr_c} = $p; + + my ( $obj, $tail ) = $coder->PP_decode_json( substr( $self->{incr_text}, 0, $p ), 0x10000001 ); + + $self->{incr_text} = substr( $self->{incr_text}, $p ); + $self->{incr_p} = 0; + + return $obj || ''; + } + + + sub incr_text { + if ( $_[0]->{incr_parsing} ) { + Carp::croak("incr_text can not be called when the incremental parser already started parsing"); + } + $_[0]->{incr_text}; + } + + + sub incr_skip { + my $self = shift; + $self->{incr_text} = substr( $self->{incr_text}, $self->{incr_c} ); + $self->{incr_p} = 0; + } + + + sub incr_reset { + my $self = shift; + $self->{incr_text} = undef; + $self->{incr_p} = 0; + $self->{incr_mode} = 0; + $self->{incr_nest} = 0; + $self->{incr_parsing} = 0; + } + + ############################### + + + 1; + __END__ + =pod + + =head1 NAME + + JSON::PP - JSON::XS compatible pure-Perl module. + + =head1 SYNOPSIS + + use JSON::PP; + + # exported functions, they croak on error + # and expect/generate UTF-8 + + $utf8_encoded_json_text = encode_json $perl_hash_or_arrayref; + $perl_hash_or_arrayref = decode_json $utf8_encoded_json_text; + + # OO-interface + + $coder = JSON::PP->new->ascii->pretty->allow_nonref; + + $json_text = $json->encode( $perl_scalar ); + $perl_scalar = $json->decode( $json_text ); + + $pretty_printed = $json->pretty->encode( $perl_scalar ); # pretty-printing + + # Note that JSON version 2.0 and above will automatically use + # JSON::XS or JSON::PP, so you should be able to just: + + use JSON; + + + =head1 VERSION + + 2.27200 + + L 2.27 (~2.30) compatible. + + =head1 DESCRIPTION + + This module is L compatible pure Perl module. + (Perl 5.8 or later is recommended) + + JSON::XS is the fastest and most proper JSON module on CPAN. + It is written by Marc Lehmann in C, so must be compiled and + installed in the used environment. + + JSON::PP is a pure-Perl module and has compatibility to JSON::XS. + + + =head2 FEATURES + + =over + + =item * correct unicode handling + + This module knows how to handle Unicode (depending on Perl version). + + See to L and + L. + + + =item * round-trip integrity + + When you serialise a perl data structure using only data types + supported by JSON and Perl, the deserialised data structure is + identical on the Perl level. (e.g. the string "2.0" doesn't suddenly + become "2" just because it looks like a number). There I minor + exceptions to this, read the MAPPING section below to learn about + those. + + + =item * strict checking of JSON correctness + + There is no guessing, no generating of illegal JSON texts by default, + and only JSON is accepted as input by default (the latter is a + security feature). But when some options are set, loose checking + features are available. + + =back + + =head1 FUNCTIONAL INTERFACE + + Some documents are copied and modified from L. + + =head2 encode_json + + $json_text = encode_json $perl_scalar + + Converts the given Perl data structure to a UTF-8 encoded, binary string. + + This function call is functionally identical to: + + $json_text = JSON::PP->new->utf8->encode($perl_scalar) + + =head2 decode_json + + $perl_scalar = decode_json $json_text + + The opposite of C: expects an UTF-8 (binary) string and tries + to parse that as an UTF-8 encoded JSON text, returning the resulting + reference. + + This function call is functionally identical to: + + $perl_scalar = JSON::PP->new->utf8->decode($json_text) + + =head2 JSON::PP::is_bool + + $is_boolean = JSON::PP::is_bool($scalar) + + Returns true if the passed scalar represents either JSON::PP::true or + JSON::PP::false, two constants that act like C<1> and C<0> respectively + and are also used to represent JSON C and C in Perl strings. + + =head2 JSON::PP::true + + Returns JSON true value which is blessed object. + It C JSON::PP::Boolean object. + + =head2 JSON::PP::false + + Returns JSON false value which is blessed object. + It C JSON::PP::Boolean object. + + =head2 JSON::PP::null + + Returns C. + + See L, below, for more information on how JSON values are mapped to + Perl. + + + =head1 HOW DO I DECODE A DATA FROM OUTER AND ENCODE TO OUTER + + This section supposes that your perl version is 5.8 or later. + + If you know a JSON text from an outer world - a network, a file content, and so on, + is encoded in UTF-8, you should use C or C module object + with C enable. And the decoded result will contain UNICODE characters. + + # from network + my $json = JSON::PP->new->utf8; + my $json_text = CGI->new->param( 'json_data' ); + my $perl_scalar = $json->decode( $json_text ); + + # from file content + local $/; + open( my $fh, '<', 'json.data' ); + $json_text = <$fh>; + $perl_scalar = decode_json( $json_text ); + + If an outer data is not encoded in UTF-8, firstly you should C it. + + use Encode; + local $/; + open( my $fh, '<', 'json.data' ); + my $encoding = 'cp932'; + my $unicode_json_text = decode( $encoding, <$fh> ); # UNICODE + + # or you can write the below code. + # + # open( my $fh, "<:encoding($encoding)", 'json.data' ); + # $unicode_json_text = <$fh>; + + In this case, C<$unicode_json_text> is of course UNICODE string. + So you B use C nor C module object with C enable. + Instead of them, you use C module object with C disable. + + $perl_scalar = $json->utf8(0)->decode( $unicode_json_text ); + + Or C and C: + + $perl_scalar = decode_json( encode( 'utf8', $unicode_json_text ) ); + # this way is not efficient. + + And now, you want to convert your C<$perl_scalar> into JSON data and + send it to an outer world - a network or a file content, and so on. + + Your data usually contains UNICODE strings and you want the converted data to be encoded + in UTF-8, you should use C or C module object with C enable. + + print encode_json( $perl_scalar ); # to a network? file? or display? + # or + print $json->utf8->encode( $perl_scalar ); + + If C<$perl_scalar> does not contain UNICODE but C<$encoding>-encoded strings + for some reason, then its characters are regarded as B for perl + (because it does not concern with your $encoding). + You B use C nor C module object with C enable. + Instead of them, you use C module object with C disable. + Note that the resulted text is a UNICODE string but no problem to print it. + + # $perl_scalar contains $encoding encoded string values + $unicode_json_text = $json->utf8(0)->encode( $perl_scalar ); + # $unicode_json_text consists of characters less than 0x100 + print $unicode_json_text; + + Or C all string values and C: + + $perl_scalar->{ foo } = decode( $encoding, $perl_scalar->{ foo } ); + # ... do it to each string values, then encode_json + $json_text = encode_json( $perl_scalar ); + + This method is a proper way but probably not efficient. + + See to L, L. + + + =head1 METHODS + + Basically, check to L or L. + + =head2 new + + $json = JSON::PP->new + + Returns a new JSON::PP object that can be used to de/encode JSON + strings. + + All boolean flags described below are by default I. + + The mutators for flags all return the JSON object again and thus calls can + be chained: + + my $json = JSON::PP->new->utf8->space_after->encode({a => [1,2]}) + => {"a": [1, 2]} + + =head2 ascii + + $json = $json->ascii([$enable]) + + $enabled = $json->get_ascii + + If $enable is true (or missing), then the encode method will not generate characters outside + the code range 0..127. Any Unicode characters outside that range will be escaped using either + a single \uXXXX or a double \uHHHH\uLLLLL escape sequence, as per RFC4627. + (See to L). + + In Perl 5.005, there is no character having high value (more than 255). + See to L. + + If $enable is false, then the encode method will not escape Unicode characters unless + required by the JSON syntax or other flags. This results in a faster and more compact format. + + JSON::PP->new->ascii(1)->encode([chr 0x10401]) + => ["\ud801\udc01"] + + =head2 latin1 + + $json = $json->latin1([$enable]) + + $enabled = $json->get_latin1 + + If $enable is true (or missing), then the encode method will encode the resulting JSON + text as latin1 (or iso-8859-1), escaping any characters outside the code range 0..255. + + If $enable is false, then the encode method will not escape Unicode characters + unless required by the JSON syntax or other flags. + + JSON::XS->new->latin1->encode (["\x{89}\x{abc}"] + => ["\x{89}\\u0abc"] # (perl syntax, U+abc escaped, U+89 not) + + See to L. + + =head2 utf8 + + $json = $json->utf8([$enable]) + + $enabled = $json->get_utf8 + + If $enable is true (or missing), then the encode method will encode the JSON result + into UTF-8, as required by many protocols, while the decode method expects to be handled + an UTF-8-encoded string. Please note that UTF-8-encoded strings do not contain any + characters outside the range 0..255, they are thus useful for bytewise/binary I/O. + + (In Perl 5.005, any character outside the range 0..255 does not exist. + See to L.) + + In future versions, enabling this option might enable autodetection of the UTF-16 and UTF-32 + encoding families, as described in RFC4627. + + If $enable is false, then the encode method will return the JSON string as a (non-encoded) + Unicode string, while decode expects thus a Unicode string. Any decoding or encoding + (e.g. to UTF-8 or UTF-16) needs to be done yourself, e.g. using the Encode module. + + Example, output UTF-16BE-encoded JSON: + + use Encode; + $jsontext = encode "UTF-16BE", JSON::PP->new->encode ($object); + + Example, decode UTF-32LE-encoded JSON: + + use Encode; + $object = JSON::PP->new->decode (decode "UTF-32LE", $jsontext); + + + =head2 pretty + + $json = $json->pretty([$enable]) + + This enables (or disables) all of the C, C and + C flags in one call to generate the most readable + (or most compact) form possible. + + Equivalent to: + + $json->indent->space_before->space_after + + =head2 indent + + $json = $json->indent([$enable]) + + $enabled = $json->get_indent + + The default indent space length is three. + You can use C to change the length. + + =head2 space_before + + $json = $json->space_before([$enable]) + + $enabled = $json->get_space_before + + If C<$enable> is true (or missing), then the C method will add an extra + optional space before the C<:> separating keys from values in JSON objects. + + If C<$enable> is false, then the C method will not add any extra + space at those places. + + This setting has no effect when decoding JSON texts. + + Example, space_before enabled, space_after and indent disabled: + + {"key" :"value"} + + =head2 space_after + + $json = $json->space_after([$enable]) + + $enabled = $json->get_space_after + + If C<$enable> is true (or missing), then the C method will add an extra + optional space after the C<:> separating keys from values in JSON objects + and extra whitespace after the C<,> separating key-value pairs and array + members. + + If C<$enable> is false, then the C method will not add any extra + space at those places. + + This setting has no effect when decoding JSON texts. + + Example, space_before and indent disabled, space_after enabled: + + {"key": "value"} + + =head2 relaxed + + $json = $json->relaxed([$enable]) + + $enabled = $json->get_relaxed + + If C<$enable> is true (or missing), then C will accept some + extensions to normal JSON syntax (see below). C will not be + affected in anyway. I. I suggest only to use this option to + parse application-specific files written by humans (configuration files, + resource files etc.) + + If C<$enable> is false (the default), then C will only accept + valid JSON texts. + + Currently accepted extensions are: + + =over 4 + + =item * list items can have an end-comma + + JSON I array elements and key-value pairs with commas. This + can be annoying if you write JSON texts manually and want to be able to + quickly append elements, so this extension accepts comma at the end of + such items not just between them: + + [ + 1, + 2, <- this comma not normally allowed + ] + { + "k1": "v1", + "k2": "v2", <- this comma not normally allowed + } + + =item * shell-style '#'-comments + + Whenever JSON allows whitespace, shell-style comments are additionally + allowed. They are terminated by the first carriage-return or line-feed + character, after which more white-space and comments are allowed. + + [ + 1, # this comment not allowed in JSON + # neither this one... + ] + + =back + + =head2 canonical + + $json = $json->canonical([$enable]) + + $enabled = $json->get_canonical + + If C<$enable> is true (or missing), then the C method will output JSON objects + by sorting their keys. This is adding a comparatively high overhead. + + If C<$enable> is false, then the C method will output key-value + pairs in the order Perl stores them (which will likely change between runs + of the same script). + + This option is useful if you want the same data structure to be encoded as + the same JSON text (given the same overall settings). If it is disabled, + the same hash might be encoded differently even if contains the same data, + as key-value pairs have no inherent ordering in Perl. + + This setting has no effect when decoding JSON texts. + + If you want your own sorting routine, you can give a code reference + or a subroutine name to C. See to C. + + =head2 allow_nonref + + $json = $json->allow_nonref([$enable]) + + $enabled = $json->get_allow_nonref + + If C<$enable> is true (or missing), then the C method can convert a + non-reference into its corresponding string, number or null JSON value, + which is an extension to RFC4627. Likewise, C will accept those JSON + values instead of croaking. + + If C<$enable> is false, then the C method will croak if it isn't + passed an arrayref or hashref, as JSON texts must either be an object + or array. Likewise, C will croak if given something that is not a + JSON object or array. + + JSON::PP->new->allow_nonref->encode ("Hello, World!") + => "Hello, World!" + + =head2 allow_unknown + + $json = $json->allow_unknown ([$enable]) + + $enabled = $json->get_allow_unknown + + If $enable is true (or missing), then "encode" will *not* throw an + exception when it encounters values it cannot represent in JSON (for + example, filehandles) but instead will encode a JSON "null" value. + Note that blessed objects are not included here and are handled + separately by c. + + If $enable is false (the default), then "encode" will throw an + exception when it encounters anything it cannot encode as JSON. + + This option does not affect "decode" in any way, and it is + recommended to leave it off unless you know your communications + partner. + + =head2 allow_blessed + + $json = $json->allow_blessed([$enable]) + + $enabled = $json->get_allow_blessed + + If C<$enable> is true (or missing), then the C method will not + barf when it encounters a blessed reference. Instead, the value of the + B option will decide whether C (C + disabled or no C method found) or a representation of the + object (C enabled and C method found) is being + encoded. Has no effect on C. + + If C<$enable> is false (the default), then C will throw an + exception when it encounters a blessed object. + + =head2 convert_blessed + + $json = $json->convert_blessed([$enable]) + + $enabled = $json->get_convert_blessed + + If C<$enable> is true (or missing), then C, upon encountering a + blessed object, will check for the availability of the C method + on the object's class. If found, it will be called in scalar context + and the resulting scalar will be encoded instead of the object. If no + C method is found, the value of C will decide what + to do. + + The C method may safely call die if it wants. If C + returns other blessed objects, those will be handled in the same + way. C must take care of not causing an endless recursion cycle + (== crash) in this case. The name of C was chosen because other + methods called by the Perl core (== not by the user of the object) are + usually in upper case letters and to avoid collisions with the C + function or method. + + This setting does not yet influence C in any way. + + If C<$enable> is false, then the C setting will decide what + to do when a blessed object is found. + + =head2 filter_json_object + + $json = $json->filter_json_object([$coderef]) + + When C<$coderef> is specified, it will be called from C each + time it decodes a JSON object. The only argument passed to the coderef + is a reference to the newly-created hash. If the code references returns + a single scalar (which need not be a reference), this value + (i.e. a copy of that scalar to avoid aliasing) is inserted into the + deserialised data structure. If it returns an empty list + (NOTE: I C, which is a valid scalar), the original deserialised + hash will be inserted. This setting can slow down decoding considerably. + + When C<$coderef> is omitted or undefined, any existing callback will + be removed and C will not change the deserialised hash in any + way. + + Example, convert all JSON objects into the integer 5: + + my $js = JSON::PP->new->filter_json_object (sub { 5 }); + # returns [5] + $js->decode ('[{}]'); # the given subroutine takes a hash reference. + # throw an exception because allow_nonref is not enabled + # so a lone 5 is not allowed. + $js->decode ('{"a":1, "b":2}'); + + =head2 filter_json_single_key_object + + $json = $json->filter_json_single_key_object($key [=> $coderef]) + + Works remotely similar to C, but is only called for + JSON objects having a single key named C<$key>. + + This C<$coderef> is called before the one specified via + C, if any. It gets passed the single value in the JSON + object. If it returns a single value, it will be inserted into the data + structure. If it returns nothing (not even C but the empty list), + the callback from C will be called next, as if no + single-key callback were specified. + + If C<$coderef> is omitted or undefined, the corresponding callback will be + disabled. There can only ever be one callback for a given key. + + As this callback gets called less often then the C + one, decoding speed will not usually suffer as much. Therefore, single-key + objects make excellent targets to serialise Perl objects into, especially + as single-key JSON objects are as close to the type-tagged value concept + as JSON gets (it's basically an ID/VALUE tuple). Of course, JSON does not + support this in any way, so you need to make sure your data never looks + like a serialised Perl hash. + + Typical names for the single object key are C<__class_whatever__>, or + C<$__dollars_are_rarely_used__$> or C<}ugly_brace_placement>, or even + things like C<__class_md5sum(classname)__>, to reduce the risk of clashing + with real hashes. + + Example, decode JSON objects of the form C<< { "__widget__" => } >> + into the corresponding C<< $WIDGET{} >> object: + + # return whatever is in $WIDGET{5}: + JSON::PP + ->new + ->filter_json_single_key_object (__widget__ => sub { + $WIDGET{ $_[0] } + }) + ->decode ('{"__widget__": 5') + + # this can be used with a TO_JSON method in some "widget" class + # for serialisation to json: + sub WidgetBase::TO_JSON { + my ($self) = @_; + + unless ($self->{id}) { + $self->{id} = ..get..some..id..; + $WIDGET{$self->{id}} = $self; + } + + { __widget__ => $self->{id} } + } + + =head2 shrink + + $json = $json->shrink([$enable]) + + $enabled = $json->get_shrink + + In JSON::XS, this flag resizes strings generated by either + C or C to their minimum size possible. + It will also try to downgrade any strings to octet-form if possible. + + In JSON::PP, it is noop about resizing strings but tries + C to the returned string by C. + See to L. + + See to L + + =head2 max_depth + + $json = $json->max_depth([$maximum_nesting_depth]) + + $max_depth = $json->get_max_depth + + Sets the maximum nesting level (default C<512>) accepted while encoding + or decoding. If a higher nesting level is detected in JSON text or a Perl + data structure, then the encoder and decoder will stop and croak at that + point. + + Nesting level is defined by number of hash- or arrayrefs that the encoder + needs to traverse to reach a given point or the number of C<{> or C<[> + characters without their matching closing parenthesis crossed to reach a + given character in a string. + + If no argument is given, the highest possible setting will be used, which + is rarely useful. + + See L for more info on why this is useful. + + When a large value (100 or more) was set and it de/encodes a deep nested object/text, + it may raise a warning 'Deep recursion on subroutine' at the perl runtime phase. + + =head2 max_size + + $json = $json->max_size([$maximum_string_size]) + + $max_size = $json->get_max_size + + Set the maximum length a JSON text may have (in bytes) where decoding is + being attempted. The default is C<0>, meaning no limit. When C + is called on a string that is longer then this many bytes, it will not + attempt to decode the string but throw an exception. This setting has no + effect on C (yet). + + If no argument is given, the limit check will be deactivated (same as when + C<0> is specified). + + See L for more info on why this is useful. + + =head2 encode + + $json_text = $json->encode($perl_scalar) + + Converts the given Perl data structure (a simple scalar or a reference + to a hash or array) to its JSON representation. Simple scalars will be + converted into JSON string or number sequences, while references to arrays + become JSON arrays and references to hashes become JSON objects. Undefined + Perl values (e.g. C) become JSON C values. + References to the integers C<0> and C<1> are converted into C and C. + + =head2 decode + + $perl_scalar = $json->decode($json_text) + + The opposite of C: expects a JSON text and tries to parse it, + returning the resulting simple scalar or reference. Croaks on error. + + JSON numbers and strings become simple Perl scalars. JSON arrays become + Perl arrayrefs and JSON objects become Perl hashrefs. C becomes + C<1> (C), C becomes C<0> (C) and + C becomes C. + + =head2 decode_prefix + + ($perl_scalar, $characters) = $json->decode_prefix($json_text) + + This works like the C method, but instead of raising an exception + when there is trailing garbage after the first JSON object, it will + silently stop parsing there and return the number of characters consumed + so far. + + JSON->new->decode_prefix ("[1] the tail") + => ([], 3) + + =head1 INCREMENTAL PARSING + + Most of this section are copied and modified from L. + + In some cases, there is the need for incremental parsing of JSON texts. + This module does allow you to parse a JSON stream incrementally. + It does so by accumulating text until it has a full JSON object, which + it then can decode. This process is similar to using C + to see if a full JSON object is available, but is much more efficient + (and can be implemented with a minimum of method calls). + + This module will only attempt to parse the JSON text once it is sure it + has enough text to get a decisive result, using a very simple but + truly incremental parser. This means that it sometimes won't stop as + early as the full parser, for example, it doesn't detect parenthesis + mismatches. The only thing it guarantees is that it starts decoding as + soon as a syntactically valid JSON text has been seen. This means you need + to set resource limits (e.g. C) to ensure the parser will stop + parsing in the presence if syntax errors. + + The following methods implement this incremental parser. + + =head2 incr_parse + + $json->incr_parse( [$string] ) # void context + + $obj_or_undef = $json->incr_parse( [$string] ) # scalar context + + @obj_or_empty = $json->incr_parse( [$string] ) # list context + + This is the central parsing function. It can both append new text and + extract objects from the stream accumulated so far (both of these + functions are optional). + + If C<$string> is given, then this string is appended to the already + existing JSON fragment stored in the C<$json> object. + + After that, if the function is called in void context, it will simply + return without doing anything further. This can be used to add more text + in as many chunks as you want. + + If the method is called in scalar context, then it will try to extract + exactly I JSON object. If that is successful, it will return this + object, otherwise it will return C. If there is a parse error, + this method will croak just as C would do (one can then use + C to skip the erroneous part). This is the most common way of + using the method. + + And finally, in list context, it will try to extract as many objects + from the stream as it can find and return them, or the empty list + otherwise. For this to work, there must be no separators between the JSON + objects or arrays, instead they must be concatenated back-to-back. If + an error occurs, an exception will be raised as in the scalar context + case. Note that in this case, any previously-parsed JSON texts will be + lost. + + Example: Parse some JSON arrays/objects in a given string and return them. + + my @objs = JSON->new->incr_parse ("[5][7][1,2]"); + + =head2 incr_text + + $lvalue_string = $json->incr_text + + This method returns the currently stored JSON fragment as an lvalue, that + is, you can manipulate it. This I works when a preceding call to + C in I successfully returned an object. Under + all other circumstances you must not call this function (I mean it. + although in simple tests it might actually work, it I fail under + real world conditions). As a special exception, you can also call this + method before having parsed anything. + + This function is useful in two cases: a) finding the trailing text after a + JSON object or b) parsing multiple JSON objects separated by non-JSON text + (such as commas). + + $json->incr_text =~ s/\s*,\s*//; + + In Perl 5.005, C attribute is not available. + You must write codes like the below: + + $string = $json->incr_text; + $string =~ s/\s*,\s*//; + $json->incr_text( $string ); + + =head2 incr_skip + + $json->incr_skip + + This will reset the state of the incremental parser and will remove the + parsed text from the input buffer. This is useful after C + died, in which case the input buffer and incremental parser state is left + unchanged, to skip the text parsed so far and to reset the parse state. + + =head2 incr_reset + + $json->incr_reset + + This completely resets the incremental parser, that is, after this call, + it will be as if the parser had never parsed anything. + + This is useful if you want to repeatedly parse JSON objects and want to + ignore any trailing data, which means you have to reset the parser after + each successful decode. + + See to L for examples. + + + =head1 JSON::PP OWN METHODS + + =head2 allow_singlequote + + $json = $json->allow_singlequote([$enable]) + + If C<$enable> is true (or missing), then C will accept + JSON strings quoted by single quotations that are invalid JSON + format. + + $json->allow_singlequote->decode({"foo":'bar'}); + $json->allow_singlequote->decode({'foo':"bar"}); + $json->allow_singlequote->decode({'foo':'bar'}); + + As same as the C option, this option may be used to parse + application-specific files written by humans. + + + =head2 allow_barekey + + $json = $json->allow_barekey([$enable]) + + If C<$enable> is true (or missing), then C will accept + bare keys of JSON object that are invalid JSON format. + + As same as the C option, this option may be used to parse + application-specific files written by humans. + + $json->allow_barekey->decode('{foo:"bar"}'); + + =head2 allow_bignum + + $json = $json->allow_bignum([$enable]) + + If C<$enable> is true (or missing), then C will convert + the big integer Perl cannot handle as integer into a L + object and convert a floating number (any) into a L. + + On the contrary, C converts C objects and C + objects into JSON numbers with C enable. + + $json->allow_nonref->allow_blessed->allow_bignum; + $bigfloat = $json->decode('2.000000000000000000000000001'); + print $json->encode($bigfloat); + # => 2.000000000000000000000000001 + + See to L about the normal conversion of JSON number. + + =head2 loose + + $json = $json->loose([$enable]) + + The unescaped [\x00-\x1f\x22\x2f\x5c] strings are invalid in JSON strings + and the module doesn't allow to C to these (except for \x2f). + If C<$enable> is true (or missing), then C will accept these + unescaped strings. + + $json->loose->decode(qq|["abc + def"]|); + + See L. + + =head2 escape_slash + + $json = $json->escape_slash([$enable]) + + According to JSON Grammar, I (U+002F) is escaped. But default + JSON::PP (as same as JSON::XS) encodes strings without escaping slash. + + If C<$enable> is true (or missing), then C will escape slashes. + + =head2 indent_length + + $json = $json->indent_length($length) + + JSON::XS indent space length is 3 and cannot be changed. + JSON::PP set the indent space length with the given $length. + The default is 3. The acceptable range is 0 to 15. + + =head2 sort_by + + $json = $json->sort_by($function_name) + $json = $json->sort_by($subroutine_ref) + + If $function_name or $subroutine_ref are set, its sort routine are used + in encoding JSON objects. + + $js = $pc->sort_by(sub { $JSON::PP::a cmp $JSON::PP::b })->encode($obj); + # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|); + + $js = $pc->sort_by('own_sort')->encode($obj); + # is($js, q|{"a":1,"b":2,"c":3,"d":4,"e":5,"f":6,"g":7,"h":8,"i":9}|); + + sub JSON::PP::own_sort { $JSON::PP::a cmp $JSON::PP::b } + + As the sorting routine runs in the JSON::PP scope, the given + subroutine name and the special variables C<$a>, C<$b> will begin + 'JSON::PP::'. + + If $integer is set, then the effect is same as C on. + + =head1 INTERNAL + + For developers. + + =over + + =item PP_encode_box + + Returns + + { + depth => $depth, + indent_count => $indent_count, + } + + + =item PP_decode_box + + Returns + + { + text => $text, + at => $at, + ch => $ch, + len => $len, + depth => $depth, + encoding => $encoding, + is_valid_utf8 => $is_valid_utf8, + }; + + =back + + =head1 MAPPING + + This section is copied from JSON::XS and modified to C. + JSON::XS and JSON::PP mapping mechanisms are almost equivalent. + + See to L. + + =head2 JSON -> PERL + + =over 4 + + =item object + + A JSON object becomes a reference to a hash in Perl. No ordering of object + keys is preserved (JSON does not preserver object key ordering itself). + + =item array + + A JSON array becomes a reference to an array in Perl. + + =item string + + A JSON string becomes a string scalar in Perl - Unicode codepoints in JSON + are represented by the same codepoints in the Perl string, so no manual + decoding is necessary. + + =item number + + A JSON number becomes either an integer, numeric (floating point) or + string scalar in perl, depending on its range and any fractional parts. On + the Perl level, there is no difference between those as Perl handles all + the conversion details, but an integer may take slightly less memory and + might represent more values exactly than floating point numbers. + + If the number consists of digits only, C will try to represent + it as an integer value. If that fails, it will try to represent it as + a numeric (floating point) value if that is possible without loss of + precision. Otherwise it will preserve the number as a string value (in + which case you lose roundtripping ability, as the JSON number will be + re-encoded to a JSON string). + + Numbers containing a fractional or exponential part will always be + represented as numeric (floating point) values, possibly at a loss of + precision (in which case you might lose perfect roundtripping ability, but + the JSON number will still be re-encoded as a JSON number). + + Note that precision is not accuracy - binary floating point values cannot + represent most decimal fractions exactly, and when converting from and to + floating point, C only guarantees precision up to but not including + the least significant bit. + + When C is enable, the big integers + and the numeric can be optionally converted into L and + L objects. + + =item true, false + + These JSON atoms become C and C, + respectively. They are overloaded to act almost exactly like the numbers + C<1> and C<0>. You can check whether a scalar is a JSON boolean by using + the C function. + + print JSON::PP::true . "\n"; + => true + print JSON::PP::true + 1; + => 1 + + ok(JSON::true eq '1'); + ok(JSON::true == 1); + + C will install these missing overloading features to the backend modules. + + + =item null + + A JSON null atom becomes C in Perl. + + C returns C. + + =back + + + =head2 PERL -> JSON + + The mapping from Perl to JSON is slightly more difficult, as Perl is a + truly typeless language, so we can only guess which JSON type is meant by + a Perl value. + + =over 4 + + =item hash references + + Perl hash references become JSON objects. As there is no inherent ordering + in hash keys (or JSON objects), they will usually be encoded in a + pseudo-random order that can change between runs of the same program but + stays generally the same within a single run of a program. C + optionally sort the hash keys (determined by the I flag), so + the same data structure will serialise to the same JSON text (given same + settings and version of JSON::XS), but this incurs a runtime overhead + and is only rarely useful, e.g. when you want to compare some JSON text + against another for equality. + + + =item array references + + Perl array references become JSON arrays. + + =item other references + + Other unblessed references are generally not allowed and will cause an + exception to be thrown, except for references to the integers C<0> and + C<1>, which get turned into C and C atoms in JSON. You can + also use C and C to improve readability. + + to_json [\0,JSON::PP::true] # yields [false,true] + + =item JSON::PP::true, JSON::PP::false, JSON::PP::null + + These special values become JSON true and JSON false values, + respectively. You can also use C<\1> and C<\0> directly if you want. + + JSON::PP::null returns C. + + =item blessed objects + + Blessed objects are not directly representable in JSON. See the + C and C methods on various options on + how to deal with this: basically, you can choose between throwing an + exception, encoding the reference as if it weren't blessed, or provide + your own serialiser method. + + See to L. + + =item simple scalars + + Simple Perl scalars (any scalar that is not a reference) are the most + difficult objects to encode: JSON::XS and JSON::PP will encode undefined scalars as + JSON C values, scalars that have last been used in a string context + before encoding as JSON strings, and anything else as number value: + + # dump as number + encode_json [2] # yields [2] + encode_json [-3.0e17] # yields [-3e+17] + my $value = 5; encode_json [$value] # yields [5] + + # used as string, so dump as string + print $value; + encode_json [$value] # yields ["5"] + + # undef becomes null + encode_json [undef] # yields [null] + + You can force the type to be a string by stringifying it: + + my $x = 3.1; # some variable containing a number + "$x"; # stringified + $x .= ""; # another, more awkward way to stringify + print $x; # perl does it for you, too, quite often + + You can force the type to be a number by numifying it: + + my $x = "3"; # some variable containing a string + $x += 0; # numify it, ensuring it will be dumped as a number + $x *= 1; # same thing, the choice is yours. + + You can not currently force the type in other, less obscure, ways. + + Note that numerical precision has the same meaning as under Perl (so + binary to decimal conversion follows the same rules as in Perl, which + can differ to other languages). Also, your perl interpreter might expose + extensions to the floating point numbers of your platform, such as + infinities or NaN's - these cannot be represented in JSON, and it is an + error to pass those in. + + =item Big Number + + When C is enable, + C converts C objects and C + objects into JSON numbers. + + + =back + + =head1 UNICODE HANDLING ON PERLS + + If you do not know about Unicode on Perl well, + please check L. + + =head2 Perl 5.8 and later + + Perl can handle Unicode and the JSON::PP de/encode methods also work properly. + + $json->allow_nonref->encode(chr hex 3042); + $json->allow_nonref->encode(chr hex 12345); + + Returns C<"\u3042"> and C<"\ud808\udf45"> respectively. + + $json->allow_nonref->decode('"\u3042"'); + $json->allow_nonref->decode('"\ud808\udf45"'); + + Returns UTF-8 encoded strings with UTF8 flag, regarded as C and C. + + Note that the versions from Perl 5.8.0 to 5.8.2, Perl built-in C was broken, + so JSON::PP wraps the C with a subroutine. Thus JSON::PP works slow in the versions. + + + =head2 Perl 5.6 + + Perl can handle Unicode and the JSON::PP de/encode methods also work. + + =head2 Perl 5.005 + + Perl 5.005 is a byte semantics world -- all strings are sequences of bytes. + That means the unicode handling is not available. + + In encoding, + + $json->allow_nonref->encode(chr hex 3042); # hex 3042 is 12354. + $json->allow_nonref->encode(chr hex 12345); # hex 12345 is 74565. + + Returns C and C, as C takes a value more than 255, it treats + as C<$value % 256>, so the above codes are equivalent to : + + $json->allow_nonref->encode(chr 66); + $json->allow_nonref->encode(chr 69); + + In decoding, + + $json->decode('"\u00e3\u0081\u0082"'); + + The returned is a byte sequence C<0xE3 0x81 0x82> for UTF-8 encoded + japanese character (C). + And if it is represented in Unicode code point, C. + + Next, + + $json->decode('"\u3042"'); + + We ordinary expect the returned value is a Unicode character C. + But here is 5.005 world. This is C<0xE3 0x81 0x82>. + + $json->decode('"\ud808\udf45"'); + + This is not a character C but bytes - C<0xf0 0x92 0x8d 0x85>. + + + =head1 TODO + + =over + + =item speed + + =item memory saving + + =back + + + =head1 SEE ALSO + + Most of the document are copied and modified from JSON::XS doc. + + L + + RFC4627 (L) + + =head1 AUTHOR + + Makamaka Hannyaharamitu, Emakamaka[at]cpan.orgE + + + =head1 COPYRIGHT AND LICENSE + + Copyright 2007-2012 by Makamaka Hannyaharamitu + + This library is free software; you can redistribute it and/or modify + it under the same terms as Perl itself. + + =cut +JSON_BACKPORTPP + +$fatpacked{"JSON/backportPP/Boolean.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_BACKPORTPP_BOOLEAN'; + =head1 NAME + + JSON::PP::Boolean - dummy module providing JSON::PP::Boolean + + =head1 SYNOPSIS + + # do not "use" yourself + + =head1 DESCRIPTION + + This module exists only to provide overload resolution for Storable + and similar modules. See L for more info about this class. + + =cut + + use JSON::backportPP (); + use strict; + + 1; + + =head1 AUTHOR + + This idea is from L written by + Marc Lehmann + + =cut + +JSON_BACKPORTPP_BOOLEAN + +$fatpacked{"JSON/backportPP/Compat5005.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_BACKPORTPP_COMPAT5005'; + package # This is JSON::backportPP + JSON::backportPP5005; + + use 5.005; + use strict; + + my @properties; + + $JSON::PP5005::VERSION = '1.10'; + + BEGIN { + + sub utf8::is_utf8 { + 0; # It is considered that UTF8 flag off for Perl 5.005. + } + + sub utf8::upgrade { + } + + sub utf8::downgrade { + 1; # must always return true. + } + + sub utf8::encode { + } + + sub utf8::decode { + } + + *JSON::PP::JSON_PP_encode_ascii = \&_encode_ascii; + *JSON::PP::JSON_PP_encode_latin1 = \&_encode_latin1; + *JSON::PP::JSON_PP_decode_surrogates = \&_decode_surrogates; + *JSON::PP::JSON_PP_decode_unicode = \&_decode_unicode; + + # missing in B module. + sub B::SVp_IOK () { 0x01000000; } + sub B::SVp_NOK () { 0x02000000; } + sub B::SVp_POK () { 0x04000000; } + + $INC{'bytes.pm'} = 1; # dummy + } + + + + sub _encode_ascii { + join('', map { $_ <= 127 ? chr($_) : sprintf('\u%04x', $_) } unpack('C*', $_[0]) ); + } + + + sub _encode_latin1 { + join('', map { chr($_) } unpack('C*', $_[0]) ); + } + + + sub _decode_surrogates { # from http://homepage1.nifty.com/nomenclator/unicode/ucs_utf.htm + my $uni = 0x10000 + (hex($_[0]) - 0xD800) * 0x400 + (hex($_[1]) - 0xDC00); # from perlunicode + my $bit = unpack('B32', pack('N', $uni)); + + if ( $bit =~ /^00000000000(...)(......)(......)(......)$/ ) { + my ($w, $x, $y, $z) = ($1, $2, $3, $4); + return pack('B*', sprintf('11110%s10%s10%s10%s', $w, $x, $y, $z)); + } + else { + Carp::croak("Invalid surrogate pair"); + } + } + + + sub _decode_unicode { + my ($u) = @_; + my ($utf8bit); + + if ( $u =~ /^00([89a-f][0-9a-f])$/i ) { # 0x80-0xff + return pack( 'H2', $1 ); + } + + my $bit = unpack("B*", pack("H*", $u)); + + if ( $bit =~ /^00000(.....)(......)$/ ) { + $utf8bit = sprintf('110%s10%s', $1, $2); + } + elsif ( $bit =~ /^(....)(......)(......)$/ ) { + $utf8bit = sprintf('1110%s10%s10%s', $1, $2, $3); + } + else { + Carp::croak("Invalid escaped unicode"); + } + + return pack('B*', $utf8bit); + } + + + sub JSON::PP::incr_text { + $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new; + + if ( $_[0]->{_incr_parser}->{incr_parsing} ) { + Carp::croak("incr_text can not be called when the incremental parser already started parsing"); + } + + $_[0]->{_incr_parser}->{incr_text} = $_[1] if ( @_ > 1 ); + $_[0]->{_incr_parser}->{incr_text}; + } + + + 1; + __END__ + + =pod + + =head1 NAME + + JSON::PP5005 - Helper module in using JSON::PP in Perl 5.005 + + =head1 DESCRIPTION + + JSON::PP calls internally. + + =head1 AUTHOR + + Makamaka Hannyaharamitu, Emakamaka[at]cpan.orgE + + + =head1 COPYRIGHT AND LICENSE + + Copyright 2007-2012 by Makamaka Hannyaharamitu + + This library is free software; you can redistribute it and/or modify + it under the same terms as Perl itself. + + =cut + +JSON_BACKPORTPP_COMPAT5005 + +$fatpacked{"JSON/backportPP/Compat5006.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_BACKPORTPP_COMPAT5006'; + package # This is JSON::backportPP + JSON::backportPP56; + + use 5.006; + use strict; + + my @properties; + + $JSON::PP56::VERSION = '1.08'; + + BEGIN { + + sub utf8::is_utf8 { + my $len = length $_[0]; # char length + { + use bytes; # byte length; + return $len != length $_[0]; # if !=, UTF8-flagged on. + } + } + + + sub utf8::upgrade { + ; # noop; + } + + + sub utf8::downgrade ($;$) { + return 1 unless ( utf8::is_utf8( $_[0] ) ); + + if ( _is_valid_utf8( $_[0] ) ) { + my $downgrade; + for my $c ( unpack( "U*", $_[0] ) ) { + if ( $c < 256 ) { + $downgrade .= pack("C", $c); + } + else { + $downgrade .= pack("U", $c); + } + } + $_[0] = $downgrade; + return 1; + } + else { + Carp::croak("Wide character in subroutine entry") unless ( $_[1] ); + 0; + } + } + + + sub utf8::encode ($) { # UTF8 flag off + if ( utf8::is_utf8( $_[0] ) ) { + $_[0] = pack( "C*", unpack( "C*", $_[0] ) ); + } + else { + $_[0] = pack( "U*", unpack( "C*", $_[0] ) ); + $_[0] = pack( "C*", unpack( "C*", $_[0] ) ); + } + } + + + sub utf8::decode ($) { # UTF8 flag on + if ( _is_valid_utf8( $_[0] ) ) { + utf8::downgrade( $_[0] ); + $_[0] = pack( "U*", unpack( "U*", $_[0] ) ); + } + } + + + *JSON::PP::JSON_PP_encode_ascii = \&_encode_ascii; + *JSON::PP::JSON_PP_encode_latin1 = \&_encode_latin1; + *JSON::PP::JSON_PP_decode_surrogates = \&JSON::PP::_decode_surrogates; + *JSON::PP::JSON_PP_decode_unicode = \&JSON::PP::_decode_unicode; + + unless ( defined &B::SVp_NOK ) { # missing in B module. + eval q{ sub B::SVp_NOK () { 0x02000000; } }; + } + + } + + + + sub _encode_ascii { + join('', + map { + $_ <= 127 ? + chr($_) : + $_ <= 65535 ? + sprintf('\u%04x', $_) : sprintf('\u%x\u%x', JSON::PP::_encode_surrogates($_)); + } _unpack_emu($_[0]) + ); + } + + + sub _encode_latin1 { + join('', + map { + $_ <= 255 ? + chr($_) : + $_ <= 65535 ? + sprintf('\u%04x', $_) : sprintf('\u%x\u%x', JSON::PP::_encode_surrogates($_)); + } _unpack_emu($_[0]) + ); + } + + + sub _unpack_emu { # for Perl 5.6 unpack warnings + return !utf8::is_utf8($_[0]) ? unpack('C*', $_[0]) + : _is_valid_utf8($_[0]) ? unpack('U*', $_[0]) + : unpack('C*', $_[0]); + } + + + sub _is_valid_utf8 { + my $str = $_[0]; + my $is_utf8; + + while ($str =~ /(?: + ( + [\x00-\x7F] + |[\xC2-\xDF][\x80-\xBF] + |[\xE0][\xA0-\xBF][\x80-\xBF] + |[\xE1-\xEC][\x80-\xBF][\x80-\xBF] + |[\xED][\x80-\x9F][\x80-\xBF] + |[\xEE-\xEF][\x80-\xBF][\x80-\xBF] + |[\xF0][\x90-\xBF][\x80-\xBF][\x80-\xBF] + |[\xF1-\xF3][\x80-\xBF][\x80-\xBF][\x80-\xBF] + |[\xF4][\x80-\x8F][\x80-\xBF][\x80-\xBF] + ) + | (.) + )/xg) + { + if (defined $1) { + $is_utf8 = 1 if (!defined $is_utf8); + } + else { + $is_utf8 = 0 if (!defined $is_utf8); + if ($is_utf8) { # eventually, not utf8 + return; + } + } + } + + return $is_utf8; + } + + + 1; + __END__ + + =pod + + =head1 NAME + + JSON::PP56 - Helper module in using JSON::PP in Perl 5.6 + + =head1 DESCRIPTION + + JSON::PP calls internally. + + =head1 AUTHOR + + Makamaka Hannyaharamitu, Emakamaka[at]cpan.orgE + + + =head1 COPYRIGHT AND LICENSE + + Copyright 2007-2012 by Makamaka Hannyaharamitu + + This library is free software; you can redistribute it and/or modify + it under the same terms as Perl itself. + + =cut + +JSON_BACKPORTPP_COMPAT5006 + +$fatpacked{"Module/CPANfile.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE'; + package Module::CPANfile; + use strict; + use warnings; + use Cwd; + use Carp (); + use Module::CPANfile::Environment; + use Module::CPANfile::Requirement; + + our $VERSION = '1.1000'; + + sub new { + my($class, $file) = @_; + bless {}, $class; + } + + sub load { + my($proto, $file) = @_; + + my $self = ref $proto ? $proto : $proto->new; + $self->parse($file || Cwd::abs_path('cpanfile')); + $self; + } + + sub save { + my($self, $path) = @_; + + open my $out, ">", $path or die "$path: $!"; + print {$out} $self->to_string; + } + + sub parse { + my($self, $file) = @_; + + my $code = do { + open my $fh, "<", $file or die "$file: $!"; + join '', <$fh>; + }; + + my $env = Module::CPANfile::Environment->new($file); + $env->parse($code) or die $@; + + $self->{_mirrors} = $env->mirrors; + $self->{_prereqs} = $env->prereqs; + } + + sub from_prereqs { + my($proto, $prereqs) = @_; + + my $self = $proto->new; + $self->{_prereqs} = Module::CPANfile::Prereqs->from_cpan_meta($prereqs); + + $self; + } + + sub mirrors { + my $self = shift; + $self->{_mirrors} || []; + } + + sub features { + my $self = shift; + map $self->feature($_), $self->{_prereqs}->identifiers; + } + + sub feature { + my($self, $identifier) = @_; + $self->{_prereqs}->feature($identifier); + } + + sub prereq { shift->prereqs } + + sub prereqs { + my $self = shift; + $self->{_prereqs}->as_cpan_meta; + } + + sub merged_requirements { + my $self = shift; + $self->{_prereqs}->merged_requirements; + } + + sub effective_prereqs { + my($self, $features) = @_; + $self->prereqs_with(@{$features || []}); + } + + sub prereqs_with { + my($self, @feature_identifiers) = @_; + + my $prereqs = $self->prereqs; + my @others = map { $self->feature($_)->prereqs } @feature_identifiers; + + $prereqs->with_merged_prereqs(\@others); + } + + sub prereq_specs { + my $self = shift; + $self->prereqs->as_string_hash; + } + + sub prereq_for_module { + my($self, $module) = @_; + $self->{_prereqs}->find($module); + } + + sub options_for_module { + my($self, $module) = @_; + my $prereq = $self->prereq_for_module($module) or return; + $prereq->requirement->options; + } + + sub merge_meta { + my($self, $file, $version) = @_; + + require CPAN::Meta; + + $version ||= $file =~ /\.yml$/ ? '1.4' : '2'; + + my $prereq = $self->prereqs; + + my $meta = CPAN::Meta->load_file($file); + my $prereqs_hash = $prereq->with_merged_prereqs($meta->effective_prereqs)->as_string_hash; + my $struct = { %{$meta->as_struct}, prereqs => $prereqs_hash }; + + CPAN::Meta->new($struct)->save($file, { version => $version }); + } + + sub _dump { + my $str = shift; + require Data::Dumper; + chomp(my $value = Data::Dumper->new([$str])->Terse(1)->Dump); + $value; + } + + sub to_string { + my($self, $include_empty) = @_; + + my $mirrors = $self->mirrors; + my $prereqs = $self->prereq_specs; + + my $code = ''; + $code .= $self->_dump_mirrors($mirrors); + $code .= $self->_dump_prereqs($prereqs, $include_empty); + + for my $feature ($self->features) { + $code .= sprintf "feature %s, %s => sub {\n", _dump($feature->{identifier}), _dump($feature->{description}); + $code .= $self->_dump_prereqs($feature->{spec}, $include_empty, 4); + $code .= "}\n\n"; + } + + $code =~ s/\n+$/\n/s; + $code; + } + + sub _dump_mirrors { + my($self, $mirrors) = @_; + + my $code = ""; + + for my $url (@$mirrors) { + $code .= "mirror '$url';\n"; + } + + $code =~ s/\n+$/\n/s; + $code; + } + + sub _dump_prereqs { + my($self, $prereqs, $include_empty, $base_indent) = @_; + + my $code = ''; + for my $phase (qw(runtime configure build test develop)) { + my $indent = $phase eq 'runtime' ? '' : ' '; + $indent = (' ' x ($base_indent || 0)) . $indent; + + my($phase_code, $requirements); + $phase_code .= "on $phase => sub {\n" unless $phase eq 'runtime'; + + for my $type (qw(requires recommends suggests conflicts)) { + for my $mod (sort keys %{$prereqs->{$phase}{$type}}) { + my $ver = $prereqs->{$phase}{$type}{$mod}; + $phase_code .= $ver eq '0' + ? "${indent}$type '$mod';\n" + : "${indent}$type '$mod', '$ver';\n"; + $requirements++; + } + } + + $phase_code .= "\n" unless $requirements; + $phase_code .= "};\n" unless $phase eq 'runtime'; + + $code .= $phase_code . "\n" if $requirements or $include_empty; + } + + $code =~ s/\n+$/\n/s; + $code; + } + + 1; + + __END__ + + =head1 NAME + + Module::CPANfile - Parse cpanfile + + =head1 SYNOPSIS + + use Module::CPANfile; + + my $file = Module::CPANfile->load("cpanfile"); + my $prereqs = $file->prereqs; # CPAN::Meta::Prereqs object + + my @features = $file->features; # CPAN::Meta::Feature objects + my $merged_prereqs = $file->prereqs_with(@identifiers); # CPAN::Meta::Prereqs + + $file->merge_meta('MYMETA.json'); + + =head1 DESCRIPTION + + Module::CPANfile is a tool to handle L format to load application + specific dependencies, not just for CPAN distributions. + + =head1 METHODS + + =over 4 + + =item load + + $file = Module::CPANfile->load; + $file = Module::CPANfile->load('cpanfile'); + + Load and parse a cpanfile. By default it tries to load C in + the current directory, unless you pass the path to its argument. + + =item from_prereqs + + $file = Module::CPANfile->from_prereqs({ + runtime => { requires => { DBI => '1.000' } }, + }); + + Creates a new Module::CPANfile object from prereqs hash you can get + via L's C, or L' + C. + + # read MYMETA, then feed the prereqs to create Module::CPANfile + my $meta = CPAN::Meta->load_file('MYMETA.json'); + my $file = Module::CPANfile->from_prereqs($meta->prereqs); + + # load cpanfile, then recreate it with round-trip + my $file = Module::CPANfile->load('cpanfile'); + $file = Module::CPANfile->from_prereqs($file->prereq_specs); + # or $file->prereqs->as_string_hash + + =item prereqs + + Returns L object out of the parsed cpanfile. + + =item prereq_specs + + Returns a hash reference that should be passed to C<< CPAN::Meta::Prereqs->new >>. + + =item features + + Returns a list of features available in the cpanfile as L. + + =item prereqs_with(@identifiers), effective_prereqs(\@identifiers) + + Returns L object, with merged prereqs for + features identified with the C<@identifiers>. + + =item to_string($include_empty) + + $file->to_string; + $file->to_string(1); + + Returns a canonical string (code) representation for cpanfile. Useful + if you want to convert L to a new cpanfile. + + # read MYMETA's prereqs and print cpanfile representation of it + my $meta = CPAN::Meta->load_file('MYMETA.json'); + my $file = Module::CPANfile->from_prereqs($meta->prereqs); + print $file->to_string; + + By default, it omits the phase where there're no modules + registered. If you pass the argument of a true value, it will print + them as well. + + =item save + + $file->save('cpanfile'); + + Saves the currently loaded prereqs as a new C by calling + C. Beware B. Taking a backup or giving + warnings to users is a caller's responsibility. + + # Read MYMETA.json and creates a new cpanfile + my $meta = CPAN::Meta->load_file('MYMETA.json'); + my $file = Module::CPANfile->from_prereqs($meta->prereqs); + $file->save('cpanfile'); + + =item merge_meta + + $file->merge_meta('META.yml'); + $file->merge_meta('MYMETA.json', '2.0'); + + Merge the effective prereqs with Meta specification loaded from the + given META file, using CPAN::Meta. You can specify the META spec + version in the second argument, which defaults to 1.4 in case the + given file is YAML, and 2 if it is JSON. + + =back + + =head1 AUTHOR + + Tatsuhiko Miyagawa + + =head1 SEE ALSO + + L, L, L + + =cut +MODULE_CPANFILE + +$fatpacked{"Module/CPANfile/Environment.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_ENVIRONMENT'; + package Module::CPANfile::Environment; + use strict; + use warnings; + use Module::CPANfile::Prereqs; + use Carp (); + + my @bindings = qw( + on requires recommends suggests conflicts + feature + osname + mirror + configure_requires build_requires test_requires author_requires + ); + + my $file_id = 1; + + sub new { + my($class, $file) = @_; + bless { + file => $file, + phase => 'runtime', # default phase + feature => undef, + features => {}, + prereqs => Module::CPANfile::Prereqs->new, + mirrors => [], + }, $class; + } + + sub bind { + my $self = shift; + my $pkg = caller; + + for my $binding (@bindings) { + no strict 'refs'; + *{"$pkg\::$binding"} = sub { $self->$binding(@_) }; + } + } + + sub parse { + my($self, $code) = @_; + + my $err; + { + local $@; + $file_id++; + $self->_evaluate(<bind } + + # line 1 "$self->{file}" + $code; + EVAL + $err = $@; + } + + if ($err) { die "Parsing $self->{file} failed: $err" }; + + return 1; + } + + sub _evaluate { + my $_environment = $_[0]; + eval $_[1]; + } + + sub prereqs { $_[0]->{prereqs} } + + sub mirrors { $_[0]->{mirrors} } + + # DSL goes from here + + sub on { + my($self, $phase, $code) = @_; + local $self->{phase} = $phase; + $code->(); + } + + sub feature { + my($self, $identifier, $description, $code) = @_; + + # shortcut: feature identifier => sub { ... } + if (@_ == 3 && ref($description) eq 'CODE') { + $code = $description; + $description = $identifier; + } + + unless (ref $description eq '' && ref $code eq 'CODE') { + Carp::croak("Usage: feature 'identifier', 'Description' => sub { ... }"); + } + + local $self->{feature} = $identifier; + $self->prereqs->add_feature($identifier, $description); + + $code->(); + } + + sub osname { die "TODO" } + + sub mirror { + my($self, $url) = @_; + push @{$self->{mirrors}}, $url; + } + + sub requirement_for { + my($self, $module, @args) = @_; + + my $requirement = 0; + $requirement = shift @args if @args % 2; + + return Module::CPANfile::Requirement->new( + name => $module, + version => $requirement, + @args, + ); + } + + sub requires { + my $self = shift; + $self->add_prereq(requires => @_); + } + + sub recommends { + my $self = shift; + $self->add_prereq(recommends => @_); + } + + sub suggests { + my $self = shift; + $self->add_prereq(suggests => @_); + } + + sub conflicts { + my $self = shift; + $self->add_prereq(conflicts => @_); + } + + sub add_prereq { + my($self, $type, $module, @args) = @_; + + $self->prereqs->add_prereq( + feature => $self->{feature}, + phase => $self->{phase}, + type => $type, + module => $module, + requirement => $self->requirement_for($module, @args), + ); + } + + # Module::Install compatible shortcuts + + sub configure_requires { + my($self, @args) = @_; + $self->on(configure => sub { $self->requires(@args) }); + } + + sub build_requires { + my($self, @args) = @_; + $self->on(build => sub { $self->requires(@args) }); + } + + sub test_requires { + my($self, @args) = @_; + $self->on(test => sub { $self->requires(@args) }); + } + + sub author_requires { + my($self, @args) = @_; + $self->on(develop => sub { $self->requires(@args) }); + } + + 1; + +MODULE_CPANFILE_ENVIRONMENT + +$fatpacked{"Module/CPANfile/Prereq.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_PREREQ'; + package Module::CPANfile::Prereq; + use strict; + + sub new { + my($class, %options) = @_; + bless \%options, $class; + } + + sub feature { $_[0]->{feature} } + sub phase { $_[0]->{phase} } + sub type { $_[0]->{type} } + sub module { $_[0]->{module} } + sub requirement { $_[0]->{requirement} } + + sub match_feature { + my($self, $identifier) = @_; + no warnings 'uninitialized'; + $self->feature eq $identifier; + } + + 1; +MODULE_CPANFILE_PREREQ + +$fatpacked{"Module/CPANfile/Prereqs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_PREREQS'; + package Module::CPANfile::Prereqs; + use strict; + use Carp (); + use CPAN::Meta::Feature; + use Module::CPANfile::Prereq; + + sub from_cpan_meta { + my($class, $prereqs) = @_; + + my $self = $class->new; + + for my $phase (keys %$prereqs) { + for my $type (keys %{ $prereqs->{$phase} }) { + while (my($module, $requirement) = each %{ $prereqs->{$phase}{$type} }) { + $self->add_prereq( + phase => $phase, + type => $type, + module => $module, + requirement => Module::CPANfile::Requirement->new(name => $module, version => $requirement), + ); + } + } + } + + $self; + } + + sub new { + my $class = shift; + bless { + prereqs => [], + features => {}, + }, $class; + } + + sub add_feature { + my($self, $identifier, $description) = @_; + $self->{features}{$identifier} = { description => $description }; + } + + sub add_prereq { + my($self, %args) = @_; + $self->add( Module::CPANfile::Prereq->new(%args) ); + } + + sub add { + my($self, $prereq) = @_; + push @{$self->{prereqs}}, $prereq; + } + + sub as_cpan_meta { + my $self = shift; + $self->{cpanmeta} ||= $self->build_cpan_meta; + } + + sub build_cpan_meta { + my($self, $identifier) = @_; + + my $prereq_spec = {}; + $self->prereq_each($identifier, sub { + my $prereq = shift; + $prereq_spec->{$prereq->phase}{$prereq->type}{$prereq->module} = $prereq->requirement->version; + }); + + CPAN::Meta::Prereqs->new($prereq_spec); + } + + sub prereq_each { + my($self, $identifier, $code) = @_; + + for my $prereq (@{$self->{prereqs}}) { + next unless $prereq->match_feature($identifier); + $code->($prereq); + } + } + + sub merged_requirements { + my $self = shift; + + my $reqs = CPAN::Meta::Requirements->new; + for my $prereq (@{$self->{prereqs}}) { + $reqs->add_string_requirement($prereq->module, $prereq->requirement->version); + } + + $reqs; + } + + sub find { + my($self, $module) = @_; + + for my $prereq (@{$self->{prereqs}}) { + return $prereq if $prereq->module eq $module; + } + + return; + } + + sub identifiers { + my $self = shift; + keys %{$self->{features}}; + } + + sub feature { + my($self, $identifier) = @_; + + my $data = $self->{features}{$identifier} + or Carp::croak("Unknown feature '$identifier'"); + + my $prereqs = $self->build_cpan_meta($identifier); + + CPAN::Meta::Feature->new($identifier, { + description => $data->{description}, + prereqs => $prereqs->as_string_hash, + }); + } + + 1; +MODULE_CPANFILE_PREREQS + +$fatpacked{"Module/CPANfile/Requirement.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_REQUIREMENT'; + package Module::CPANfile::Requirement; + use strict; + + sub new { + my ($class, %args) = @_; + + $args{version} ||= 0; + + bless +{ + name => delete $args{name}, + version => delete $args{version}, + options => \%args, + }, $class; + } + + sub name { $_[0]->{name} } + sub version { $_[0]->{version} } + + sub options { $_[0]->{options} } + + sub has_options { + keys %{$_[0]->{options}} > 0; + } + + 1; +MODULE_CPANFILE_REQUIREMENT + +$fatpacked{"Module/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_METADATA'; + # -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*- + # vim:ts=8:sw=2:et:sta:sts=2 + package Module::Metadata; # git description: v1.000026-12-g9b12bf1 + + # Adapted from Perl-licensed code originally distributed with + # Module-Build by Ken Williams + + # This module provides routines to gather information about + # perl modules (assuming this may be expanded in the distant + # parrot future to look at other types of modules). + + sub __clean_eval { eval $_[0] } + use strict; + use warnings; + + our $VERSION = '1.000027'; + + use Carp qw/croak/; + use File::Spec; + BEGIN { + # Try really hard to not depend ony any DynaLoaded module, such as IO::File or Fcntl + eval { + require Fcntl; Fcntl->import('SEEK_SET'); 1; + } or *SEEK_SET = sub { 0 } + } + use version 0.87; + BEGIN { + if ($INC{'Log/Contextual.pm'}) { + require "Log/Contextual/WarnLogger.pm"; # Hide from AutoPrereqs + Log::Contextual->import('log_info', + '-default_logger' => Log::Contextual::WarnLogger->new({ env_prefix => 'MODULE_METADATA', }), + ); + } else { + *log_info = sub (&) { warn $_[0]->() }; + } + } + use File::Find qw(find); + + my $V_NUM_REGEXP = qr{v?[0-9._]+}; # crudely, a v-string or decimal + + my $PKG_FIRST_WORD_REGEXP = qr{ # the FIRST word in a package name + [a-zA-Z_] # the first word CANNOT start with a digit + (?: + [\w']? # can contain letters, digits, _, or ticks + \w # But, NO multi-ticks or trailing ticks + )* + }x; + + my $PKG_ADDL_WORD_REGEXP = qr{ # the 2nd+ word in a package name + \w # the 2nd+ word CAN start with digits + (?: + [\w']? # and can contain letters or ticks + \w # But, NO multi-ticks or trailing ticks + )* + }x; + + my $PKG_NAME_REGEXP = qr{ # match a package name + (?: :: )? # a pkg name can start with arisdottle + $PKG_FIRST_WORD_REGEXP # a package word + (?: + (?: :: )+ ### arisdottle (allow one or many times) + $PKG_ADDL_WORD_REGEXP ### a package word + )* # ^ zero, one or many times + (?: + :: # allow trailing arisdottle + )? + }x; + + my $PKG_REGEXP = qr{ # match a package declaration + ^[\s\{;]* # intro chars on a line + package # the word 'package' + \s+ # whitespace + ($PKG_NAME_REGEXP) # a package name + \s* # optional whitespace + ($V_NUM_REGEXP)? # optional version number + \s* # optional whitesapce + [;\{] # semicolon line terminator or block start (since 5.16) + }x; + + my $VARNAME_REGEXP = qr{ # match fully-qualified VERSION name + ([\$*]) # sigil - $ or * + ( + ( # optional leading package name + (?:::|\')? # possibly starting like just :: (a la $::VERSION) + (?:\w+(?:::|\'))* # Foo::Bar:: ... + )? + VERSION + )\b + }x; + + my $VERS_REGEXP = qr{ # match a VERSION definition + (?: + \(\s*$VARNAME_REGEXP\s*\) # with parens + | + $VARNAME_REGEXP # without parens + ) + \s* + =[^=~>] # = but not ==, nor =~, nor => + }x; + + sub new_from_file { + my $class = shift; + my $filename = File::Spec->rel2abs( shift ); + + return undef unless defined( $filename ) && -f $filename; + return $class->_init(undef, $filename, @_); + } + + sub new_from_handle { + my $class = shift; + my $handle = shift; + my $filename = shift; + return undef unless defined($handle) && defined($filename); + $filename = File::Spec->rel2abs( $filename ); + + return $class->_init(undef, $filename, @_, handle => $handle); + + } + + + sub new_from_module { + my $class = shift; + my $module = shift; + my %props = @_; + + $props{inc} ||= \@INC; + my $filename = $class->find_module_by_name( $module, $props{inc} ); + return undef unless defined( $filename ) && -f $filename; + return $class->_init($module, $filename, %props); + } + + { + + my $compare_versions = sub { + my ($v1, $op, $v2) = @_; + $v1 = version->new($v1) + unless UNIVERSAL::isa($v1,'version'); + + my $eval_str = "\$v1 $op \$v2"; + my $result = eval $eval_str; + log_info { "error comparing versions: '$eval_str' $@" } if $@; + + return $result; + }; + + my $normalize_version = sub { + my ($version) = @_; + if ( $version =~ /[=<>!,]/ ) { # logic, not just version + # take as is without modification + } + elsif ( ref $version eq 'version' ) { # version objects + $version = $version->is_qv ? $version->normal : $version->stringify; + } + elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots + # normalize string tuples without "v": "1.2.3" -> "v1.2.3" + $version = "v$version"; + } + else { + # leave alone + } + return $version; + }; + + # separate out some of the conflict resolution logic + + my $resolve_module_versions = sub { + my $packages = shift; + + my( $file, $version ); + my $err = ''; + foreach my $p ( @$packages ) { + if ( defined( $p->{version} ) ) { + if ( defined( $version ) ) { + if ( $compare_versions->( $version, '!=', $p->{version} ) ) { + $err .= " $p->{file} ($p->{version})\n"; + } else { + # same version declared multiple times, ignore + } + } else { + $file = $p->{file}; + $version = $p->{version}; + } + } + $file ||= $p->{file} if defined( $p->{file} ); + } + + if ( $err ) { + $err = " $file ($version)\n" . $err; + } + + my %result = ( + file => $file, + version => $version, + err => $err + ); + + return \%result; + }; + + sub provides { + my $class = shift; + + croak "provides() requires key/value pairs \n" if @_ % 2; + my %args = @_; + + croak "provides() takes only one of 'dir' or 'files'\n" + if $args{dir} && $args{files}; + + croak "provides() requires a 'version' argument" + unless defined $args{version}; + + croak "provides() does not support version '$args{version}' metadata" + unless grep { $args{version} eq $_ } qw/1.4 2/; + + $args{prefix} = 'lib' unless defined $args{prefix}; + + my $p; + if ( $args{dir} ) { + $p = $class->package_versions_from_directory($args{dir}); + } + else { + croak "provides() requires 'files' to be an array reference\n" + unless ref $args{files} eq 'ARRAY'; + $p = $class->package_versions_from_directory($args{files}); + } + + # Now, fix up files with prefix + if ( length $args{prefix} ) { # check in case disabled with q{} + $args{prefix} =~ s{/$}{}; + for my $v ( values %$p ) { + $v->{file} = "$args{prefix}/$v->{file}"; + } + } + + return $p + } + + sub package_versions_from_directory { + my ( $class, $dir, $files ) = @_; + + my @files; + + if ( $files ) { + @files = @$files; + } else { + find( { + wanted => sub { + push @files, $_ if -f $_ && /\.pm$/; + }, + no_chdir => 1, + }, $dir ); + } + + # First, we enumerate all packages & versions, + # separating into primary & alternative candidates + my( %prime, %alt ); + foreach my $file (@files) { + my $mapped_filename = File::Spec::Unix->abs2rel( $file, $dir ); + my @path = split( /\//, $mapped_filename ); + (my $prime_package = join( '::', @path )) =~ s/\.pm$//; + + my $pm_info = $class->new_from_file( $file ); + + foreach my $package ( $pm_info->packages_inside ) { + next if $package eq 'main'; # main can appear numerous times, ignore + next if $package eq 'DB'; # special debugging package, ignore + next if grep /^_/, split( /::/, $package ); # private package, ignore + + my $version = $pm_info->version( $package ); + + $prime_package = $package if lc($prime_package) eq lc($package); + if ( $package eq $prime_package ) { + if ( exists( $prime{$package} ) ) { + croak "Unexpected conflict in '$package'; multiple versions found.\n"; + } else { + $mapped_filename = "$package.pm" if lc("$package.pm") eq lc($mapped_filename); + $prime{$package}{file} = $mapped_filename; + $prime{$package}{version} = $version if defined( $version ); + } + } else { + push( @{$alt{$package}}, { + file => $mapped_filename, + version => $version, + } ); + } + } + } + + # Then we iterate over all the packages found above, identifying conflicts + # and selecting the "best" candidate for recording the file & version + # for each package. + foreach my $package ( keys( %alt ) ) { + my $result = $resolve_module_versions->( $alt{$package} ); + + if ( exists( $prime{$package} ) ) { # primary package selected + + if ( $result->{err} ) { + # Use the selected primary package, but there are conflicting + # errors among multiple alternative packages that need to be + # reported + log_info { + "Found conflicting versions for package '$package'\n" . + " $prime{$package}{file} ($prime{$package}{version})\n" . + $result->{err} + }; + + } elsif ( defined( $result->{version} ) ) { + # There is a primary package selected, and exactly one + # alternative package + + if ( exists( $prime{$package}{version} ) && + defined( $prime{$package}{version} ) ) { + # Unless the version of the primary package agrees with the + # version of the alternative package, report a conflict + if ( $compare_versions->( + $prime{$package}{version}, '!=', $result->{version} + ) + ) { + + log_info { + "Found conflicting versions for package '$package'\n" . + " $prime{$package}{file} ($prime{$package}{version})\n" . + " $result->{file} ($result->{version})\n" + }; + } + + } else { + # The prime package selected has no version so, we choose to + # use any alternative package that does have a version + $prime{$package}{file} = $result->{file}; + $prime{$package}{version} = $result->{version}; + } + + } else { + # no alt package found with a version, but we have a prime + # package so we use it whether it has a version or not + } + + } else { # No primary package was selected, use the best alternative + + if ( $result->{err} ) { + log_info { + "Found conflicting versions for package '$package'\n" . + $result->{err} + }; + } + + # Despite possible conflicting versions, we choose to record + # something rather than nothing + $prime{$package}{file} = $result->{file}; + $prime{$package}{version} = $result->{version} + if defined( $result->{version} ); + } + } + + # Normalize versions. Can't use exists() here because of bug in YAML::Node. + # XXX "bug in YAML::Node" comment seems irrelevant -- dagolden, 2009-05-18 + for (grep defined $_->{version}, values %prime) { + $_->{version} = $normalize_version->( $_->{version} ); + } + + return \%prime; + } + } + + + sub _init { + my $class = shift; + my $module = shift; + my $filename = shift; + my %props = @_; + + my $handle = delete $props{handle}; + my( %valid_props, @valid_props ); + @valid_props = qw( collect_pod inc ); + @valid_props{@valid_props} = delete( @props{@valid_props} ); + warn "Unknown properties: @{[keys %props]}\n" if scalar( %props ); + + my %data = ( + module => $module, + filename => $filename, + version => undef, + packages => [], + versions => {}, + pod => {}, + pod_headings => [], + collect_pod => 0, + + %valid_props, + ); + + my $self = bless(\%data, $class); + + if ( not $handle ) { + my $filename = $self->{filename}; + open $handle, '<', $filename + or croak( "Can't open '$filename': $!" ); + + $self->_handle_bom($handle, $filename); + } + $self->_parse_fh($handle); + + unless($self->{module} and length($self->{module})) { + my ($v, $d, $f) = File::Spec->splitpath($self->{filename}); + if($f =~ /\.pm$/) { + $f =~ s/\..+$//; + my @candidates = grep /$f$/, @{$self->{packages}}; + $self->{module} = shift(@candidates); # punt + } + else { + if(grep /main/, @{$self->{packages}}) { + $self->{module} = 'main'; + } + else { + $self->{module} = $self->{packages}[0] || ''; + } + } + } + + $self->{version} = $self->{versions}{$self->{module}} + if defined( $self->{module} ); + + return $self; + } + + # class method + sub _do_find_module { + my $class = shift; + my $module = shift || croak 'find_module_by_name() requires a package name'; + my $dirs = shift || \@INC; + + my $file = File::Spec->catfile(split( /::/, $module)); + foreach my $dir ( @$dirs ) { + my $testfile = File::Spec->catfile($dir, $file); + return [ File::Spec->rel2abs( $testfile ), $dir ] + if -e $testfile and !-d _; # For stuff like ExtUtils::xsubpp + $testfile .= '.pm'; + return [ File::Spec->rel2abs( $testfile ), $dir ] + if -e $testfile; + } + return; + } + + # class method + sub find_module_by_name { + my $found = shift()->_do_find_module(@_) or return; + return $found->[0]; + } + + # class method + sub find_module_dir_by_name { + my $found = shift()->_do_find_module(@_) or return; + return $found->[1]; + } + + + # given a line of perl code, attempt to parse it if it looks like a + # $VERSION assignment, returning sigil, full name, & package name + sub _parse_version_expression { + my $self = shift; + my $line = shift; + + my( $sigil, $variable_name, $package); + if ( $line =~ /$VERS_REGEXP/o ) { + ( $sigil, $variable_name, $package) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 ); + if ( $package ) { + $package = ($package eq '::') ? 'main' : $package; + $package =~ s/::$//; + } + } + + return ( $sigil, $variable_name, $package ); + } + + # Look for a UTF-8/UTF-16BE/UTF-16LE BOM at the beginning of the stream. + # If there's one, then skip it and set the :encoding layer appropriately. + sub _handle_bom { + my ($self, $fh, $filename) = @_; + + my $pos = tell $fh; + return unless defined $pos; + + my $buf = ' ' x 2; + my $count = read $fh, $buf, length $buf; + return unless defined $count and $count >= 2; + + my $encoding; + if ( $buf eq "\x{FE}\x{FF}" ) { + $encoding = 'UTF-16BE'; + } elsif ( $buf eq "\x{FF}\x{FE}" ) { + $encoding = 'UTF-16LE'; + } elsif ( $buf eq "\x{EF}\x{BB}" ) { + $buf = ' '; + $count = read $fh, $buf, length $buf; + if ( defined $count and $count >= 1 and $buf eq "\x{BF}" ) { + $encoding = 'UTF-8'; + } + } + + if ( defined $encoding ) { + if ( "$]" >= 5.008 ) { + binmode( $fh, ":encoding($encoding)" ); + } + } else { + seek $fh, $pos, SEEK_SET + or croak( sprintf "Can't reset position to the top of '$filename'" ); + } + + return $encoding; + } + + sub _parse_fh { + my ($self, $fh) = @_; + + my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 ); + my( @packages, %vers, %pod, @pod ); + my $package = 'main'; + my $pod_sect = ''; + my $pod_data = ''; + my $in_end = 0; + + while (defined( my $line = <$fh> )) { + my $line_num = $.; + + chomp( $line ); + + # From toke.c : any line that begins by "=X", where X is an alphabetic + # character, introduces a POD segment. + my $is_cut; + if ( $line =~ /^=([a-zA-Z].*)/ ) { + my $cmd = $1; + # Then it goes back to Perl code for "=cutX" where X is a non-alphabetic + # character (which includes the newline, but here we chomped it away). + $is_cut = $cmd =~ /^cut(?:[^a-zA-Z]|$)/; + $in_pod = !$is_cut; + } + + if ( $in_pod ) { + + if ( $line =~ /^=head[1-4]\s+(.+)\s*$/ ) { + push( @pod, $1 ); + if ( $self->{collect_pod} && length( $pod_data ) ) { + $pod{$pod_sect} = $pod_data; + $pod_data = ''; + } + $pod_sect = $1; + + } elsif ( $self->{collect_pod} ) { + $pod_data .= "$line\n"; + + } + + } elsif ( $is_cut ) { + + if ( $self->{collect_pod} && length( $pod_data ) ) { + $pod{$pod_sect} = $pod_data; + $pod_data = ''; + } + $pod_sect = ''; + + } else { + + # Skip after __END__ + next if $in_end; + + # Skip comments in code + next if $line =~ /^\s*#/; + + # Would be nice if we could also check $in_string or something too + if ($line eq '__END__') { + $in_end++; + next; + } + last if $line eq '__DATA__'; + + # parse $line to see if it's a $VERSION declaration + my( $version_sigil, $version_fullname, $version_package ) = + index($line, 'VERSION') >= 1 + ? $self->_parse_version_expression( $line ) + : (); + + if ( $line =~ /$PKG_REGEXP/o ) { + $package = $1; + my $version = $2; + push( @packages, $package ) unless grep( $package eq $_, @packages ); + $need_vers = defined $version ? 0 : 1; + + if ( not exists $vers{$package} and defined $version ){ + # Upgrade to a version object. + my $dwim_version = eval { _dwim_version($version) }; + croak "Version '$version' from $self->{filename} does not appear to be valid:\n$line\n\nThe fatal error was: $@\n" + unless defined $dwim_version; # "0" is OK! + $vers{$package} = $dwim_version; + } + + # VERSION defined with full package spec, i.e. $Module::VERSION + } elsif ( $version_fullname && $version_package ) { + push( @packages, $version_package ) unless grep( $version_package eq $_, @packages ); + $need_vers = 0 if $version_package eq $package; + + unless ( defined $vers{$version_package} && length $vers{$version_package} ) { + $vers{$version_package} = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line ); + } + + # first non-comment line in undeclared package main is VERSION + } elsif ( $package eq 'main' && $version_fullname && !exists($vers{main}) ) { + $need_vers = 0; + my $v = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line ); + $vers{$package} = $v; + push( @packages, 'main' ); + + # first non-comment line in undeclared package defines package main + } elsif ( $package eq 'main' && !exists($vers{main}) && $line =~ /\w/ ) { + $need_vers = 1; + $vers{main} = ''; + push( @packages, 'main' ); + + # only keep if this is the first $VERSION seen + } elsif ( $version_fullname && $need_vers ) { + $need_vers = 0; + my $v = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line ); + + unless ( defined $vers{$package} && length $vers{$package} ) { + $vers{$package} = $v; + } + } + } + } + + if ( $self->{collect_pod} && length($pod_data) ) { + $pod{$pod_sect} = $pod_data; + } + + $self->{versions} = \%vers; + $self->{packages} = \@packages; + $self->{pod} = \%pod; + $self->{pod_headings} = \@pod; + } + + { + my $pn = 0; + sub _evaluate_version_line { + my $self = shift; + my( $sigil, $variable_name, $line ) = @_; + + # We compile into a local sub because 'use version' would cause + # compiletime/runtime issues with local() + $pn++; # everybody gets their own package + my $eval = qq{ my \$dummy = q# Hide from _packages_inside() + #; package Module::Metadata::_version::p${pn}; + use version; + sub { + local $sigil$variable_name; + $line; + \$$variable_name + }; + }; + + $eval = $1 if $eval =~ m{^(.+)}s; + + local $^W; + # Try to get the $VERSION + my $vsub = __clean_eval($eval); + # some modules say $VERSION $Foo::Bar::VERSION, but Foo::Bar isn't + # installed, so we need to hunt in ./lib for it + if ( $@ =~ /Can't locate/ && -d 'lib' ) { + local @INC = ('lib',@INC); + $vsub = __clean_eval($eval); + } + warn "Error evaling version line '$eval' in $self->{filename}: $@\n" + if $@; + + (ref($vsub) eq 'CODE') or + croak "failed to build version sub for $self->{filename}"; + + my $result = eval { $vsub->() }; + # FIXME: $eval is not the right thing to print here + croak "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n" + if $@; + + # Upgrade it into a version object + my $version = eval { _dwim_version($result) }; + + # FIXME: $eval is not the right thing to print here + croak "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n" + unless defined $version; # "0" is OK! + + return $version; + } + } + + # Try to DWIM when things fail the lax version test in obvious ways + { + my @version_prep = ( + # Best case, it just works + sub { return shift }, + + # If we still don't have a version, try stripping any + # trailing junk that is prohibited by lax rules + sub { + my $v = shift; + $v =~ s{([0-9])[a-z-].*$}{$1}i; # 1.23-alpha or 1.23b + return $v; + }, + + # Activestate apparently creates custom versions like '1.23_45_01', which + # cause version.pm to think it's an invalid alpha. So check for that + # and strip them + sub { + my $v = shift; + my $num_dots = () = $v =~ m{(\.)}g; + my $num_unders = () = $v =~ m{(_)}g; + my $leading_v = substr($v,0,1) eq 'v'; + if ( ! $leading_v && $num_dots < 2 && $num_unders > 1 ) { + $v =~ s{_}{}g; + $num_unders = () = $v =~ m{(_)}g; + } + return $v; + }, + + # Worst case, try numifying it like we would have before version objects + sub { + my $v = shift; + no warnings 'numeric'; + return 0 + $v; + }, + + ); + + sub _dwim_version { + my ($result) = shift; + + return $result if ref($result) eq 'version'; + + my ($version, $error); + for my $f (@version_prep) { + $result = $f->($result); + $version = eval { version->new($result) }; + $error ||= $@ if $@; # capture first failure + last if defined $version; + } + + croak $error unless defined $version; + + return $version; + } + } + + ############################################################ + + # accessors + sub name { $_[0]->{module} } + + sub filename { $_[0]->{filename} } + sub packages_inside { @{$_[0]->{packages}} } + sub pod_inside { @{$_[0]->{pod_headings}} } + sub contains_pod { 0+@{$_[0]->{pod_headings}} } + + sub version { + my $self = shift; + my $mod = shift || $self->{module}; + my $vers; + if ( defined( $mod ) && length( $mod ) && + exists( $self->{versions}{$mod} ) ) { + return $self->{versions}{$mod}; + } else { + return undef; + } + } + + sub pod { + my $self = shift; + my $sect = shift; + if ( defined( $sect ) && length( $sect ) && + exists( $self->{pod}{$sect} ) ) { + return $self->{pod}{$sect}; + } else { + return undef; + } + } + + sub is_indexable { + my ($self, $package) = @_; + + my @indexable_packages = grep { $_ ne 'main' } $self->packages_inside; + + # check for specific package, if provided + return !! grep { $_ eq $package } @indexable_packages if $package; + + # otherwise, check for any indexable packages at all + return !! @indexable_packages; + } + + 1; + + =head1 NAME + + Module::Metadata - Gather package and POD information from perl module files + + =head1 SYNOPSIS + + use Module::Metadata; + + # information about a .pm file + my $info = Module::Metadata->new_from_file( $file ); + my $version = $info->version; + + # CPAN META 'provides' field for .pm files in a directory + my $provides = Module::Metadata->provides( + dir => 'lib', version => 2 + ); + + =head1 DESCRIPTION + + This module provides a standard way to gather metadata about a .pm file through + (mostly) static analysis and (some) code execution. When determining the + version of a module, the C<$VERSION> assignment is Ced, as is traditional + in the CPAN toolchain. + + =head1 CLASS METHODS + + =head2 C<< new_from_file($filename, collect_pod => 1) >> + + Constructs a C object given the path to a file. Returns + undef if the filename does not exist. + + C is a optional boolean argument that determines whether POD + data is collected and stored for reference. POD data is not collected by + default. POD headings are always collected. + + If the file begins by an UTF-8, UTF-16BE or UTF-16LE byte-order mark, then + it is skipped before processing, and the content of the file is also decoded + appropriately starting from perl 5.8. + + =head2 C<< new_from_handle($handle, $filename, collect_pod => 1) >> + + This works just like C, except that a handle can be provided + as the first argument. + + Note that there is no validation to confirm that the handle is a handle or + something that can act like one. Passing something that isn't a handle will + cause a exception when trying to read from it. The C argument is + mandatory or undef will be returned. + + You are responsible for setting the decoding layers on C<$handle> if + required. + + =head2 C<< new_from_module($module, collect_pod => 1, inc => \@dirs) >> + + Constructs a C object given a module or package name. + Returns undef if the module cannot be found. + + In addition to accepting the C argument as described above, + this method accepts a C argument which is a reference to an array of + directories to search for the module. If none are given, the default is + @INC. + + If the file that contains the module begins by an UTF-8, UTF-16BE or + UTF-16LE byte-order mark, then it is skipped before processing, and the + content of the file is also decoded appropriately starting from perl 5.8. + + =head2 C<< find_module_by_name($module, \@dirs) >> + + Returns the path to a module given the module or package name. A list + of directories can be passed in as an optional parameter, otherwise + @INC is searched. + + Can be called as either an object or a class method. + + =head2 C<< find_module_dir_by_name($module, \@dirs) >> + + Returns the entry in C<@dirs> (or C<@INC> by default) that contains + the module C<$module>. A list of directories can be passed in as an + optional parameter, otherwise @INC is searched. + + Can be called as either an object or a class method. + + =head2 C<< provides( %options ) >> + + This is a convenience wrapper around C + to generate a CPAN META C data structure. It takes key/value + pairs. Valid option keys include: + + =over + + =item version B<(required)> + + Specifies which version of the L should be used as + the format of the C output. Currently only '1.4' and '2' + are supported (and their format is identical). This may change in + the future as the definition of C changes. + + The C option is required. If it is omitted or if + an unsupported version is given, then C will throw an error. + + =item dir + + Directory to search recursively for F<.pm> files. May not be specified with + C. + + =item files + + Array reference of files to examine. May not be specified with C. + + =item prefix + + String to prepend to the C field of the resulting output. This defaults + to F, which is the common case for most CPAN distributions with their + F<.pm> files in F. This option ensures the META information has the + correct relative path even when the C or C arguments are + absolute or have relative paths from a location other than the distribution + root. + + =back + + For example, given C of 'lib' and C of 'lib', the return value + is a hashref of the form: + + { + 'Package::Name' => { + version => '0.123', + file => 'lib/Package/Name.pm' + }, + 'OtherPackage::Name' => ... + } + + =head2 C<< package_versions_from_directory($dir, \@files?) >> + + Scans C<$dir> for .pm files (unless C<@files> is given, in which case looks + for those files in C<$dir> - and reads each file for packages and versions, + returning a hashref of the form: + + { + 'Package::Name' => { + version => '0.123', + file => 'Package/Name.pm' + }, + 'OtherPackage::Name' => ... + } + + The C and C
packages are always omitted, as are any "private" + packages that have leading underscores in the namespace (e.g. + C) + + Note that the file path is relative to C<$dir> if that is specified. + This B be used directly for CPAN META C. See + the C method instead. + + =head2 C<< log_info (internal) >> + + Used internally to perform logging; imported from Log::Contextual if + Log::Contextual has already been loaded, otherwise simply calls warn. + + =head1 OBJECT METHODS + + =head2 C<< name() >> + + Returns the name of the package represented by this module. If there + is more than one package, it makes a best guess based on the + filename. If it's a script (i.e. not a *.pm) the package name is + 'main'. + + =head2 C<< version($package) >> + + Returns the version as defined by the $VERSION variable for the + package as returned by the C method if no arguments are + given. If given the name of a package it will attempt to return the + version of that package if it is specified in the file. + + =head2 C<< filename() >> + + Returns the absolute path to the file. + Note that this file may not actually exist on disk yet, e.g. if the module was read from an in-memory filehandle. + + =head2 C<< packages_inside() >> + + Returns a list of packages. Note: this is a raw list of packages + discovered (or assumed, in the case of C
). It is not + filtered for C, C
or private packages the way the + C method does. Invalid package names are not returned, + for example "Foo:Bar". Strange but valid package names are + returned, for example "Foo::Bar::", and are left up to the caller + on how to handle. + + =head2 C<< pod_inside() >> + + Returns a list of POD sections. + + =head2 C<< contains_pod() >> + + Returns true if there is any POD in the file. + + =head2 C<< pod($section) >> + + Returns the POD data in the given section. + + =head2 C<< is_indexable($package) >> or C<< is_indexable() >> + + Returns a boolean indicating whether the package (if provided) or any package + (otherwise) is eligible for indexing by PAUSE, the Perl Authors Upload Server. + Note This only checks for valid C declarations, and does not take any + ownership information into account. + + =head1 AUTHOR + + Original code from Module::Build::ModuleInfo by Ken Williams + , Randy W. Sims + + Released as Module::Metadata by Matt S Trout (mst) with + assistance from David Golden (xdg) . + + =head1 COPYRIGHT & LICENSE + + Original code Copyright (c) 2001-2011 Ken Williams. + Additional code Copyright (c) 2010-2011 Matt Trout and David Golden. + All rights reserved. + + This library is free software; you can redistribute it and/or + modify it under the same terms as Perl itself. + + =cut +MODULE_METADATA + +$fatpacked{"Module/Reader.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_READER'; + package Module::Reader; + BEGIN { require 5.006 } + use strict; + use warnings; + + our $VERSION = '0.002003'; + $VERSION = eval $VERSION; + + use base 'Exporter'; + our @EXPORT_OK = qw(module_content module_handle); + our %EXPORT_TAGS = (all => [@EXPORT_OK]); + + use File::Spec; + use Scalar::Util qw(blessed reftype openhandle); + use Carp; + use constant _OPEN_STRING => $] >= 5.008; + BEGIN { + require IO::String + if !_OPEN_STRING; + } + + sub module_content { + my $module = _get_module(@_); + if (ref $module) { + local $/; + return scalar <$module>; + } + else { + return $module; + } + } + + sub module_handle { + my $module = _get_module(@_); + if (ref $module) { + return $module; + } + elsif (_OPEN_STRING) { + open my $fh, '<', \$module; + return $fh; + } + else { + return IO::String->new($module); + } + } + + sub _get_module { + my ($package, @inc) = @_; + (my $module = "$package.pm") =~ s{::}{/}g; + my $opts = ref $_[-1] && ref $_[-1] eq 'HASH' && pop @inc || {}; + if (!@inc) { + @inc = @INC; + } + if (my $found = $opts->{found}) { + if (my $full_module = $found->{$module}) { + if (ref $full_module) { + @inc = $full_module; + } + elsif (-f $full_module) { + open my $fh, '<', $full_module + or die "Couldn't open ${full_module} for ${module}: $!"; + return $fh; + } + } + } + for my $inc (@inc) { + if (!ref $inc) { + my $full_module = File::Spec->catfile($inc, $module); + next unless -f $full_module; + open my $fh, '<', $full_module + or die "Couldn't open ${full_module} for ${module}: $!"; + return $fh; + } + + my @cb = ref $inc eq 'ARRAY' ? $inc->[0]->($inc, $module) + : blessed $inc ? $inc->INC($module) + : $inc->($inc, $module); + + next + unless ref $cb[0]; + my $fh; + if (reftype $cb[0] eq 'GLOB' && openhandle $cb[0]) { + $fh = shift @cb; + } + + if (ref $cb[0] eq 'CODE') { + my $cb = shift @cb; + # require docs are wrong, perl sends 0 as the first param + my @params = (0, @cb ? $cb[0] : ()); + + my $module = ''; + while (1) { + local $_ = $fh ? <$fh> : ''; + $_ = '' + if !defined; + last if !$cb->(@params); + $module .= $_; + } + return $module; + } + elsif ($fh) { + return $fh; + } + } + croak "Can't find module $module"; + } + + 1; + + __END__ + + =head1 NAME + + Module::Reader - Read the source of a module like perl does + + =head1 SYNOPSIS + + use Module::Reader qw(:all); + my $io = module_handle('My::Module'); + my $content = module_content('My::Module'); + + my $io = module_handle('My::Module', @search_dirs); + + my $io = module_handle('My::Module', @search_dirs, { found => \%INC }); + + =head1 DESCRIPTION + + Reads the content of perl modules the same way perl does. This + includes reading modules available only by L<@INC hooks|perlfunc/require>, or filtered + through them. + + =head1 EXPORTS + + =head2 module_handle( $module_name, @search_dirs, \%options ) + + Returns an IO handle to the given module. Searches the directories + specified, or L<@INC|perlvar/@INC> if none are. + + =head3 Options + + =over 4 + + =item found + + A reference to a hash like L<%INC|perlvar/%INC> with module file names (in the + style 'F') as keys and full file paths as values. + Modules listed in this will be used in preference to searching + through directories. + + =back + + =head2 module_content( $module_name, @search_dirs, \%options ) + + Returns the content of the given module. Accepts the same options as C. + + =head1 AUTHOR + + haarg - Graham Knop (cpan:HAARG) + + =head2 CONTRIBUTORS + + None yet. + + =head1 COPYRIGHT + + Copyright (c) 2013 the Module::Reader L and L + as listed above. + + =head1 LICENSE + + This library is free software and may be distributed under the same terms + as perl itself. + + =cut +MODULE_READER + +$fatpacked{"Parse/CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PARSE_CPAN_META'; + use 5.008001; + use strict; + package Parse::CPAN::Meta; + # ABSTRACT: Parse META.yml and META.json CPAN metadata files + our $VERSION = '1.4414'; # VERSION + + use Exporter; + use Carp 'croak'; + + our @ISA = qw/Exporter/; + our @EXPORT_OK = qw/Load LoadFile/; + + sub load_file { + my ($class, $filename) = @_; + + my $meta = _slurp($filename); + + if ($filename =~ /\.ya?ml$/) { + return $class->load_yaml_string($meta); + } + elsif ($filename =~ /\.json$/) { + return $class->load_json_string($meta); + } + else { + $class->load_string($meta); # try to detect yaml/json + } + } + + sub load_string { + my ($class, $string) = @_; + if ( $string =~ /^---/ ) { # looks like YAML + return $class->load_yaml_string($string); + } + elsif ( $string =~ /^\s*\{/ ) { # looks like JSON + return $class->load_json_string($string); + } + else { # maybe doc-marker-free YAML + return $class->load_yaml_string($string); + } + } + + sub load_yaml_string { + my ($class, $string) = @_; + my $backend = $class->yaml_backend(); + my $data = eval { no strict 'refs'; &{"$backend\::Load"}($string) }; + croak $@ if $@; + return $data || {}; # in case document was valid but empty + } + + sub load_json_string { + my ($class, $string) = @_; + my $data = eval { $class->json_backend()->new->decode($string) }; + croak $@ if $@; + return $data || {}; + } + + sub yaml_backend { + if (! defined $ENV{PERL_YAML_BACKEND} ) { + _can_load( 'CPAN::Meta::YAML', 0.011 ) + or croak "CPAN::Meta::YAML 0.011 is not available\n"; + return "CPAN::Meta::YAML"; + } + else { + my $backend = $ENV{PERL_YAML_BACKEND}; + _can_load( $backend ) + or croak "Could not load PERL_YAML_BACKEND '$backend'\n"; + $backend->can("Load") + or croak "PERL_YAML_BACKEND '$backend' does not implement Load()\n"; + return $backend; + } + } + + sub json_backend { + if (! $ENV{PERL_JSON_BACKEND} or $ENV{PERL_JSON_BACKEND} eq 'JSON::PP') { + _can_load( 'JSON::PP' => 2.27103 ) + or croak "JSON::PP 2.27103 is not available\n"; + return 'JSON::PP'; + } + else { + _can_load( 'JSON' => 2.5 ) + or croak "JSON 2.5 is required for " . + "\$ENV{PERL_JSON_BACKEND} = '$ENV{PERL_JSON_BACKEND}'\n"; + return "JSON"; + } + } + + sub _slurp { + require Encode; + open my $fh, "<:raw", "$_[0]" ## no critic + or die "can't open $_[0] for reading: $!"; + my $content = do { local $/; <$fh> }; + $content = Encode::decode('UTF-8', $content, Encode::PERLQQ()); + return $content; + } + + sub _can_load { + my ($module, $version) = @_; + (my $file = $module) =~ s{::}{/}g; + $file .= ".pm"; + return 1 if $INC{$file}; + return 0 if exists $INC{$file}; # prior load failed + eval { require $file; 1 } + or return 0; + if ( defined $version ) { + eval { $module->VERSION($version); 1 } + or return 0; + } + return 1; + } + + # Kept for backwards compatibility only + # Create an object from a file + sub LoadFile ($) { + return Load(_slurp(shift)); + } + + # Parse a document from a string. + sub Load ($) { + require CPAN::Meta::YAML; + my $object = eval { CPAN::Meta::YAML::Load(shift) }; + croak $@ if $@; + return $object; + } + + 1; + + __END__ + + =pod + + =encoding UTF-8 + + =head1 NAME + + Parse::CPAN::Meta - Parse META.yml and META.json CPAN metadata files + + =head1 VERSION + + version 1.4414 + + =head1 SYNOPSIS + + ############################################# + # In your file + + --- + name: My-Distribution + version: 1.23 + resources: + homepage: "http://example.com/dist/My-Distribution" + + + ############################################# + # In your program + + use Parse::CPAN::Meta; + + my $distmeta = Parse::CPAN::Meta->load_file('META.yml'); + + # Reading properties + my $name = $distmeta->{name}; + my $version = $distmeta->{version}; + my $homepage = $distmeta->{resources}{homepage}; + + =head1 DESCRIPTION + + B is a parser for F and F files, using + L and/or L. + + B provides three methods: C, C, + and C. These will read and deserialize CPAN metafiles, and + are described below in detail. + + B provides a legacy API of only two functions, + based on the YAML functions of the same name. Wherever possible, + identical calling semantics are used. These may only be used with YAML sources. + + All error reporting is done with exceptions (die'ing). + + Note that META files are expected to be in UTF-8 encoding, only. When + converted string data, it must first be decoded from UTF-8. + + =begin Pod::Coverage + + + + + =end Pod::Coverage + + =head1 METHODS + + =head2 load_file + + my $metadata_structure = Parse::CPAN::Meta->load_file('META.json'); + + my $metadata_structure = Parse::CPAN::Meta->load_file('META.yml'); + + This method will read the named file and deserialize it to a data structure, + determining whether it should be JSON or YAML based on the filename. + The file will be read using the ":utf8" IO layer. + + =head2 load_yaml_string + + my $metadata_structure = Parse::CPAN::Meta->load_yaml_string($yaml_string); + + This method deserializes the given string of YAML and returns the first + document in it. (CPAN metadata files should always have only one document.) + If the source was UTF-8 encoded, the string must be decoded before calling + C. + + =head2 load_json_string + + my $metadata_structure = Parse::CPAN::Meta->load_json_string($json_string); + + This method deserializes the given string of JSON and the result. + If the source was UTF-8 encoded, the string must be decoded before calling + C. + + =head2 load_string + + my $metadata_structure = Parse::CPAN::Meta->load_string($some_string); + + If you don't know whether a string contains YAML or JSON data, this method + will use some heuristics and guess. If it can't tell, it assumes YAML. + + =head2 yaml_backend + + my $backend = Parse::CPAN::Meta->yaml_backend; + + Returns the module name of the YAML serializer. See L + for details. + + =head2 json_backend + + my $backend = Parse::CPAN::Meta->json_backend; + + Returns the module name of the JSON serializer. This will either + be L or L. Even if C is set, + this will return L as further delegation is handled by + the L module. See L for details. + + =head1 FUNCTIONS + + For maintenance clarity, no functions are exported by default. These functions + are available for backwards compatibility only and are best avoided in favor of + C. + + =head2 Load + + my @yaml = Parse::CPAN::Meta::Load( $string ); + + Parses a string containing a valid YAML stream into a list of Perl data + structures. + + =head2 LoadFile + + my @yaml = Parse::CPAN::Meta::LoadFile( 'META.yml' ); + + Reads the YAML stream from a file instead of a string. + + =head1 ENVIRONMENT + + =head2 PERL_JSON_BACKEND + + By default, L will be used for deserializing JSON data. If the + C environment variable exists, is true and is not + "JSON::PP", then the L module (version 2.5 or greater) will be loaded and + used to interpret C. If L is not installed or is too + old, an exception will be thrown. + + =head2 PERL_YAML_BACKEND + + By default, L will be used for deserializing YAML data. If + the C environment variable is defined, then it is interpreted + as a module to use for deserialization. The given module must be installed, + must load correctly and must implement the C function or an exception + will be thrown. + + =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan + + =head1 SUPPORT + + =head2 Bugs / Feature Requests + + Please report any bugs or feature requests through the issue tracker + at L. + You will be notified automatically of any progress on your issue. + + =head2 Source Code + + This is open source software. The code repository is available for + public review and contribution under the terms of the license. + + L + + git clone https://github.com/Perl-Toolchain-Gang/Parse-CPAN-Meta.git + + =head1 AUTHORS + + =over 4 + + =item * + + Adam Kennedy + + =item * + + David Golden + + =back + + =head1 CONTRIBUTORS + + =over 4 + + =item * + + Graham Knop + + =item * + + Joshua ben Jore + + =item * + + Neil Bowers + + =item * + + Ricardo Signes + + =item * + + Steffen Mueller + + =back + + =head1 COPYRIGHT AND LICENSE + + This software is copyright (c) 2014 by Adam Kennedy and Contributors. + + This is free software; you can redistribute it and/or modify it under + the same terms as the Perl 5 programming language system itself. + + =cut +PARSE_CPAN_META + +$fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_TINY'; + use 5.008001; + use strict; + use warnings; + + package Path::Tiny; + # ABSTRACT: File path utility + + our $VERSION = '0.072'; # from Path-Tiny-0.072.tar.gz + + # Dependencies + use Config; + use Exporter 5.57 (qw/import/); + use File::Spec 3.40 (); + use Carp (); + + our @EXPORT = qw/path/; + our @EXPORT_OK = qw/cwd rootdir tempfile tempdir/; + + use constant { + PATH => 0, + CANON => 1, + VOL => 2, + DIR => 3, + FILE => 4, + TEMP => 5, + IS_BSD => ( scalar $^O =~ /bsd$/ ), + IS_WIN32 => ( $^O eq 'MSWin32' ), + }; + + use overload ( + q{""} => sub { $_[0]->[PATH] }, + bool => sub () { 1 }, + fallback => 1, + ); + + # FREEZE/THAW per Sereal/CBOR/Types::Serialiser protocol + sub FREEZE { return $_[0]->[PATH] } + sub THAW { return path( $_[2] ) } + { no warnings 'once'; *TO_JSON = *FREEZE }; + + my $HAS_UU; # has Unicode::UTF8; lazily populated + + sub _check_UU { + !!eval { require Unicode::UTF8; Unicode::UTF8->VERSION(0.58); 1 }; + } + + my $HAS_FLOCK = $Config{d_flock} || $Config{d_fcntl_can_lock} || $Config{d_lockf}; + + # notions of "root" directories differ on Win32: \\server\dir\ or C:\ or \ + my $SLASH = qr{[\\/]}; + my $NOTSLASH = qr{[^\\/]}; + my $DRV_VOL = qr{[a-z]:}i; + my $UNC_VOL = qr{$SLASH $SLASH $NOTSLASH+ $SLASH $NOTSLASH+}x; + my $WIN32_ROOT = qr{(?: $UNC_VOL $SLASH | $DRV_VOL $SLASH | $SLASH )}x; + + sub _win32_vol { + my ( $path, $drv ) = @_; + require Cwd; + my $dcwd = eval { Cwd::getdcwd($drv) }; # C: -> C:\some\cwd + # getdcwd on non-existent drive returns empty string + # so just use the original drive Z: -> Z: + $dcwd = "$drv" unless defined $dcwd && length $dcwd; + # normalize dwcd to end with a slash: might be C:\some\cwd or D:\ or Z: + $dcwd =~ s{$SLASH?$}{/}; + # make the path absolute with dcwd + $path =~ s{^$DRV_VOL}{$dcwd}; + return $path; + } + + # This is a string test for before we have the object; see is_rootdir for well-formed + # object test + sub _is_root { + return IS_WIN32() ? ( $_[0] =~ /^$WIN32_ROOT$/ ) : ( $_[0] eq '/' ); + } + + # mode bits encoded for chmod in symbolic mode + my %MODEBITS = ( om => 0007, gm => 0070, um => 0700 ); ## no critic + { my $m = 0; $MODEBITS{$_} = ( 1 << $m++ ) for qw/ox ow or gx gw gr ux uw ur/ }; + + sub _symbolic_chmod { + my ( $mode, $symbolic ) = @_; + for my $clause ( split /,\s*/, $symbolic ) { + if ( $clause =~ m{\A([augo]+)([=+-])([rwx]+)\z} ) { + my ( $who, $action, $perms ) = ( $1, $2, $3 ); + $who =~ s/a/ugo/g; + for my $w ( split //, $who ) { + my $p = 0; + $p |= $MODEBITS{"$w$_"} for split //, $perms; + if ( $action eq '=' ) { + $mode = ( $mode & ~$MODEBITS{"${w}m"} ) | $p; + } + else { + $mode = $action eq "+" ? ( $mode | $p ) : ( $mode & ~$p ); + } + } + } + else { + Carp::croak("Invalid mode clause '$clause' for chmod()"); + } + } + return $mode; + } + + # flock doesn't work on NFS on BSD. Since program authors often can't control + # or detect that, we warn once instead of being fatal if we can detect it and + # people who need it strict can fatalize the 'flock' category + + #<<< No perltidy + { package flock; use if Path::Tiny::IS_BSD(), 'warnings::register' } + #>>> + + my $WARNED_BSD_NFS = 0; + + sub _throw { + my ( $self, $function, $file ) = @_; + if ( IS_BSD() + && $function =~ /^flock/ + && $! =~ /operation not supported/i + && !warnings::fatal_enabled('flock') ) + { + if ( !$WARNED_BSD_NFS ) { + warnings::warn( flock => "No flock for NFS on BSD: continuing in unsafe mode" ); + $WARNED_BSD_NFS++; + } + } + else { + Path::Tiny::Error->throw( $function, ( defined $file ? $file : $self->[PATH] ), $! ); + } + return; + } + + # cheapo option validation + sub _get_args { + my ( $raw, @valid ) = @_; + if ( defined($raw) && ref($raw) ne 'HASH' ) { + my ( undef, undef, undef, $called_as ) = caller(1); + $called_as =~ s{^.*::}{}; + Carp::croak("Options for $called_as must be a hash reference"); + } + my $cooked = {}; + for my $k (@valid) { + $cooked->{$k} = delete $raw->{$k} if exists $raw->{$k}; + } + if ( keys %$raw ) { + my ( undef, undef, undef, $called_as ) = caller(1); + $called_as =~ s{^.*::}{}; + Carp::croak( "Invalid option(s) for $called_as: " . join( ", ", keys %$raw ) ); + } + return $cooked; + } + + #--------------------------------------------------------------------------# + # Constructors + #--------------------------------------------------------------------------# + + #pod =construct path + #pod + #pod $path = path("foo/bar"); + #pod $path = path("/tmp", "file.txt"); # list + #pod $path = path("."); # cwd + #pod $path = path("~user/file.txt"); # tilde processing + #pod + #pod Constructs a C object. It doesn't matter if you give a file or + #pod directory path. It's still up to you to call directory-like methods only on + #pod directories and file-like methods only on files. This function is exported + #pod automatically by default. + #pod + #pod The first argument must be defined and have non-zero length or an exception + #pod will be thrown. This prevents subtle, dangerous errors with code like + #pod C<< path( maybe_undef() )->remove_tree >>. + #pod + #pod If the first component of the path is a tilde ('~') then the component will be + #pod replaced with the output of C. If the first component of the path + #pod is a tilde followed by a user name then the component will be replaced with + #pod output of C. Behaviour for non-existent users depends on + #pod the output of C on the system. + #pod + #pod On Windows, if the path consists of a drive identifier without a path component + #pod (C or C), it will be expanded to the absolute path of the current + #pod directory on that volume using C. + #pod + #pod If called with a single C argument, the original is returned unless + #pod the original is holding a temporary file or directory reference in which case a + #pod stringified copy is made. + #pod + #pod $path = path("foo/bar"); + #pod $temp = Path::Tiny->tempfile; + #pod + #pod $p2 = path($path); # like $p2 = $path + #pod $t2 = path($temp); # like $t2 = path( "$temp" ) + #pod + #pod This optimizes copies without proliferating references unexpectedly if a copy is + #pod made by code outside your control. + #pod + #pod Current API available since 0.017. + #pod + #pod =cut + + sub path { + my $path = shift; + Carp::croak("Path::Tiny paths require defined, positive-length parts") + unless 1 + @_ == grep { defined && length } $path, @_; + + # non-temp Path::Tiny objects are effectively immutable and can be reused + if ( !@_ && ref($path) eq __PACKAGE__ && !$path->[TEMP] ) { + return $path; + } + + # stringify objects + $path = "$path"; + + # expand relative volume paths on windows; put trailing slash on UNC root + if ( IS_WIN32() ) { + $path = _win32_vol( $path, $1 ) if $path =~ m{^($DRV_VOL)(?:$NOTSLASH|$)}; + $path .= "/" if $path =~ m{^$UNC_VOL$}; + } + + # concatenations stringifies objects, too + if (@_) { + $path .= ( _is_root($path) ? "" : "/" ) . join( "/", @_ ); + } + + # canonicalize, but with unix slashes and put back trailing volume slash + my $cpath = $path = File::Spec->canonpath($path); + $path =~ tr[\\][/] if IS_WIN32(); + $path .= "/" if IS_WIN32() && $path =~ m{^$UNC_VOL$}; + + # root paths must always have a trailing slash, but other paths must not + if ( _is_root($path) ) { + $path =~ s{/?$}{/}; + } + else { + $path =~ s{/$}{}; + } + + # do any tilde expansions + if ( $path =~ m{^(~[^/]*).*} ) { + require File::Glob; + my ($homedir) = File::Glob::bsd_glob($1); + $path =~ s{^(~[^/]*)}{$homedir}; + } + + bless [ $path, $cpath ], __PACKAGE__; + } + + #pod =construct new + #pod + #pod $path = Path::Tiny->new("foo/bar"); + #pod + #pod This is just like C, but with method call overhead. (Why would you + #pod do that?) + #pod + #pod Current API available since 0.001. + #pod + #pod =cut + + sub new { shift; path(@_) } + + #pod =construct cwd + #pod + #pod $path = Path::Tiny->cwd; # path( Cwd::getcwd ) + #pod $path = cwd; # optional export + #pod + #pod Gives you the absolute path to the current directory as a C object. + #pod This is slightly faster than C<< path(".")->absolute >>. + #pod + #pod C may be exported on request and used as a function instead of as a + #pod method. + #pod + #pod Current API available since 0.018. + #pod + #pod =cut + + sub cwd { + require Cwd; + return path( Cwd::getcwd() ); + } + + #pod =construct rootdir + #pod + #pod $path = Path::Tiny->rootdir; # / + #pod $path = rootdir; # optional export + #pod + #pod Gives you C<< File::Spec->rootdir >> as a C object if you're too + #pod picky for C. + #pod + #pod C may be exported on request and used as a function instead of as a + #pod method. + #pod + #pod Current API available since 0.018. + #pod + #pod =cut + + sub rootdir { path( File::Spec->rootdir ) } + + #pod =construct tempfile, tempdir + #pod + #pod $temp = Path::Tiny->tempfile( @options ); + #pod $temp = Path::Tiny->tempdir( @options ); + #pod $temp = tempfile( @options ); # optional export + #pod $temp = tempdir( @options ); # optional export + #pod + #pod C passes the options to C<< File::Temp->new >> and returns a C + #pod object with the file name. The C option is enabled by default. + #pod + #pod The resulting C object is cached. When the C object is + #pod destroyed, the C object will be as well. + #pod + #pod C annoyingly requires you to specify a custom template in slightly + #pod different ways depending on which function or method you call, but + #pod C lets you ignore that and can take either a leading template or a + #pod C