aboutsummaryrefslogtreecommitdiffstats
path: root/vendor
diff options
context:
space:
mode:
authorMatthew Somerville <matthew-github@dracos.co.uk>2019-05-03 19:42:00 +0100
committerMatthew Somerville <matthew-github@dracos.co.uk>2019-05-05 15:06:16 +0100
commit08ff4cf7bb3d43798e51fe53c421e2c79b007309 (patch)
treeccbcd67817a5dcdfa78d79df8f3320414e3c8e6d /vendor
parent92b253904062edd533e55c22824de6fd01e2f7c1 (diff)
Update carton.
Diffstat (limited to 'vendor')
-rwxr-xr-xvendor/bin/carton54750
1 files changed, 23618 insertions, 31132 deletions
diff --git a/vendor/bin/carton b/vendor/bin/carton
index 0a714c6d7..cc3d197cf 100755
--- a/vendor/bin/carton
+++ b/vendor/bin/carton
@@ -5,25651 +5,1407 @@
BEGIN {
my %fatpacked;
-$fatpacked{"App/cpanminus.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_CPANMINUS';
- package App::cpanminus;
- our $VERSION = "1.7043";
+$fatpacked{"CPAN/Common/Index.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_COMMON_INDEX';
+ use 5.008001;
+ use strict;
+ use warnings;
- =encoding utf8
+ package CPAN::Common::Index;
+ # ABSTRACT: Common library for searching CPAN modules, authors and distributions
- =head1 NAME
+ our $VERSION = '0.010';
- App::cpanminus - get, unpack, build and install modules from CPAN
+ use Carp ();
- =head1 SYNOPSIS
+ use Class::Tiny;
- cpanm Module
+ #--------------------------------------------------------------------------#
+ # Document abstract methods
+ #--------------------------------------------------------------------------#
- Run C<cpanm -h> or C<perldoc cpanm> for more options.
+ #pod =method search_packages (ABSTRACT)
+ #pod
+ #pod $result = $index->search_packages( { package => "Moose" });
+ #pod @result = $index->search_packages( \%advanced_query );
+ #pod
+ #pod Searches the index for a package such as listed in the CPAN
+ #pod F<02packages.details.txt> file. The query must be provided as a hash
+ #pod reference. Valid keys are
+ #pod
+ #pod =for :list
+ #pod * package -- a string, regular expression or code reference
+ #pod * version -- a version number or code reference
+ #pod * dist -- a string, regular expression or code reference
+ #pod
+ #pod If the query term is a string or version number, the query will be for an exact
+ #pod match. If a code reference, the code will be called with the value of the
+ #pod field for each potential match. It should return true if it matches.
+ #pod
+ #pod Not all backends will implement support for all fields or all types of queries.
+ #pod If it does not implement either, it should "decline" the query with an empty
+ #pod return.
+ #pod
+ #pod The return should be context aware, returning either a
+ #pod single result or a list of results.
+ #pod
+ #pod The result must be formed as follows:
+ #pod
+ #pod {
+ #pod package => 'MOOSE',
+ #pod version => '2.0802',
+ #pod uri => "cpan:///distfile/ETHER/Moose-2.0802.tar.gz"
+ #pod }
+ #pod
+ #pod The C<uri> field should be a valid URI. It may be a L<URI::cpan> or any other
+ #pod URI. (It is up to a client to do something useful with any given URI scheme.)
+ #pod
+ #pod =method search_authors (ABSTRACT)
+ #pod
+ #pod $result = $index->search_authors( { id => "DAGOLDEN" });
+ #pod @result = $index->search_authors( \%advanced_query );
+ #pod
+ #pod Searches the index for author data such as from the CPAN F<01mailrc.txt> file.
+ #pod The query must be provided as a hash reference. Valid keys are
+ #pod
+ #pod =for :list
+ #pod * id -- a string, regular expression or code reference
+ #pod * fullname -- a string, regular expression or code reference
+ #pod * email -- a string, regular expression or code reference
+ #pod
+ #pod If the query term is a string, the query will be for an exact match. If a code
+ #pod reference, the code will be called with the value of the field for each
+ #pod potential match. It should return true if it matches.
+ #pod
+ #pod Not all backends will implement support for all fields or all types of queries.
+ #pod If it does not implement either, it should "decline" the query with an empty
+ #pod return.
+ #pod
+ #pod The return should be context aware, returning either a single result or a list
+ #pod of results.
+ #pod
+ #pod The result must be formed as follows:
+ #pod
+ #pod {
+ #pod id => 'DAGOLDEN',
+ #pod fullname => 'David Golden',
+ #pod email => 'dagolden@cpan.org',
+ #pod }
+ #pod
+ #pod The C<email> field may not reflect an actual email address. The 01mailrc file
+ #pod on CPAN often shows "CENSORED" when email addresses are concealed.
+ #pod
+ #pod =cut
- =head1 DESCRIPTION
+ #--------------------------------------------------------------------------#
+ # stub methods
+ #--------------------------------------------------------------------------#
- cpanminus is a script to get, unpack, build and install modules from
- CPAN and does nothing else.
+ #pod =method index_age
+ #pod
+ #pod $epoch = $index->index_age;
+ #pod
+ #pod Returns the modification time of the index in epoch seconds. This may not make sense
+ #pod for some backends. By default it returns the current time.
+ #pod
+ #pod =cut
- It's dependency free (can bootstrap itself), requires zero
- configuration, and stands alone. When running, it requires only 10MB
- of RAM.
+ sub index_age { time }
- =head1 INSTALLATION
+ #pod =method refresh_index
+ #pod
+ #pod $index->refresh_index;
+ #pod
+ #pod This ensures the index source is up to date. For example, a remote
+ #pod mirror file would be re-downloaded. By default, it does nothing.
+ #pod
+ #pod =cut
- There are several ways to install cpanminus to your system.
+ sub refresh_index { 1 }
- =head2 Package management system
+ #pod =method attributes
+ #pod
+ #pod Return attributes and default values as a hash reference. By default
+ #pod returns an empty hash reference.
+ #pod
+ #pod =cut
- 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<cpanm> to your system without thinking about where to
- install, and later upgrade.
+ sub attributes { {} }
- =head2 Installing to system perl
+ #pod =method validate_attributes
+ #pod
+ #pod $self->validate_attributes;
+ #pod
+ #pod This is called by the constructor to validate any arguments. Subclasses
+ #pod should override the default one to perform validation. It should not be
+ #pod called by application code. By default, it does nothing.
+ #pod
+ #pod =cut
- You can also use the latest cpanminus to install cpanminus itself:
+ sub validate_attributes { 1 }
- curl -L https://cpanmin.us | perl - --sudo App::cpanminus
+ 1;
- This will install C<cpanm> to your bin directory like
- C</usr/local/bin> and you'll need the C<--sudo> option to write to
- the directory, unless you configured C<INSTALL_BASE> with L<local::lib>.
- =head2 Installing to local perl (perlbrew, plenv etc.)
+ # vim: ts=4 sts=4 sw=4 et:
- If you have perl in your home directory, which is the case if you use
- tools like L<perlbrew> 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:
+ __END__
- curl -L https://cpanmin.us | perl - App::cpanminus
+ =pod
- to install the C<cpanm> executable to the perl's bin path, like
- C<~/perl5/perlbrew/bin/cpanm>.
+ =encoding UTF-8
- =head2 Downloading the standalone executable
+ =head1 NAME
- You can also copy the standalone executable to whatever location you'd like.
+ CPAN::Common::Index - Common library for searching CPAN modules, authors and distributions
- cd ~/bin
- curl -L https://cpanmin.us/ -o cpanm
- chmod +x cpanm
+ =head1 VERSION
- 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.
+ version 0.010
- =head2 Troubleshoot: HTTPS warnings
+ =head1 SYNOPSIS
- When you run C<curl> 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.
+ use CPAN::Common::Index::Mux::Ordered;
+ use Data::Dumper;
- 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<https://git.io/cpanm>
+ $index = CPAN::Common::Index::Mux::Ordered->assemble(
+ MetaDB => {},
+ Mirror => { mirror => "http://cpan.cpantesters.org" },
+ );
- =head1 DEPENDENCIES
+ $result = $index->search_packages( { package => "Moose" } );
- perl 5.8.1 or later.
+ print Dumper($result);
- =over 4
+ # {
+ # package => 'MOOSE',
+ # version => '2.0802',
+ # uri => "cpan:///distfile/ETHER/Moose-2.0802.tar.gz"
+ # }
- =item *
+ =head1 DESCRIPTION
- 'tar' executable (bsdtar or GNU tar version 1.22 are recommended) or Archive::Tar to unpack files.
+ This module provides a common library for working with a variety of CPAN index
+ services. It is intentionally minimalist, trying to use as few non-core
+ modules as possible.
- =item *
+ The C<CPAN::Common::Index> module is an abstract base class that defines a
+ common API. Individual backends deliver the API for a particular index.
+
+ As shown in the SYNOPSIS, one interesting application is multiplexing -- using
+ different index backends, querying each in turn, and returning the first
+ result.
- C compiler, if you want to build XS modules.
+ =head1 METHODS
- =item *
+ =head2 search_packages (ABSTRACT)
+
+ $result = $index->search_packages( { package => "Moose" });
+ @result = $index->search_packages( \%advanced_query );
+
+ Searches the index for a package such as listed in the CPAN
+ F<02packages.details.txt> file. The query must be provided as a hash
+ reference. Valid keys are
- make
+ =over 4
=item *
- Module::Build (core in 5.10)
+ package -- a string, regular expression or code reference
- =back
+ =item *
- =head1 QUESTIONS
+ version -- a version number or code reference
- =head2 How does cpanm get/parse/update the CPAN index?
+ =item *
- It queries the CPAN Meta DB site at L<http://cpanmetadb.plackperl.org/>.
- 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<http://metacpan.org/> using its search API.
+ dist -- a string, regular expression or code reference
- 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<cpanm>, and read more about the privacy policy
- about this data collection at L<http://cpanmetadb.plackperl.org/#privacy>
+ =back
- Fetched files are unpacked in C<~/.cpanm> and automatically cleaned up
- periodically. You can configure the location of this with the
- C<PERL_CPANM_HOME> environment variable.
+ If the query term is a string or version number, the query will be for an exact
+ match. If a code reference, the code will be called with the value of the
+ field for each potential match. It should return true if it matches.
- =head2 Where does this install modules to? Do I need root access?
+ Not all backends will implement support for all fields or all types of queries.
+ If it does not implement either, it should "decline" the query with an empty
+ return.
- It installs to wherever ExtUtils::MakeMaker and Module::Build are
- configured to (via C<PERL_MM_OPT> and C<PERL_MB_OPT>).
+ The return should be context aware, returning either a
+ single result or a list of results.
- By default, it installs to the site_perl directory that belongs to
- your perl. You can see the locations for that by running C<perl -V>
- and it will be likely something under C</opt/local/perl/...> if you're
- using system perl, or under your home directory if you have built perl
- yourself using perlbrew or plenv.
+ The result must be formed as follows:
- If you've already configured local::lib on your shell, cpanm respects
- that settings and modules will be installed to your local perl5
- directory.
+ {
+ package => 'MOOSE',
+ version => '2.0802',
+ uri => "cpan:///distfile/ETHER/Moose-2.0802.tar.gz"
+ }
- 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<perl5> directory under your home
- directory.
+ The C<uri> field should be a valid URI. It may be a L<URI::cpan> or any other
+ URI. (It is up to a client to do something useful with any given URI scheme.)
- To avoid this, run C<cpanm> either as a root user, with C<--sudo>
- option, or with C<--local-lib> option.
+ =head2 search_authors (ABSTRACT)
- =head2 cpanminus can't install the module XYZ. Is it a bug?
+ $result = $index->search_authors( { id => "DAGOLDEN" });
+ @result = $index->search_authors( \%advanced_query );
- It is more likely a problem with the distribution itself. cpanminus
- doesn't support or may have issues with distributions such as follows:
+ Searches the index for author data such as from the CPAN F<01mailrc.txt> file.
+ The query must be provided as a hash reference. Valid keys are
=over 4
=item *
- Tests that require input from STDIN.
+ id -- a string, regular expression or code reference
=item *
- Build.PL or Makefile.PL that prompts for input even when
- C<PERL_MM_USE_DEFAULT> is enabled.
+ fullname -- a string, regular expression or code reference
=item *
- Modules that have invalid numeric values as VERSION (such as C<1.1a>)
+ email -- a string, regular expression or code reference
=back
- These failures can be reported back to the author of the module so
- that they can fix it accordingly, rather than to cpanminus.
+ If the query term is a string, the query will be for an exact match. If a code
+ reference, the code will be called with the value of the field for each
+ potential match. It should return true if it matches.
- =head2 Does cpanm support the feature XYZ of L<CPAN> and L<CPANPLUS>?
+ Not all backends will implement support for all fields or all types of queries.
+ If it does not implement either, it should "decline" the query with an empty
+ return.
- Most likely not. Here are the things that cpanm doesn't do by
- itself.
+ The return should be context aware, returning either a single result or a list
+ of results.
- If you need these features, use L<CPAN>, L<CPANPLUS> or the standalone
- tools that are mentioned.
+ The result must be formed as follows:
- =over 4
+ {
+ id => 'DAGOLDEN',
+ fullname => 'David Golden',
+ email => 'dagolden@cpan.org',
+ }
- =item *
+ The C<email> field may not reflect an actual email address. The 01mailrc file
+ on CPAN often shows "CENSORED" when email addresses are concealed.
- CPAN testers reporting. See L<App::cpanminus::reporter>
+ =head2 index_age
- =item *
+ $epoch = $index->index_age;
- Building RPM packages from CPAN modules
+ Returns the modification time of the index in epoch seconds. This may not make sense
+ for some backends. By default it returns the current time.
- =item *
+ =head2 refresh_index
- Listing the outdated modules that needs upgrading. See L<App::cpanoutdated>
+ $index->refresh_index;
- =item *
+ This ensures the index source is up to date. For example, a remote
+ mirror file would be re-downloaded. By default, it does nothing.
- Showing the changes of the modules you're about to upgrade. See L<cpan-listchanges>
+ =head2 attributes
- =item *
+ Return attributes and default values as a hash reference. By default
+ returns an empty hash reference.
- Patching CPAN modules with distroprefs.
+ =head2 validate_attributes
- =back
+ $self->validate_attributes;
- See L<cpanm> or C<cpanm -h> to see what cpanminus I<can> do :)
+ This is called by the constructor to validate any arguments. Subclasses
+ should override the default one to perform validation. It should not be
+ called by application code. By default, it does nothing.
- =head1 COPYRIGHT
-
- Copyright 2010- Tatsuhiko Miyagawa
-
- The standalone executable contains the following modules embedded.
-
- =over 4
+ =for Pod::Coverage method_names_here
- =item L<CPAN::DistnameInfo> Copyright 2003 Graham Barr
+ =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
- =item L<local::lib> Copyright 2007-2009 Matt S Trout
+ =head1 SUPPORT
- =item L<HTTP::Tiny> Copyright 2011 Christian Hansen
+ =head2 Bugs / Feature Requests
- =item L<Module::Metadata> Copyright 2001-2006 Ken Williams. 2010 Matt S Trout
+ Please report any bugs or feature requests through the issue tracker
+ at L<https://github.com/Perl-Toolchain-Gang/CPAN-Common-Index/issues>.
+ You will be notified automatically of any progress on your issue.
- =item L<version> Copyright 2004-2010 John Peacock
+ =head2 Source Code
- =item L<JSON::PP> Copyright 2007-2011 by Makamaka Hannyaharamitu
+ This is open source software. The code repository is available for
+ public review and contribution under the terms of the license.
- =item L<CPAN::Meta>, L<CPAN::Meta::Requirements> Copyright (c) 2010 by David Golden and Ricardo Signes
+ L<https://github.com/Perl-Toolchain-Gang/CPAN-Common-Index>
- =item L<CPAN::Meta::YAML> Copyright 2010 Adam Kennedy
+ git clone https://github.com/Perl-Toolchain-Gang/CPAN-Common-Index.git
- =item L<File::pushd> Copyright 2012 David Golden
+ =head1 AUTHOR
- =back
+ David Golden <dagolden@cpan.org>
- =head1 LICENSE
+ =head1 CONTRIBUTORS
- This software is licensed under the same terms as Perl.
+ =for stopwords David Golden Helmut Wollmersdorfer Kenichi Ishigaki Shoichi Kaji Tatsuhiko Miyagawa
- =head1 CREDITS
+ =over 4
- =head2 CONTRIBUTORS
+ =item *
- Patches and code improvements were contributed by:
+ David Golden <xdg@xdg.me>
- Goro Fuji, Kazuhiro Osawa, Tokuhiro Matsuno, Kenichi Ishigaki, Ian
- Wells, Pedro Melo, Masayoshi Sekimura, Matt S Trout (mst), squeeky,
- horus and Ingy dot Net.
+ =item *
- =head2 ACKNOWLEDGEMENTS
+ Helmut Wollmersdorfer <helmut@wollmersdorfer.at>
- Bug reports, suggestions and feedbacks were sent by, or general
- acknowledgement goes to:
+ =item *
- 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.
+ Kenichi Ishigaki <ishigaki@cpan.org>
- =head1 COMMUNITY
+ =item *
- =over 4
+ Shoichi Kaji <skaji@cpan.org>
- =item L<http://github.com/miyagawa/cpanminus> - source code repository, issue tracker
+ =item *
- =item L<irc://irc.perl.org/#cpanm> - discussions about cpanm and its related tools
+ Tatsuhiko Miyagawa <miyagawa@bulknews.net>
=back
- =head1 NO WARRANTY
+ =head1 COPYRIGHT AND LICENSE
- 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.
+ This software is Copyright (c) 2013 by David Golden.
- =head1 SEE ALSO
+ This is free software, licensed under:
- L<CPAN> L<CPANPLUS> L<pip>
+ The Apache License, Version 2.0, January 2004
=cut
-
- 1;
-APP_CPANMINUS
+CPAN_COMMON_INDEX
-$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 -`.
+$fatpacked{"CPAN/Common/Index/LocalPackage.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_COMMON_INDEX_LOCALPACKAGE';
+ use 5.008001;
+ use strict;
+ use warnings;
- # DO NOT EDIT -- this is an auto generated file
+ package CPAN::Common::Index::LocalPackage;
+ # ABSTRACT: Search index via custom local CPAN package flatfile
- # 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;
+ our $VERSION = '0.010';
- $fatpacked{"App/cpanminus.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_CPANMINUS';
- package App::cpanminus;
- our $VERSION = "1.7043";
-
- =encoding utf8
-
- =head1 NAME
-
- App::cpanminus - get, unpack, build and install modules from CPAN
-
- =head1 SYNOPSIS
-
- cpanm Module
-
- Run C<cpanm -h> or C<perldoc cpanm> 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<cpanm> 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<cpanm> to your bin directory like
- C</usr/local/bin> and you'll need the C<--sudo> option to write to
- the directory, unless you configured C<INSTALL_BASE> with L<local::lib>.
-
- =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<perlbrew> 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<cpanm> 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<curl> 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<https://git.io/cpanm>
-
- =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<http://cpanmetadb.plackperl.org/>.
- 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<http://metacpan.org/> using its search 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<cpanm>, and read more about the privacy policy
- about this data collection at L<http://cpanmetadb.plackperl.org/#privacy>
-
- Fetched files are unpacked in C<~/.cpanm> and automatically cleaned up
- periodically. You can configure the location of this with the
- C<PERL_CPANM_HOME> 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<PERL_MM_OPT> and C<PERL_MB_OPT>).
-
- By default, it installs to the site_perl directory that belongs to
- your perl. You can see the locations for that by running C<perl -V>
- and it will be likely something under C</opt/local/perl/...> 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<perl5> directory under your home
- directory.
-
- To avoid this, run C<cpanm> 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<PERL_MM_USE_DEFAULT> 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<CPAN> and L<CPANPLUS>?
-
- Most likely not. Here are the things that cpanm doesn't do by
- itself.
-
- If you need these features, use L<CPAN>, L<CPANPLUS> or the standalone
- tools that are mentioned.
-
- =over 4
-
- =item *
-
- CPAN testers reporting. See L<App::cpanminus::reporter>
-
- =item *
-
- Building RPM packages from CPAN modules
-
- =item *
-
- Listing the outdated modules that needs upgrading. See L<App::cpanoutdated>
-
- =item *
-
- Showing the changes of the modules you're about to upgrade. See L<cpan-listchanges>
-
- =item *
-
- Patching CPAN modules with distroprefs.
-
- =back
-
- See L<cpanm> or C<cpanm -h> to see what cpanminus I<can> do :)
-
- =head1 COPYRIGHT
-
- Copyright 2010- Tatsuhiko Miyagawa
-
- The standalone executable contains the following modules embedded.
-
- =over 4
-
- =item L<CPAN::DistnameInfo> Copyright 2003 Graham Barr
-
- =item L<local::lib> Copyright 2007-2009 Matt S Trout
-
- =item L<HTTP::Tiny> Copyright 2011 Christian Hansen
-
- =item L<Module::Metadata> Copyright 2001-2006 Ken Williams. 2010 Matt S Trout
-
- =item L<version> Copyright 2004-2010 John Peacock
-
- =item L<JSON::PP> Copyright 2007-2011 by Makamaka Hannyaharamitu
-
- =item L<CPAN::Meta>, L<CPAN::Meta::Requirements> Copyright (c) 2010 by David Golden and Ricardo Signes
-
- =item L<CPAN::Meta::YAML> Copyright 2010 Adam Kennedy
-
- =item L<File::pushd> 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<http://github.com/miyagawa/cpanminus> - source code repository, issue tracker
-
- =item L<irc://irc.perl.org/#cpanm> - discussions about cpanm and its related tools
-
- =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<CPAN> L<CPANPLUS> L<pip>
-
- =cut
-
- 1;
- APP_CPANMINUS
+ use parent 'CPAN::Common::Index::Mirror';
- $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
+ use Class::Tiny qw/source/;
- $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,
- with_configure => 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-configure' => \$self->{with_configure},
- 'without-configure' => sub { $self->{with_configure} = 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 <<DIE;
- It appears your cpanm executable was installed via `perlbrew install-cpanm`.
- cpanm --self-upgrade won't upgrade the version of cpanm you're running.
-
- Run the following command to get it upgraded.
-
- perlbrew install-cpanm
-
- DIE
- } else {
- die <<DIE;
- You are running cpanm from the path where your current perl won't install executables to.
- Because of that, cpanm --self-upgrade won't upgrade the version of cpanm you're running.
-
- cpanm path : $0
- Install path : $Config{installsitebin}
-
- It means you either installed cpanm globally with system perl, or use distro packages such
- as rpm or apt-get, and you have to use them again to upgrade cpanm.
- DIE
- }
- }
- }
-
- sub check_libs {
- my $self = shift;
- return if $self->{_checked}++;
- $self->bootstrap_local_lib;
- }
-
- sub setup_verify {
- my $self = shift;
-
- my $has_modules = eval { require Module::Signature; require Digest::SHA; 1 };
- $self->{cpansign} = $self->which('cpansign');
-
- unless ($has_modules && $self->{cpansign}) {
- warn "WARNING: Module::Signature and Digest::SHA is required for distribution verifications.\n";
- $self->{verify} = 0;
- }
- }
-
- sub parse_module_args {
- my($self, $module) = @_;
-
- # 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 <<USAGE;
- Usage: cpanm [options] Module [...]
-
- Try `cpanm --help` or `man cpanm` for more options.
- USAGE
- return;
- }
-
- print <<HELP;
- Usage: cpanm [options] Module [...]
-
- Options:
- -v,--verbose Turns on chatty output
- -q,--quiet Turns off the most output
- --interactive Turns on interactive configure (required for Task:: modules)
- -f,--force force install
- -n,--notest Do not run unit tests
- --test-only Run tests only, do not install
- -S,--sudo sudo to run install commands
- --installdeps Only install dependencies
- --showdeps Only display direct dependencies
- --reinstall Reinstall the distribution even if you already have the latest version installed
- --mirror Specify the base URL for the mirror (e.g. http://cpan.cpantesters.org/)
- --mirror-only Use the mirror's index file instead of the CPAN Meta DB
- -M,--from Use only this mirror base URL and its index file
- --prompt Prompt when configure/build/test fails
- -l,--local-lib Specify the install base to install modules
- -L,--local-lib-contained Specify the install base to install all non-core modules
- --self-contained Install all non-core modules, even if they're already installed.
- --auto-cleanup Number of days that cpanm's work directories expire in. Defaults to 7
-
- Commands:
- --self-upgrade upgrades itself
- --info Displays distribution info on CPAN
- --look Opens the distribution with your SHELL
- -U,--uninstall Uninstalls the modules (EXPERIMENTAL)
- -V,--version Displays software version
-
- Examples:
-
- 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 -M https://cpan.metacpan.org App::perlbrew # use only this secure mirror and its index
-
- You can also specify the default options in PERL_CPANM_OPT environment variable in the shell rc:
-
- export PERL_CPANM_OPT="--prompt --reinstall -l ~/perl --mirror http://cpan.cpantesters.org"
-
- Type `man cpanm` or `perldoc cpanm` for the more detailed explanation of the options.
-
- HELP
-
- return 1;
- }
-
- sub _writable {
- my $dir = shift;
- my @dir = File::Spec->splitdir($dir);
- while (@dir) {
- $dir = File::Spec->catdir(@dir);
- if (-e $dir) {
- return -w _;
- }
- pop @dir;
- }
-
- return;
- }
-
- sub maybe_abs {
- my($self, $lib) = @_;
- if ($lib eq '_' or $lib =~ /^~/ or File::Spec->file_name_is_absolute($lib)) {
- return $lib;
- } else {
- return File::Spec->canonpath(File::Spec->catdir(Cwd::cwd(), $lib));
- }
- }
-
- sub local_lib_target {
- my($self, $root) = @_;
- # 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(<<DIAG, 1);
- !
- ! Can't write to $Config{installsitelib} and $Config{installsitebin}: Installing modules to $ENV{HOME}/perl5
- ! To turn off this warning, you have to do one of the following:
- ! - run me as a root or with --sudo option (to install to $Config{installsitelib} and $Config{installsitebin})
- ! - Configure local::lib in your existing shell to set PERL_MM_OPT etc.
- ! - Install local::lib by running the following commands
- !
- ! cpanm --local-lib=~/perl5 local::lib && eval \$(perl -I ~/perl5/lib/perl5/ -Mlocal::lib)
- !
- DIAG
- sleep 2;
- }
-
- sub upgrade_toolchain {
- my($self, $config_deps) = @_;
-
- my %deps = map { $_->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(<<WARN, 1) if $base =~ /\s/;
- WARNING: Your lib directory name ($base) contains a space in it. It's known to cause issues with perl builder tools such as local::lib and MakeMaker. You're recommended to rename your directory.
- WARN
-
- local $SIG{__WARN__} = sub { }; # catch 'Attempting to write ...'
- local::lib->setup_env_hash_for($base, 0);
- }
-
- sub setup_local_lib {
- my($self, $base, $no_env) = @_;
- $base = undef if $base eq '_';
-
- require local::lib;
- {
- local $0 = 'cpanm'; # 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 = <STDIN>;
- 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";
- }
-
- local $ENV{PERL_USE_UNSAFE_INC} = 1
- unless exists $ENV{PERL_USE_UNSAFE_INC};
-
- $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};
-
- local $ENV{PERL_USE_UNSAFE_INC} = 1
- unless exists $ENV{PERL_USE_UNSAFE_INC};
-
- $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;
-
- local $ENV{PERL_USE_UNSAFE_INC} = 1
- unless exists $ENV{PERL_USE_UNSAFE_INC};
-
- 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;
- }
-
- local $ENV{PERL_USE_UNSAFE_INC} = 1
- unless exists $ENV{PERL_USE_UNSAFE_INC};
-
- 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(<<DIAG, 1);
- $module is not found in the following directories and can't be uninstalled.
-
- @{[ join(" \n", map " $_", @inc) ]}
-
- DIAG
- return;
- }
-
- my @uninst_files = $self->uninstall_target($metadata, $packlist);
-
- $self->ask_permission($module, \@uninst_files) or return;
- $self->uninstall_files(@uninst_files, $packlist);
-
- $self->diag("Successfully uninstalled $module\n", 1);
-
- return 1;
- }
-
- sub packlists_containing {
- my($self, $module, $inc) = @_;
-
- require Module::Metadata;
- my $metadata = Module::Metadata->new_from_module($module, inc => $inc)
- or return;
-
- my $packlist;
- my $wanted = sub {
- return unless $_ eq '.packlist' && -f $_;
- for my $file ($self->unpack_packlist($File::Find::name)) {
- $packlist ||= $File::Find::name if $file eq $metadata->filename;
- }
- };
-
- {
- require File::pushd;
- my $pushd = File::pushd::pushd();
- my @search = grep -d $_, map File::Spec->catdir($_, 'auto'), @$inc;
- File::Find::find($wanted, @search);
- }
-
- return $metadata, $packlist;
- }
-
- sub uninstall_target {
- my($self, $metadata, $packlist) = @_;
-
- # If 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 <<EOF;
- package ModuleBuildSkipMan;
- CHECK {
- if (%Module::Build::) {
- no warnings 'redefine';
- *Module::Build::Base::ACTION_manpages = sub {};
- *Module::Build::Base::ACTION_docs = sub {};
- }
- }
- 1;
- EOF
- }
-
- sub core_version_for {
- my($self, $module) = @_;
-
- require Module::CoreList; # no fatpack
- unless (exists $Module::CoreList::version{$]+0}) {
- die sprintf("Module::CoreList %s (loaded from %s) doesn't seem to have entries for perl $]. " .
- "You're strongly recommended to upgrade Module::CoreList from CPAN.\n",
- $Module::CoreList::VERSION, $INC{"Module/CoreList.pm"});
- }
-
- unless (exists $Module::CoreList::version{$]+0}{$module}) {
- return -1;
- }
-
- return $Module::CoreList::version{$]+0}{$module};
- }
-
- sub search_inc {
- my $self = shift;
- $self->{search_inc} ||= do {
- # 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->merge_with_cpanfile($dist, \@config_deps);
-
- $self->upgrade_toolchain(\@config_deps);
-
- my $target = $dist->{meta}{name} ? "$dist->{meta}{name}-$dist->{meta}{version}" : $dist->{dir};
- {
- $self->install_deps_bailout($target, $dist->{dir}, $depth, @config_deps)
- or return;
- }
-
- $self->diag_progress("Configuring $target");
-
- my $configure_state = $self->configure_this($dist, $depth);
- $self->diag_ok($configure_state->{configured_ok} ? "OK" : "N/A");
-
- if ($dist->{cpanmeta} && $dist->{source} eq 'cpan') {
- $dist->{provides} = $dist->{cpanmeta}{provides} || $self->extract_packages($dist->{cpanmeta}, ".");
- }
-
- # 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;
- push @{$dist->{want_phases}}, 'configure' if $self->{with_configure} && $depth == 0;
-
- my @deps = $self->find_prereqs($dist);
- my $module_name = $self->find_module_name($configure_state) || $dist->{meta}{name};
- $module_name =~ s/-/::/g;
-
- if ($self->{showdeps}) {
- for my $dep (@config_deps, @deps) {
- print $dep->module, ($dep->version ? ("~".$dep->version) : ""), "\n";
- }
- return 1;
- }
-
- my $distname = $dist->{meta}{name} ? "$dist->{meta}{name}-$dist->{meta}{version}" : $stuff;
-
- my $walkup;
- if ($self->{scandeps}) {
- $walkup = $self->scandeps_append_child($dist);
- }
-
- $self->install_deps_bailout($distname, $dist->{dir}, $depth, @deps)
- or return;
-
- if ($self->{scandeps}) {
- unless ($configure_state->{configured_ok}) {
- my $diag = <<DIAG;
- ! Configuring $distname failed. See $self->{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);
- }
-
- $self->merge_with_cpanfile($dist, \@deps);
-
- return @deps;
- }
-
- sub merge_with_cpanfile {
- my($self, $dist, $deps) = @_;
-
- if ($self->{cpanfile_requirements} && !$dist->{cpanfile}) {
- for my $dep (@$deps) {
- $dep->merge_with($self->{cpanfile_requirements});
- }
- }
- }
-
- 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 $match;
- if ($dist->{module}) {
- $match = sub {
- my $meta = Module::Metadata->new_from_file($_[0]);
- $meta && ($meta->name eq $dist->{module});
- };
- } else {
- $match = sub { 1 };
- }
-
- my @files;
- File::Find::find({
- wanted => sub {
- push @files, File::Spec->rel2abs($_) if /\.pm$/i && $match->($_);
- },
- 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);
-
- my $source_mtime = (stat $file)[9];
-
- # Don't mirror a file that's already there (like the index)
- return 1 if -e $path && (stat $path)[9] >= $source_mtime;
-
- File::Copy::copy($file, $path);
-
- utime $source_mtime, $source_mtime, $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(?=-)
- )(?<![._-][vV])
- )+)(.*)
- $/xs or return ($file,undef,undef);
-
- if ($dist =~ /-undef\z/ and ! length $version) {
- $dist =~ s/-undef\z//;
- }
-
- # Remove potential -withoutworldwriteables suffix
- $version =~ s/-withoutworldwriteables$//;
-
- if ($version =~ /^(-[Vv].*)-(\d.*)/) {
-
- # Catch names like Unicode-Collate-Standard-V3_1_1-0.1
- # where the V3_1_1 is part of the distname
- $dist .= $1;
- $version = $2;
- }
-
- if ($version =~ /(.+_.*)-(\d.*)/) {
- # Catch names like Task-Deprecations5_14-1.00.tar.gz where the 5_14 is
- # part of the distname. However, names like libao-perl_0.03-1.tar.gz
- # should still have 0.03-1 as their version.
- $dist .= $1;
- $version = $2;
- }
-
- # Normalize the Dist.pm-1.23 convention which CGI.pm and
- # a few others use.
- $dist =~ s{\.pm$}{};
-
- $version = $1
- if !length $version and $dist =~ s/-(\d+\w)$//;
-
- $version = $1 . $version
- if $version =~ /^\d+$/ and $dist =~ s/-(\w+)$//;
-
- if ($version =~ /\d\.\d/) {
- $version =~ s/^[-_.]+//;
- }
- else {
- $version =~ s/^[-_]+//;
- }
-
- my $dev;
- if (length $version) {
- if ($file =~ /^perl-?\d+\.(\d+)(?:\D(\d+))?(-(?:TRIAL|RC)\d+)?$/) {
- $dev = 1 if (($1 > 6 and $1 & 1) or ($2 and $2 >= 50)) or $3;
- }
- elsif ($version =~ /\d\D\d+_\d/ or $version =~ /-TRIAL/) {
- $dev = 1;
- }
- }
- else {
- $version = undef;
- }
-
- ($dist, $version, $dev);
- }
-
- sub new {
- my $class = shift;
- my $distfile = shift;
-
- $distfile =~ s,//+,/,g;
-
- my %info = ( pathname => $distfile );
-
- ($info{filename} = $distfile) =~ s,^(((.*?/)?authors/)?id/)?([A-Z])/(\4[A-Z])/(\5[-A-Z0-9]*)/,,
- and $info{cpanid} = $6;
-
- if ($distfile =~ m,([^/]+)\.(tar\.(?:g?z|bz2)|zip|tgz)$,i) { # 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<CPAN::DistnameInfo> uses heuristics that have been learnt by
- L<http://search.cpan.org/> 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<released> or C<developer>
-
- =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 <gbarr@pobox.com>
-
- =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
+ use Carp;
+ use File::Basename ();
+ use File::Copy ();
+ use File::Spec;
+ use File::stat ();
- $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<META.json> or, for
- #pod older distributions, F<META.yml>, which describes the distribution, its
- #pod contents, and the requirements for building and installing the distribution.
- #pod The data structure stored in the F<META.json> file is described in
- #pod L<CPAN::Meta::Spec>.
- #pod
- #pod CPAN::Meta provides a simple class to represent this distribution metadata (or
- #pod I<distmeta>), 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<authors> and C<licenses> methods may also be called as C<author> and
- #pod C<license>, 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<custom_keys> method and
- #pod particular keys may be retrieved with the C<custom> 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<new()>, except that C<generated_by> and C<meta-spec> fields
- #pod will be generated if not provided. This means the metadata structure is
- #pod assumed to otherwise follow the latest L<CPAN::Meta::Spec>.
- #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<CPAN::Meta> object, just
- #pod like C<new()>. 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<new()> but C<lazy_validation> 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<load_file()>.
- #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<load_file()>.
- #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<Parse::CPAN::Meta> to guess. In other respects it is identical to
- #pod C<load_file()>.
- #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<version>, which defaults to '2'. On Perl 5.8.1 or later, the file
- #pod is saved with UTF-8 encoding.
- #pod
- #pod For C<version> 2 (or higher), the filename should end in '.json'. L<JSON::PP>
- #pod is the default JSON backend. Using another JSON backend requires L<JSON> 2.5 or
- #pod later and you must set the C<$ENV{PERL_JSON_BACKEND}> to a supported alternate
- #pod backend like L<JSON::XS>.
- #pod
- #pod For C<version> less than 2, the filename should end in '.yml'.
- #pod L<CPAN::Meta::Converter> 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<meta_spec> 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<CPAN::Meta::Prereqs> 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<file> and C<directory> keys in the C<no_index> property of
- #pod the distmeta structure. Note that neither the version format nor
- #pod C<release_status> 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<package> and C<namespace> keys in the C<no_index>
- #pod property of the distmeta structure. Note that neither the version format nor
- #pod C<release_status> 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<CPAN::Meta::Feature> 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<CPAN::Meta::Feature> 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<version> 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<not> UTF-8 encoded.) It takes an optional hashref
- #pod of options. If the hashref contains a C<version> 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<version> greater than or equal to 2, the string will be serialized as
- #pod JSON. For C<version> less than 2, the string will be serialized as YAML. In
- #pod both cases, the same rules are followed as in the C<save()> method for choosing
- #pod a serialization backend.
- #pod
- #pod The serialized structure will include a C<x_serialization_backend> 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<META.json> or, for
- older distributions, F<META.yml>, which describes the distribution, its
- contents, and the requirements for building and installing the distribution.
- The data structure stored in the F<META.json> file is described in
- L<CPAN::Meta::Spec>.
-
- CPAN::Meta provides a simple class to represent this distribution metadata (or
- I<distmeta>), 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<new()>, except that C<generated_by> and C<meta-spec> fields
- will be generated if not provided. This means the metadata structure is
- assumed to otherwise follow the latest L<CPAN::Meta::Spec>.
-
- =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<CPAN::Meta> object, just
- like C<new()>. It will die if the deserialized version fails to validate
- against its stated specification version.
-
- It takes the same options as C<new()> but C<lazy_validation> 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<load_file()>.
-
- =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<load_file()>.
-
- =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<Parse::CPAN::Meta> to guess. In other respects it is identical to
- C<load_file()>.
-
- =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<version>, which defaults to '2'. On Perl 5.8.1 or later, the file
- is saved with UTF-8 encoding.
-
- For C<version> 2 (or higher), the filename should end in '.json'. L<JSON::PP>
- is the default JSON backend. Using another JSON backend requires L<JSON> 2.5 or
- later and you must set the C<$ENV{PERL_JSON_BACKEND}> to a supported alternate
- backend like L<JSON::XS>.
-
- For C<version> less than 2, the filename should end in '.yml'.
- L<CPAN::Meta::Converter> 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<meta_spec> 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<CPAN::Meta::Prereqs> 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<file> and C<directory> keys in the C<no_index> property of
- the distmeta structure. Note that neither the version format nor
- C<release_status> 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<package> and C<namespace> keys in the C<no_index>
- property of the distmeta structure. Note that neither the version format nor
- C<release_status> are considered.
-
- =head2 features
-
- my @feature_objects = $meta->features;
-
- This method returns a list of L<CPAN::Meta::Feature> 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<CPAN::Meta::Feature> 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<version> 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<not> UTF-8 encoded.) It takes an optional hashref
- of options. If the hashref contains a C<version> 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<version> greater than or equal to 2, the string will be serialized as
- JSON. For C<version> less than 2, the string will be serialized as YAML. In
- both cases, the same rules are followed as in the C<save()> method for choosing
- a serialization backend.
-
- The serialized structure will include a C<x_serialization_backend> 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<authors> and C<licenses> methods may also be called as C<author> and
- C<license>, 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<custom_keys> method and
- particular keys may be retrieved with the C<custom> 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<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta>
-
- 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<CPAN::Meta::Converter>
-
- =item *
-
- L<CPAN::Meta::Validator>
-
- =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<https://github.com/Perl-Toolchain-Gang/CPAN-Meta/issues>.
- 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<https://github.com/Perl-Toolchain-Gang/CPAN-Meta>
-
- git clone https://github.com/Perl-Toolchain-Gang/CPAN-Meta.git
-
- =head1 AUTHORS
-
- =over 4
-
- =item *
-
- David Golden <dagolden@cpan.org>
-
- =item *
-
- Ricardo Signes <rjbs@cpan.org>
-
- =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 <ansgar@cpan.org>
-
- =item *
-
- Avar Arnfjord Bjarmason <avar@cpan.org>
-
- =item *
-
- Christopher J. Madsen <cjm@cpan.org>
-
- =item *
-
- Chuck Adams <cja987@gmail.com>
-
- =item *
-
- Cory G Watson <gphat@cpan.org>
-
- =item *
-
- Damyan Ivanov <dam@cpan.org>
-
- =item *
-
- Eric Wilhelm <ewilhelm@cpan.org>
-
- =item *
-
- Graham Knop <haarg@haarg.org>
-
- =item *
-
- Gregor Hermann <gregoa@debian.org>
-
- =item *
-
- Karen Etheridge <ether@cpan.org>
-
- =item *
-
- Kenichi Ishigaki <ishigaki@cpan.org>
-
- =item *
-
- Ken Williams <kwilliams@cpan.org>
-
- =item *
-
- Lars Dieckow <daxim@cpan.org>
-
- =item *
-
- Leon Timmermans <leont@cpan.org>
-
- =item *
-
- majensen <maj@fortinbras.us>
-
- =item *
-
- Mark Fowler <markf@cpan.org>
-
- =item *
-
- Matt S Trout <mst@shadowcat.co.uk>
-
- =item *
-
- Michael G. Schwern <mschwern@cpan.org>
-
- =item *
-
- mohawk2 <mohawk2@users.noreply.github.com>
-
- =item *
-
- moznion <moznion@gmail.com>
-
- =item *
-
- Niko Tyni <ntyni@debian.org>
-
- =item *
-
- Olaf Alders <olaf@wundersolutions.com>
-
- =item *
-
- Olivier Mengué <dolmen@cpan.org>
-
- =item *
-
- Randy Sims <randys@thepierianspring.org>
-
- =item *
-
- Tomohiro Hosaka <bokutin@bokut.in>
-
- =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
+ #pod =attr source (REQUIRED)
+ #pod
+ #pod Path to a local file in the form of 02packages.details.txt. It may
+ #pod be compressed with a ".gz" suffix or it may be uncompressed.
+ #pod
+ #pod =attr cache
+ #pod
+ #pod Path to a local directory to store a (possibly uncompressed) copy
+ #pod of the source index. Defaults to a temporary directory if not
+ #pod specified.
+ #pod
+ #pod =cut
- $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<CPAN::Meta::Requirements|CPAN::Meta::Requirements> 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<CPAN::Meta::Prereqs> or L<CPAN::Meta> 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<CPAN::Meta::Requirements|CPAN::Meta::Requirements> 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<CPAN::Meta spec|CPAN::Meta::Spec>. C<$type> must be a relationship as defined by the same spec. C<$meta> should be a L<CPAN::Meta::Prereqs> or L<CPAN::Meta> object.
-
- =head1 SEE ALSO
-
- =over 4
-
- =item * L<Test::CheckDeps|Test::CheckDeps>
-
- =item * L<CPAN::Meta|CPAN::Meta>
-
- =for comment # vi:noet:sts=2:sw=2:ts=2
-
- =back
-
- =head1 AUTHOR
-
- Leon Timmermans <leont@cpan.org>
-
- =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
+ sub BUILD {
+ my $self = shift;
- $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 || "<dev>");
-
- return $sig unless defined $gen and length $gen;
- return $gen if $gen =~ /\Q$sig/;
- return "$gen, $sig";
- }
-
- sub _listify { ! defined $_[0] ? undef : ref $_[0] eq 'ARRAY' ? $_[0] : [$_[0]] }
-
- sub _prefix_custom {
- my $key = shift;
- $key =~ s/^(?!x_) # Unless it already starts with x_
- (?: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};
+ my $file = $self->source;
+ if ( !defined $file ) {
+ Carp::croak("'source' parameter must be provided");
}
- 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 '<undef>' );
-
- 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 '<undef>' ) {
- $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};
+ elsif ( !-f $file ) {
+ Carp::croak("index file '$file' does not exist");
}
+
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<default_version> 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<meta-spec> 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<convert> 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<version> -- 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<author> 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<license> field will result in a C<license>
- #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<default_version> 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<meta-spec> field.
-
- =head2 convert
-
- my $new_struct = $cmc->convert( version => "2" );
-
- Returns a new hash reference with the metadata converted to a different form.
- C<convert> will die if any conversion/standardization still results in an
- invalid structure.
-
- Valid parameters include:
-
- =over
-
- =item *
-
- C<version> -- 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<author> 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<license> field will result in a C<license>
- 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<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta>
-
- 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 <dagolden@cpan.org>
-
- =item *
-
- Ricardo Signes <rjbs@cpan.org>
-
- =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<META.json> (or F<META.yml>)
- #pod file.
- #pod
- #pod For the most part, this class will only be used when operating on the result of
- #pod the C<feature> or C<features> methods on a L<CPAN::Meta> 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<optional_feature> entry in the
- #pod distmeta. It must contain entries for C<description> and C<prereqs>.
- #pod
- #pod =cut
-
- sub new {
- my ($class, $identifier, $spec) = @_;
-
- my %guts = (
- identifier => $identifier,
- description => $spec->{description},
- prereqs => CPAN::Meta::Prereqs->new($spec->{prereqs}),
+ sub cached_package {
+ my ($self) = @_;
+ my $package = File::Spec->catfile(
+ $self->cache, File::Basename::basename($self->source)
);
-
- 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<CPAN::Meta::Prereqs>
- #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<META.json> (or F<META.yml>)
- file.
-
- For the most part, this class will only be used when operating on the result of
- the C<feature> or C<features> methods on a L<CPAN::Meta> 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<optional_feature> entry in the
- distmeta. It must contain entries for C<description> and C<prereqs>.
-
- =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<CPAN::Meta::Prereqs>
- object.
-
- =head1 BUGS
-
- Please report any bugs or feature using the CPAN Request Tracker.
- Bugs can be submitted through the web interface at
- L<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta>
-
- 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 <dagolden@cpan.org>
-
- =item *
-
- Ricardo Signes <rjbs@cpan.org>
-
- =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<CPAN::Meta::Spec>.
-
- 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<phase> (configure, build, test, runtime, etc.) and I<relationship>
- (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 <dagolden@cpan.org>
-
- =item *
-
- Ricardo Signes <rjbs@cpan.org>
-
- =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<version>, declaring the version of the meta-spec that must be
- used for the merge. It can optionally take an C<extra_mappings> 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 <dagolden@cpan.org>
-
- =item *
-
- Ricardo Signes <rjbs@cpan.org>
-
- =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
+ $package =~ s/\.gz$//;
+ $self->refresh_index unless -r $package;
+ return $package;
+ }
- $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<CPAN::Meta::Prereqs>.
- #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<prereqs> field described in L<CPAN::Meta::Spec>, 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<CPAN::Meta::Requirements> 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<CPAN::Meta::Requirements> 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<version> objects inside it.
- #pod
- #pod =cut
-
- sub as_string_hash {
+ sub refresh_index {
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<finalize> 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<CPAN::Meta::Prereqs>.
-
- =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<prereqs> field described in L<CPAN::Meta::Spec>, 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<CPAN::Meta::Requirements> 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<CPAN::Meta::Requirements> 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<version> 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<finalize> 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<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta>
-
- 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 <dagolden@cpan.org>
-
- =item *
-
- Ricardo Signes <rjbs@cpan.org>
-
- =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<META.yml> or F<META.json> files in CPAN distributions,
- #pod and as defined by L<CPAN::Meta::Spec>;
- #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<bad_version_hook> -- 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";
+ my $source = $self->source;
+ my $basename = File::Basename::basename($source);
+ if ( $source =~ /\.gz$/ ) {
+ Carp::croak "can't load gz source files without IO::Uncompress::Gunzip\n"
+ unless $CPAN::Common::Index::Mirror::HAS_IO_UNCOMPRESS_GUNZIP;
+ ( my $uncompressed = $basename ) =~ s/\.gz$//;
+ $uncompressed = File::Spec->catfile( $self->cache, $uncompressed );
+ if ( !-f $uncompressed
+ or File::stat::stat($source)->mtime > File::stat::stat($uncompressed)->mtime ) {
+ no warnings 'once';
+ IO::Uncompress::Gunzip::gunzip( map { "$_" } $source, $uncompressed )
+ or Carp::croak "gunzip failed: $IO::Uncompress::Gunzip::GunzipError\n";
}
- }
- }
-
- # 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<exactly> 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<CPAN::Meta::Spec> 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</accepts_module> 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/;
+ my $dest = File::Spec->catfile( $self->cache, $basename );
+ File::Copy::copy($source, $dest)
+ if !-e $dest || File::stat::stat($source)->mtime > File::stat::stat($dest)->mtime;
}
-
return 1;
- }
-
- #pod =method is_finalized
- #pod
- #pod This method returns true if the requirements have been finalized by having the
- #pod C<finalize> 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<if> 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<CPAN::Meta::Spec> 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<CPAN::Meta::Spec/Version Ranges>. 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<E<gt>=>). 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</new>
- #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<META.yml> or F<META.json> files in CPAN distributions,
- and as defined by L<CPAN::Meta::Spec>;
- 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<bad_version_hook> -- 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<exactly> 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<CPAN::Meta::Spec> 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</accepts_module> 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<finalize> method called on them.
-
- =head2 finalize
-
- This method marks the requirements finalized. Subsequent attempts to change
- the requirements will be fatal, I<if> 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<CPAN::Meta::Spec> 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<CPAN::Meta::Spec/Version Ranges>. 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<E<gt>=>). 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</new>
- 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<https://github.com/dagolden/CPAN-Meta-Requirements/issues>.
- 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<https://github.com/dagolden/CPAN-Meta-Requirements>
-
- git clone https://github.com/dagolden/CPAN-Meta-Requirements.git
-
- =head1 AUTHORS
-
- =over 4
-
- =item *
-
- David Golden <dagolden@cpan.org>
-
- =item *
-
- Ricardo Signes <rjbs@cpan.org>
-
- =back
-
- =head1 CONTRIBUTORS
-
- =for stopwords Ed J Karen Etheridge Leon Timmermans robario
-
- =over 4
-
- =item *
-
- Ed J <mohawk2@users.noreply.github.com>
-
- =item *
-
- Karen Etheridge <ether@cpan.org>
-
- =item *
-
- Leon Timmermans <fawaka@gmail.com>
-
- =item *
-
- robario <webmaster@robario.com>
-
- =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 <kwilliams@cpan.org>',
- 'Module-Build List <module-build@perl.org>', # 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<x>. 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<Class-Container>, C<libwww-perl>,
- or C<DBI>.
-
- =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<File::Spec> instead of
- F<File/Spec.pm>
-
- =item package
-
- This refers to a namespace declared with the Perl C<package> 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</STRUCTURE> 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<Boolean> is used to provide a true or false value. It B<must> be
- represented as a defined value.
-
- =head2 String
-
- A I<String> 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<List> is an ordered collection of zero or more data elements.
- Elements of a List may be of mixed types.
-
- Producers B<must> 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<must> consider a String as equivalent to a
- List of length 1.
-
- =head2 Map
-
- A I<Map> 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<License String> is a subtype of String with a restricted set of
- values. Valid values are described in detail in the description of
- the L</license> field.
-
- =head2 URL
-
- I<URL> 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<Version> 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</Version Formats> section.
-
- =head2 Version Range
-
- The I<Version Range> 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</Version Ranges> 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<custom keys> and B<must> 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<required>
- or I<optional> 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<Deprecated>. 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 <kwilliams@cpan.org>' ]
-
- (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 <email-address>
-
- This field provides a general contact list independent of other
- structured fields provided within the L</resources> field, such as
- C<bugtracker>. 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<Build.PL> or F<Makefile.PL> (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</Prerequisites for dynamically configured distributions> in the implementors'
- notes.
-
- This field explicitly B<does not> 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<version> is required.
-
- =over
-
- =item version
-
- This subkey gives the integer I<Version> of the CPAN Meta Spec against
- which the document was generated.
-
- =item url
-
- This is a I<URL> 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<https://metacpan.org/pod/CPAN::Meta::Spec>
-
- =item *
-
- C<http://search.cpan.org/perldoc?CPAN::Meta::Spec>
-
- =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<LWP::UserAgent> 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<version> field contains an underscore character, then
- C<release_status> B<must not> be "stable."
-
- The C<release_status> field B<must> 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<may> 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<abstract> 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<must not> 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<include> - see
- L</Indexing distributions a la PAUSE> in the implementors notes for more
- information.
-
- Valid subkeys are as follows:
-
- =over
-
- =item file
-
- A I<List> of relative paths to files. Paths B<must be> specified with
- unix conventions.
-
- =item directory
-
- A I<List> of relative paths to directories. Paths B<must be> specified
- with unix conventions.
-
- [ Note: previous editions of the spec had C<dir> instead of C<directory> ]
-
- =item package
-
- A I<List> of package names.
-
- =item namespace
-
- A I<List> of package namespaces, where anything below the namespace
- must be ignored, but I<not> the namespace itself.
-
- In the example above for C<no_index>, C<My::Module::Sample::Foo> would
- be ignored, but C<My::Module::Sample> 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<optional_features> 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<L</prereqs>> 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<must not> include C<configure> phase prereqs.
-
- =back
-
- Consumers B<must not> 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<prereqs> key using the same
- semantics. See L</Merging and Resolving Prerequisites> for details on
- merging prerequisites.
-
- I<Suggestion for disuse:> Because there is currently no way for a
- distribution to specify a dependency on an optional feature of another
- dependency, the use of C<optional_feature> is discouraged. Instead,
- create a separate, installable distribution that ensures the desired
- feature is available. For example, if C<Foo::Bar> has a C<Baz> feature,
- release a separate C<Foo-Bar-Baz> 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<configure>, C<build>, C<test>
- or C<runtime>. Values are Maps in which the keys name the type of
- prerequisite relationship such as C<requires>, C<recommends>, or
- C<suggests> and the value provides a set of prerequisite relations. The
- set of relations B<must> be specified as a Map of package names to
- version ranges.
-
- The full definition for this field is given in the L</Prereq Spec>
- 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<provides> 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<META.yml> or C<META.json>
- to claim a package for indexing without needing a C<*.pm>.
-
- =item version
-
- If it exists, this field must contains a I<Version> 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<URL>'s that relate to this distribution's license. As with the
- top-level C<license> 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<http://myrepo.example.com/> is ambiguous as to
- type, producers should provide a C<type> whenever a C<url> key is given.
- The C<type> field should be the name of the most common program used
- to work with the repository, e.g. C<git>, C<svn>, C<cvs>, C<darcs>,
- C<bzr> or C<hg>.
-
- =back
-
- =head2 DEPRECATED FIELDS
-
- =head3 build_requires
-
- I<(Deprecated in Spec 2)> [optional] {String}
-
- Replaced by C<prereqs>
-
- =head3 configure_requires
-
- I<(Deprecated in Spec 2)> [optional] {String}
-
- Replaced by C<prereqs>
-
- =head3 conflicts
-
- I<(Deprecated in Spec 2)> [optional] {String}
-
- Replaced by C<prereqs>
-
- =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<license> in C<resources>
-
- =head3 private
-
- I<(Deprecated in Spec 1.2)> [optional] {Map}
-
- This field has been renamed to L</"no_index">.
-
- =head3 recommends
-
- I<(Deprecated in Spec 2)> [optional] {String}
-
- Replaced by C<prereqs>
-
- =head3 requires
-
- I<(Deprecated in Spec 2)> [optional] {String}
-
- Replaced by C<prereqs>
-
- =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<must not> be serialized as C<1.2>. Version
- comparison should be delegated to the Perl L<version> module, version
- 0.80 or newer.
-
- Unless otherwise specified, version numbers B<must> appear in one of two
- formats:
-
- =over
-
- =item Decimal versions
-
- Decimal versions are regular "decimal numbers", with some limitations.
- They B<must> be non-negative and B<must> begin and end with a digit. A
- single underscore B<may> be included, but B<must> be between two digits.
- They B<must not> 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<should> be restricted to the
- range 0 to 999. The final component B<may> 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<at least> version 2.4
- must be present. To indicate that B<any> 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<may> use the operators E<lt> (less than),
- E<lt>= (less than or equal), E<gt> (greater than), E<gt>= (greater than
- or equal), == (equal), and != (not equal). For example, the
- specification C<E<lt> 2.0> means that any version of the prerequisite
- less than 2.0 is suitable.
-
- For more complicated situations, version specifications B<may> be AND-ed
- together using commas. The specification C<E<gt>= 1.2, != 1.5, E<lt>
- 2.0> indicates a version that must be B<at least> 1.2, B<less than> 2.0,
- and B<not equal to> 1.5.
-
- =head1 PREREQUISITES
-
- =head2 Prereq Spec
-
- The C<prereqs> key in the top-level metadata and within
- C<optional_features> define the relationship between a distribution and
- other packages. The prereq spec structure is a hierarchical data
- structure which divides prerequisites into I<Phases> of activity in the
- installation process and I<Relationships> that indicate how
- prerequisites should be resolved.
-
- For example, to specify that C<Data::Dumper> is C<required> during the
- C<test> 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<runtime> 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<build>
- requirements must also be available during the C<test> 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<runtime> 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<must> 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<must> be installed for proper completion of the
- phase.
-
- =item recommends
-
- Recommended dependencies are I<strongly> 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<conflicts> 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<optional_features>, 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<Version Ranges> 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<should> test whether prerequisites would result
- in installed module files being "downgraded" to an older version and
- B<may> 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<META.json>.
-
- In the past, the distribution metadata structure had been packed with
- distributions as F<META.yml>, a file in the YAML Tiny format (for which,
- see L<YAML::Tiny>). Tools that consume distribution metadata from disk
- should be capable of loading F<META.yml>, but should prefer F<META.json>
- 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<ExtUtils::MakeMaker> or L<Module::Metadata>. 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<version> 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<version> 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<eval> and the C<use> 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<dynamic_config> 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<inc>, C<xt>, or C<t> directories, or common 'mistake' directories such as
- C<perl5>.
-
- Or: If you're trying to be PAUSE-like, make sure you skip C<inc>, C<xt> and
- C<t> 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<http://www.cpan.org/>
-
- =item *
-
- JSON, L<http://json.org/>
-
- =item *
-
- YAML, L<http://www.yaml.org/>
-
- =item *
-
- L<CPAN>
-
- =item *
-
- L<CPANPLUS>
-
- =item *
-
- L<ExtUtils::MakeMaker>
-
- =item *
-
- L<Module::Build>
-
- =item *
-
- L<Module::Install>
-
- =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 <dagolden@cpan.org>
-
- =item *
-
- Ricardo Signes <rjbs@cpan.org>
-
- =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<meta-spec> field of the structure.
- #pod
- #pod =cut
-
- #--------------------------------------------------------------------------#
- # This code copied and adapted from Test::CPAN::Meta
- # by Barbie, <barbie@cpan.org> for Miss Barbell Productions,
- # L<http://www.missbarbell.co.uk>
- #--------------------------------------------------------------------------#
-
- #--------------------------------------------------------------------------#
- # 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 || "<undef>";
- if(defined $spec->{value}) {
- $spec->{value}->($self,'list',$value);
- } elsif(defined $spec->{'map'}) {
- $self->check_map($spec->{'map'},$value);
- } elsif(defined $spec->{'list'}) {
- $self->check_list($spec->{'list'},$value);
- } elsif ($spec->{':key'}) {
- $self->check_map($spec,$value);
- } else {
- $self->_error( "$spec_error associated with '$self->{stack}[-2]'" );
- }
- pop @{$self->{stack}};
- }
- }
-
- #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 = '<undef>' unless(defined $value);
- $self->_error( "'$value' for '$key' is not a valid version." );
- return 0;
- }
-
- sub version {
- my ($self,$key,$value) = @_;
- if(defined $value) {
- return 0 unless($value || $value =~ /0/);
- return 1 if($value =~ /^\s*((<|<=|>=|>|!=|==)\s*)?v?\d+((\.\d+((_|\.)\d+)?)?)/);
- } else {
- $value = '<undef>';
- }
- $self->_error( "'$value' for '$key' is not a valid version." );
- return 0;
- }
-
- sub boolean {
- my ($self,$key,$value) = @_;
- if(defined $value) {
- return 1 if($value =~ /^(0|1|true|false)$/);
- } else {
- $value = '<undef>';
- }
- $self->_error( "'$value' for '$key' is not a boolean value." );
- return 0;
- }
-
- my %v1_licenses = (
- 'perl' => 'http://dev.perl.org/licenses/',
- 'gpl' => 'http://www.opensource.org/licenses/gpl-license.php',
- 'apache' => 'http://apache.org/licenses/LICENSE-2.0',
- 'artistic' => 'http://opensource.org/licenses/artistic-license.php',
- 'artistic_2' => 'http://opensource.org/licenses/artistic-license-2.0.php',
- 'lgpl' => 'http://www.opensource.org/licenses/lgpl-license.php',
- 'bsd' => 'http://www.opensource.org/licenses/bsd-license.php',
- 'gpl' => 'http://www.opensource.org/licenses/gpl-license.php',
- 'mit' => 'http://opensource.org/licenses/mit-license.php',
- 'mozilla' => 'http://opensource.org/licenses/mozilla1.1.php',
- 'open_source' => undef,
- 'unrestricted' => undef,
- 'restrictive' => undef,
- 'unknown' => undef,
- );
-
- my %v2_licenses = map { $_ => 1 } qw(
- agpl_3
- apache_1_1
- apache_2_0
- artistic_1
- artistic_2
- bsd
- freebsd
- gfdl_1_2
- gfdl_1_3
- gpl_1
- gpl_2
- gpl_3
- lgpl_2_1
- lgpl_3_0
- mit
- mozilla_1_0
- mozilla_1_1
- openssl
- perl_5
- qpl_1_0
- ssleay
- sun
- zlib
- open_source
- restricted
- unrestricted
- unknown
- );
-
- sub license {
- my ($self,$key,$value) = @_;
- my $licenses = $self->{spec} < 2 ? \%v1_licenses : \%v2_licenses;
- if(defined $value) {
- return 1 if($value && exists $licenses->{$value});
- } else {
- $value = '<undef>';
- }
- $self->_error( "License '$value' is invalid" );
- return 0;
- }
-
- sub custom_1 {
- my ($self,$key) = @_;
- if(defined $key) {
- # 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 = '<undef>';
- }
- $self->_error( "Custom resource '$key' must be in CamelCase." );
- return 0;
- }
-
- sub custom_2 {
- my ($self,$key) = @_;
- if(defined $key) {
- return 1 if($key && $key =~ /^x_/i); # user defined
- } else {
- $key = '<undef>';
- }
- $self->_error( "Custom key '$key' must begin with 'x_' or 'X_'." );
- return 0;
- }
-
- sub identifier {
- my ($self,$key) = @_;
- if(defined $key) {
- return 1 if($key && $key =~ /^([a-z][_a-z]+)$/i); # spec 2.0 defined
- } else {
- $key = '<undef>';
- }
- $self->_error( "Key '$key' is not a legal identifier." );
- return 0;
- }
-
- sub module {
- my ($self,$key) = @_;
- if(defined $key) {
- return 1 if($key && $key =~ /^[A-Za-z0-9_]+(::[A-Za-z0-9_]+)*$/);
- } else {
- $key = '<undef>';
- }
- $self->_error( "Key '$key' is not a legal module name." );
- return 0;
- }
-
- my @valid_phases = qw/ configure build test runtime develop /;
- sub phase {
- my ($self,$key) = @_;
- if(defined $key) {
- return 1 if( length $key && grep { $key eq $_ } @valid_phases );
- return 1 if $key =~ /x_/i;
- } else {
- $key = '<undef>';
- }
- $self->_error( "Key '$key' is not a legal phase." );
- return 0;
- }
-
- my @valid_relations = qw/ requires recommends suggests conflicts /;
- sub relation {
- my ($self,$key) = @_;
- if(defined $key) {
- return 1 if( length $key && grep { $key eq $_ } @valid_relations );
- return 1 if $key =~ /x_/i;
- } else {
- $key = '<undef>';
- }
- $self->_error( "Key '$key' is not a legal prereq relationship." );
- return 0;
- }
-
- sub _error {
- my $self = shift;
- my $mess = shift;
-
- $mess .= ' ('.join(' -> ',@{$self->{stack}}).')' if($self->{stack});
- $mess .= " [Validation: $self->{spec}]";
-
- push @{$self->{errors}}, $mess;
- }
-
- 1;
-
- # 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<meta-spec> 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<http://rt.cpan.org/Dist/Display.html?Queue=CPAN-Meta>
-
- 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 <dagolden@cpan.org>
-
- =item *
-
- Ricardo Signes <rjbs@cpan.org>
-
- =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
+ sub search_authors { return }; # this package handles packages only
- $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<META.yml> and F<MYMETA.yml>. It should
- not be used for any other general YAML parsing or generation task.
-
- NOTE: F<META.yml> (and F<MYMETA.yml>) files should be UTF-8 encoded. Users are
- responsible for proper encoding and decoding. In particular, the C<read> and
- C<write> methods do B<not> support UTF-8 and should not be used.
-
- =head1 SUPPORT
-
- This module is currently derived from L<YAML::Tiny> 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<https://github.com/Perl-Toolchain-Gang/YAML-Tiny/issues>
-
- =head1 SEE ALSO
-
- L<YAML::Tiny>, L<YAML>, L<YAML::XS>
-
- =head1 AUTHORS
-
- =over 4
-
- =item *
-
- Adam Kennedy <adamk@cpan.org>
-
- =item *
-
- David Golden <dagolden@cpan.org>
-
- =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
+ 1;
- $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<YourModule.pm>:
-
- 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<YourModule>:
-
- use YourModule qw(frobnicate); # import listed symbols
- frobnicate ($left, $right) # calls YourModule::frobnicate
-
- Take a look at L</Good Practices> for some variants
- you will like to use in modern Perl code.
-
- =head1 DESCRIPTION
-
- The Exporter module implements an C<import> method which allows a module
- to export functions and variables to its users' namespaces. Many modules
- use Exporter rather than implementing their own C<import> method because
- Exporter provides a highly flexible interface, with an implementation optimised
- for the common case.
-
- Perl automatically calls the C<import> method when processing a
- C<use> statement for a module. Modules and C<use> are documented
- in L<perlfunc> and L<perlmod>. Understanding the concept of
- modules and how the C<use> 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<not> export method names!
-
- Do B<not> 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<YourModule::item_name> (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<perlmod>.
-
- =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<use YourModule;>
-
- This imports all the symbols from YourModule's C<@EXPORT> into the namespace
- of the C<use> statement.
-
- =item C<use YourModule ();>
-
- This causes perl to load your module but does not import any symbols.
-
- =item C<use YourModule qw(...);>
-
- 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<Module.pm> 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</^EXIT/> rather than C</EXIT/>.
-
- You can say C<BEGIN { $Exporter::Verbose=1 }> 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<require_version> method that
- simply delegates to C<VERSION>. Originally, before C<UNIVERSAL::VERSION>
- existed, Exporter would call C<require_version>.
-
- Since the C<UNIVERSAL::VERSION> 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<export_fail> 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<export_fail> method which
- simply returns the list unchanged.
-
- Uses for the C<export_fail> 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<CGI.pm> 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 C<AUTOLOAD>ed Constants
-
- Many modules make use of C<AUTOLOAD>ing for constant subroutines to
- avoid having to compile and waste memory on rarely used values (see
- L<perlsub> 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 C<AUTOLOAD>ed 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<BEGIN> 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<AUTOLOAD> for C<SO_LINGER> to take place before
- SO_LINGER is encountered later in C<My> package.
-
- If you are writing a package that C<AUTOLOAD>s, consider forcing
- an C<AUTOLOAD> for any constants explicitly imported by other packages
- or which are usually used when your package is C<use>d.
-
- =head1 Good Practices
-
- =head2 Declaring C<@EXPORT_OK> and Friends
-
- When using C<Exporter> with the standard C<strict> and C<warnings>
- pragmas, the C<our> 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<use vars> 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<require Exporter> 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<BEGIN> blocks. So the first part
- of the L</SYNOPSIS> 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<BEGIN> will assure that the loading of F<Exporter.pm>
- 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<Exporter> and inheriting, there
- are alternatives with the use of modules like C<base> and C<parent>.
-
- use base qw(Exporter);
- # or
- use parent qw(Exporter);
-
- Any of these statements are nice replacements for
- C<BEGIN { require Exporter; @ISA = qw(Exporter); }>
- with the same compile-time effect. The basic difference
- is that C<base> code interacts with declared C<fields>
- while C<parent> is a streamlined version of the older
- C<base> code to just establish the IS-A relationship.
-
- For more details, see the documentation and code of
- L<base> and L<parent>.
-
- Another thorough remedy to that runtime
- vs. compile-time trap is to use L<Exporter::Easy>,
- 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</Selecting What to Export>
- 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<not>
- export variable names. Just because C<Exporter> 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<Exporter> 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
+ # vim: ts=4 sts=4 sw=4 et:
- $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<chdir> that is easily and automatically
- reverted, similar to C<pushd> 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<chdir> 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<File::Temp>.
-
- For convenience, the object stringifies as the canonical form of the absolute
- pathname of the directory entered.
-
- B<Warning>: if you create multiple C<pushd> 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<pushd> and C<tempd> functions.
-
- =head2 pushd
-
- {
- my $dir = pushd( $target_directory );
- }
-
- Caches the current working directory, calls C<chdir> 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<pushd> will die with an error message.
-
- Can be given a hashref as an optional second argument. The only supported
- option is C<untaint_pattern>, 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<pushd> but automatically creates and calls C<chdir> to
- a temporary directory created by L<File::Temp>. Unlike normal L<File::Temp>
- cleanup which happens at the end of the program, this temporary directory is
- removed when the object is destroyed. (But also see C<preserve>.) A warning
- will be issued if the directory cannot be removed.
-
- As with C<pushd>, C<tempd> will die if C<chdir> fails.
-
- It may be given a single options hash that will be passed internally
- to C<pushd>.
-
- =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<preserve> 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<tempd> objects may be
- marked for cleanup. (Target directories to C<pushd> are always preserved.)
- C<preserve> returns true if the directory will be preserved, and false
- otherwise.
-
- =head1 SEE ALSO
-
- =over 4
-
- =item *
-
- L<File::chdir>
-
- =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<https://github.com/dagolden/File-pushd/issues>.
- 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<https://github.com/dagolden/File-pushd>
-
- git clone https://github.com/dagolden/File-pushd.git
-
- =head1 AUTHOR
-
- David Golden <dagolden@cpan.org>
-
- =head1 CONTRIBUTORS
-
- =over 4
-
- =item *
-
- Diab Jerius <djerius@cfa.harvard.edu>
-
- =item *
-
- Graham Ollis <plicease@cpan.org>
-
- =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
+ __END__
- $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<agent> —
- #pod A user-agent string (defaults to 'HTTP-Tiny/$VERSION'). If C<agent> — ends in a space character, the default user-agent string is appended.
- #pod * C<cookie_jar> —
- #pod An instance of L<HTTP::CookieJar> — or equivalent class that supports the C<add> and C<cookie_header> methods
- #pod * C<default_headers> —
- #pod A hashref of default headers to apply to requests
- #pod * C<local_address> —
- #pod The local IP address to bind to
- #pod * C<keep_alive> —
- #pod Whether to reuse the last connection (if for the same scheme, host and port) (defaults to 1)
- #pod * C<max_redirect> —
- #pod Maximum number of redirects allowed (defaults to 5)
- #pod * C<max_size> —
- #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<http_proxy> —
- #pod URL of a proxy server to use for HTTP connections (default is C<$ENV{http_proxy}> — if set)
- #pod * C<https_proxy> —
- #pod URL of a proxy server to use for HTTPS connections (default is C<$ENV{https_proxy}> — if set)
- #pod * C<proxy> —
- #pod URL of a generic proxy server for both HTTP and HTTPS connections (default is C<$ENV{all_proxy}> — if set)
- #pod * C<no_proxy> —
- #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<timeout> —
- #pod Request timeout in seconds (default is 60)
- #pod * C<verify_SSL> —
- #pod A boolean that indicates whether to validate the SSL certificate of an C<https> —
- #pod connection (default is false)
- #pod * C<SSL_options> —
- #pod A hashref of C<SSL_*> — options to pass through to L<IO::Socket::SSL>
- #pod
- #pod Passing an explicit C<undef> for C<proxy>, C<http_proxy> or C<https_proxy> will
- #pod prevent getting the corresponding proxies from the environment.
- #pod
- #pod Exceptions from C<max_size>, C<timeout> 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<keep_alive> 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</SSL SUPPORT> for more on the C<verify_SSL> and C<SSL_options> 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<request()> for the given method. The
- #pod URL must have unsafe characters escaped and international domain names encoded.
- #pod See C<request()> for valid options and a description of the response.
- #pod
- #pod The C<success> 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<POST> request and sends the key/value pairs from a
- #pod form data hash or array reference to the given URL with a C<content-type> of
- #pod C<application/x-www-form-urlencoded>. 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<www_form_urlencode> method for details on the encoding.
- #pod
- #pod The URL must have unsafe characters escaped and international domain names
- #pod encoded. See C<request()> for valid options and a description of the response.
- #pod Any C<content-type> header or content in the options hashref will be ignored.
- #pod
- #pod The C<success> 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<GET> 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<If-Modified-Since> header with the modification timestamp of the file. You
- #pod may specify a different C<If-Modified-Since> header yourself in the C<<
- #pod $options->{headers} >> hash.
- #pod
- #pod The C<success> 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<Last-Modified> 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<headers> —
- #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<content> —
- #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<trailer_callback> —
- #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<data_callback> —
- #pod A code reference that will be called for each chunks of the response
- #pod body received.
- #pod
- #pod The C<Host> header is generated from the URL in accordance with RFC 2616. It
- #pod is a fatal error to specify C<Host> in the C<headers> option. Other headers
- #pod may be ignored or overwritten if necessary for transport compliance.
- #pod
- #pod If the C<content> 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<content> option is the empty string, no C<content-type> or
- #pod C<content-length> headers will be generated.
- #pod
- #pod If the C<data_callback> 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<status> or C<headers>
- #pod received prior to the content body.)
- #pod
- #pod The C<request> method returns a hashref containing the response. The hashref
- #pod will have the following keys:
- #pod
- #pod =for :list
- #pod * C<success> —
- #pod Boolean indicating whether the operation returned a 2XX status code
- #pod * C<url> —
- #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<status> —
- #pod The HTTP status code of the response
- #pod * C<reason> —
- #pod The response phrase returned by the server
- #pod * C<content> —
- #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<headers> —
- #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<status> field will
- #pod contain 599, and the C<content> 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<x-www-form-urlencoded> 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<Net::SSLeay> and L<IO::Socket::SSL>.
- #pod When called as an object methods, if C<SSL_verify> is true or if C<SSL_verify_mode>
- #pod is set in C<SSL_options>, 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@]<host>:<port>/\n});
- }
-
- return ($scheme, $host, $port, $auth);
- }
-
- sub _create_proxy_tunnel {
- my ($self, $request, $handle) = @_;
-
- $handle->_assert_ssl;
-
- my $agent = exists($request->{headers}{'user-agent'})
- ? $request->{headers}{'user-agent'} : $self->{agent};
-
- my $connect_request = {
- method => 'CONNECT',
- uri => "$request->{host}:$request->{port}",
- headers => {
- host => "$request->{host}:$request->{port}",
- 'user-agent' => $agent,
- }
- };
-
- if ( $request->{headers}{'proxy-authorization'} ) {
- $connect_request->{headers}{'proxy-authorization'} =
- delete $request->{headers}{'proxy-authorization'};
- }
-
- $handle->write_request($connect_request);
- my $response;
- do { $response = $handle->read_response_header }
- until (substr($response->{status},0,1) ne '1');
-
- # 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<LWP::UserAgent>.
-
- It is more correct and more complete than L<HTTP::Lite>. It supports
- proxies and redirection. It also correctly resumes after EINTR.
-
- If L<IO::Socket::IP> 0.25 or later is installed, HTTP::Tiny will use it instead
- of L<IO::Socket::INET> for transparent support for both IPv4 and IPv6.
-
- Cookie support requires L<HTTP::CookieJar> 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<agent> — A user-agent string (defaults to 'HTTP-Tiny/$VERSION'). If C<agent> — ends in a space character, the default user-agent string is appended.
-
- =item *
-
- C<cookie_jar> — An instance of L<HTTP::CookieJar> — or equivalent class that supports the C<add> and C<cookie_header> methods
-
- =item *
-
- C<default_headers> — A hashref of default headers to apply to requests
-
- =item *
-
- C<local_address> — The local IP address to bind to
-
- =item *
-
- C<keep_alive> — Whether to reuse the last connection (if for the same scheme, host and port) (defaults to 1)
-
- =item *
-
- C<max_redirect> — Maximum number of redirects allowed (defaults to 5)
-
- =item *
-
- C<max_size> — Maximum response size in bytes (only when not using a data callback). If defined, responses larger than this will return an exception.
-
- =item *
-
- C<http_proxy> — URL of a proxy server to use for HTTP connections (default is C<$ENV{http_proxy}> — if set)
-
- =item *
-
- C<https_proxy> — URL of a proxy server to use for HTTPS connections (default is C<$ENV{https_proxy}> — if set)
-
- =item *
-
- C<proxy> — URL of a generic proxy server for both HTTP and HTTPS connections (default is C<$ENV{all_proxy}> — if set)
-
- =item *
-
- C<no_proxy> — 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<timeout> — Request timeout in seconds (default is 60)
-
- =item *
-
- C<verify_SSL> — A boolean that indicates whether to validate the SSL certificate of an C<https> — connection (default is false)
-
- =item *
-
- C<SSL_options> — A hashref of C<SSL_*> — options to pass through to L<IO::Socket::SSL>
-
- =back
-
- Passing an explicit C<undef> for C<proxy>, C<http_proxy> or C<https_proxy> will
- prevent getting the corresponding proxies from the environment.
-
- Exceptions from C<max_size>, C<timeout> 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<keep_alive> 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</SSL SUPPORT> for more on the C<verify_SSL> and C<SSL_options> 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<request()> for the given method. The
- URL must have unsafe characters escaped and international domain names encoded.
- See C<request()> for valid options and a description of the response.
-
- The C<success> 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<POST> request and sends the key/value pairs from a
- form data hash or array reference to the given URL with a C<content-type> of
- C<application/x-www-form-urlencoded>. 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<www_form_urlencode> method for details on the encoding.
-
- The URL must have unsafe characters escaped and international domain names
- encoded. See C<request()> for valid options and a description of the response.
- Any C<content-type> header or content in the options hashref will be ignored.
-
- The C<success> 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<GET> 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<If-Modified-Since> header with the modification timestamp of the file. You
- may specify a different C<If-Modified-Since> header yourself in the C<<
- $options->{headers} >> hash.
-
- The C<success> 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<Last-Modified> 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<headers> — 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<content> — 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<trailer_callback> — 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<data_callback> — A code reference that will be called for each chunks of the response body received.
-
- =back
-
- The C<Host> header is generated from the URL in accordance with RFC 2616. It
- is a fatal error to specify C<Host> in the C<headers> option. Other headers
- may be ignored or overwritten if necessary for transport compliance.
-
- If the C<content> 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<content> option is the empty string, no C<content-type> or
- C<content-length> headers will be generated.
-
- If the C<data_callback> 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<status> or C<headers>
- received prior to the content body.)
-
- The C<request> method returns a hashref containing the response. The hashref
- will have the following keys:
-
- =over 4
-
- =item *
-
- C<success> — Boolean indicating whether the operation returned a 2XX status code
-
- =item *
-
- C<url> — 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<status> — The HTTP status code of the response
-
- =item *
-
- C<reason> — The response phrase returned by the server
-
- =item *
-
- C<content> — 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<headers> — 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<status> field will
- contain 599, and the C<content> 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<x-www-form-urlencoded> 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<Net::SSLeay> and L<IO::Socket::SSL>.
- When called as an object methods, if C<SSL_verify> is true or if C<SSL_verify_mode>
- is set in C<SSL_options>, 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<https> connections are supported only if L<IO::Socket::SSL> 1.56 or
- greater and L<Net::SSLeay> 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<HTTP::Tiny::can_ssl()> utility function
- that returns boolean to see if the required modules are installed.
-
- An C<https> connection may be made via an C<http> proxy that supports the CONNECT
- command (i.e. RFC 2817). You may not proxy C<https> via a proxy that itself
- requires C<https> to communicate.
-
- SSL provides two distinct capabilities:
-
- =over 4
-
- =item *
-
- Encrypted communication channel
-
- =item *
-
- Verification of server identity
-
- =back
-
- B<By default, HTTP::Tiny does not verify server identity>.
-
- 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<CAcert.org|http://cacert.org>.
-
- 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<verify_SSL> 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<man-in-the-middle
- attack|http://en.wikipedia.org/wiki/Man-in-the-middle_attack>. If you are
- concerned about security, you should enable this option.
-
- Certificate verification requires a file containing trusted CA certificates.
- If the L<Mozilla::CA> 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<verify_SSL> is true and no CA certificate file
- is available.
-
- If you desire complete control over SSL connections, the C<SSL_options> attribute
- lets you provide a hash reference that will be passed through to
- C<IO::Socket::SSL::start_SSL()>, 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<SSL_options> 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<IO::Socket::SSL> documentation for
- details.
-
- =head1 PROXY SUPPORT
-
- HTTP::Tiny can proxy both C<http> and C<https> requests. Only Basic proxy
- authorization is supported and it must be provided as part of the proxy URL:
- C<http://user:pass@proxy.example.com/>.
-
- 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<REQUEST_METHOD> environment variable is set, then this might be a CGI
- process and C<HTTP_PROXY> would be set from the C<Proxy:> header, which is a
- security risk. If C<REQUEST_METHOD> is set, C<HTTP_PROXY> (the upper case
- variant only) is ignored.
-
- Tunnelling C<https> over an C<http> proxy using the CONNECT method is
- supported. If your proxy uses C<https> itself, you can not tunnel C<https>
- over it.
-
- Be warned that proxying an C<https> connection opens you to the risk of a
- man-in-the-middle attack by the proxy server.
-
- The C<no_proxy> 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<new> will override their corresponding
- environment variables.
-
- =head1 LIMITATIONS
-
- HTTP::Tiny is I<conditionally compliant> with the
- L<HTTP/1.1 specifications|http://www.w3.org/Protocols/>:
-
- =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<URI::Escape>,
- L<URI::_punycode> and L<Net::IDN::Encode>.
-
- =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<Expect> header.
- Unexpected C<1XX> responses are silently ignored as per the specification.
-
- =item *
-
- Only 'chunked' C<Transfer-Encoding> 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<HTTP::Tiny::UA>.
-
- =head1 SEE ALSO
-
- =over 4
-
- =item *
-
- L<HTTP::Tiny::UA> - Higher level UA features for HTTP::Tiny
-
- =item *
-
- L<HTTP::Thin> - HTTP::Tiny wrapper with L<HTTP::Request>/L<HTTP::Response> compatibility
-
- =item *
-
- L<HTTP::Tiny::Mech> - Wrap L<WWW::Mechanize> instance in HTTP::Tiny compatible interface
-
- =item *
-
- L<IO::Socket::IP> - Required for IPv6 support
-
- =item *
-
- L<IO::Socket::SSL> - Required for SSL support
-
- =item *
-
- L<LWP::UserAgent> - If HTTP::Tiny isn't enough for you, this is the "standard" way to do things
-
- =item *
-
- L<Mozilla::CA> - Required if you want to validate SSL certificates
-
- =item *
-
- L<Net::SSLeay> - 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<https://github.com/chansen/p5-http-tiny/issues>.
- 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<https://github.com/chansen/p5-http-tiny>
-
- git clone https://github.com/chansen/p5-http-tiny.git
-
- =head1 AUTHORS
-
- =over 4
-
- =item *
-
- Christian Hansen <chansen@cpan.org>
-
- =item *
-
- David Golden <dagolden@cpan.org>
-
- =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 <gardner@pythian.com>
-
- =item *
-
- Alessandro Ghedini <al3xbio@gmail.com>
-
- =item *
-
- Brad Gilbert <bgills@cpan.org>
-
- =item *
-
- Chris Nehren <apeiron@cpan.org>
-
- =item *
-
- Chris Weyl <cweyl@alumni.drew.edu>
-
- =item *
-
- Claes Jakobsson <claes@surfar.nu>
-
- =item *
-
- Clinton Gormley <clint@traveljury.com>
-
- =item *
-
- Dean Pearce <pearce@pythian.com>
-
- =item *
-
- Edward Zborowski <ed@rubensteintech.com>
-
- =item *
-
- James Raspass <jraspass@gmail.com>
-
- =item *
-
- Jeremy Mates <jmates@cpan.org>
-
- =item *
-
- Jess Robinson <castaway@desert-island.me.uk>
-
- =item *
-
- Lukas Eklund <leklund@gmail.com>
-
- =item *
-
- Martin J. Evans <mjegh@ntlworld.com>
-
- =item *
-
- Martin-Louis Bright <mlbright@gmail.com>
-
- =item *
-
- Mike Doherty <doherty@cpan.org>
-
- =item *
-
- Olaf Alders <olaf@wundersolutions.com>
-
- =item *
-
- Olivier Mengué <dolmen@cpan.org>
-
- =item *
-
- Petr Písař <ppisar@redhat.com>
-
- =item *
-
- Sören Kornetzki <soeren.kornetzki@delti.com>
-
- =item *
-
- Syohei YOSHIDA <syohex@gmail.com>
-
- =item *
-
- Tatsuhiko Miyagawa <miyagawa@bulknews.net>
-
- =item *
-
- Tom Hukins <tom@eborcom.com>
-
- =item *
-
- Tony Cook <tony@develop-help.com>
-
- =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
+ =pod
- $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 <jmuhlich [at] bitflood.org>
- 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<JSON::XS> 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<JSON::XS> 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<JSON::XS/A FEW NOTES ON UNICODE AND PERL> and L<UNICODE HANDLING ON PERLS>.
-
-
- =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<are> 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<JSON::XS/FUNCTIONAL INTERFACE>.
-
- =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<encode_json>: 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<true> and C<false> in Perl strings.
-
- =head2 JSON::PP::true
-
- Returns JSON true value which is blessed object.
- It C<isa> JSON::PP::Boolean object.
-
- =head2 JSON::PP::false
-
- Returns JSON false value which is blessed object.
- It C<isa> JSON::PP::Boolean object.
-
- =head2 JSON::PP::null
-
- Returns C<undef>.
-
- See L<MAPPING>, 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<decode_json> or C<JSON> module object
- with C<utf8> 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<decode> 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<cannot> use C<decode_json> nor C<JSON> module object with C<utf8> enable.
- Instead of them, you use C<JSON> module object with C<utf8> disable.
-
- $perl_scalar = $json->utf8(0)->decode( $unicode_json_text );
-
- Or C<encode 'utf8'> and C<decode_json>:
-
- $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<encode_json> or C<JSON> module object with C<utf8> 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<latin1> for perl
- (because it does not concern with your $encoding).
- You B<cannot> use C<encode_json> nor C<JSON> module object with C<utf8> enable.
- Instead of them, you use C<JSON> module object with C<utf8> 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<decode $encoding> all string values and C<encode_json>:
-
- $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<Encode>, L<perluniintro>.
-
-
- =head1 METHODS
-
- Basically, check to L<JSON> or L<JSON::XS>.
-
- =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<disabled>.
-
- 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<JSON::XS/OBJECT-ORIENTED INTERFACE>).
-
- In Perl 5.005, there is no character having high value (more than 255).
- See to L<UNICODE HANDLING ON PERLS>.
-
- 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<UNICODE HANDLING ON PERLS>.
-
- =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<UNICODE HANDLING ON PERLS>.)
-
- 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<indent>, C<space_before> and
- C<space_after> 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<indent_length> 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<encode> 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<encode> 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<encode> 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<encode> 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<decode> will accept some
- extensions to normal JSON syntax (see below). C<encode> will not be
- affected in anyway. I<Be aware that this option makes you accept invalid
- JSON texts as if they were valid!>. 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<decode> will only accept
- valid JSON texts.
-
- Currently accepted extensions are:
-
- =over 4
-
- =item * list items can have an end-comma
-
- JSON I<separates> 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<encode> method will output JSON objects
- by sorting their keys. This is adding a comparatively high overhead.
-
- If C<$enable> is false, then the C<encode> 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<sort_by>. See to C<JSON::PP OWN METHODS>.
-
- =head2 allow_nonref
-
- $json = $json->allow_nonref([$enable])
-
- $enabled = $json->get_allow_nonref
-
- If C<$enable> is true (or missing), then the C<encode> method can convert a
- non-reference into its corresponding string, number or null JSON value,
- which is an extension to RFC4627. Likewise, C<decode> will accept those JSON
- values instead of croaking.
-
- If C<$enable> is false, then the C<encode> method will croak if it isn't
- passed an arrayref or hashref, as JSON texts must either be an object
- or array. Likewise, C<decode> 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<allow_nonref>.
-
- 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<encode> method will not
- barf when it encounters a blessed reference. Instead, the value of the
- B<convert_blessed> option will decide whether C<null> (C<convert_blessed>
- disabled or no C<TO_JSON> method found) or a representation of the
- object (C<convert_blessed> enabled and C<TO_JSON> method found) is being
- encoded. Has no effect on C<decode>.
-
- If C<$enable> is false (the default), then C<encode> 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<encode>, upon encountering a
- blessed object, will check for the availability of the C<TO_JSON> 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<TO_JSON> method is found, the value of C<allow_blessed> will decide what
- to do.
-
- The C<TO_JSON> method may safely call die if it wants. If C<TO_JSON>
- returns other blessed objects, those will be handled in the same
- way. C<TO_JSON> must take care of not causing an endless recursion cycle
- (== crash) in this case. The name of C<TO_JSON> 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<to_json>
- function or method.
-
- This setting does not yet influence C<decode> in any way.
-
- If C<$enable> is false, then the C<allow_blessed> 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<decode> 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<not> C<undef>, 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<decode> 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<filter_json_object>, 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<filter_json_object>, 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<undef> but the empty list),
- the callback from C<filter_json_object> 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<filter_json_object>
- 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__" => <id> } >>
- into the corresponding C<< $WIDGET{<id>} >> 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<encode> or C<decode> 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<utf8::downgrade> to the returned string by C<encode>.
- See to L<utf8>.
-
- See to L<JSON::XS/OBJECT-ORIENTED INTERFACE>
-
- =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<JSON::XS/SSECURITY CONSIDERATIONS> 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<decode>
- 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<encode> (yet).
-
- If no argument is given, the limit check will be deactivated (same as when
- C<0> is specified).
-
- See L<JSON::XS/SSECURITY CONSIDERATIONS> 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<undef>) become JSON C<null> values.
- References to the integers C<0> and C<1> are converted into C<true> and C<false>.
-
- =head2 decode
-
- $perl_scalar = $json->decode($json_text)
-
- The opposite of C<encode>: 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<true> becomes
- C<1> (C<JSON::true>), C<false> becomes C<0> (C<JSON::false>) and
- C<null> becomes C<undef>.
-
- =head2 decode_prefix
-
- ($perl_scalar, $characters) = $json->decode_prefix($json_text)
-
- This works like the C<decode> 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<JSON::XS/INCREMENTAL PARSING>.
-
- 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<decode_prefix>
- 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<max_size>) 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<one> JSON object. If that is successful, it will return this
- object, otherwise it will return C<undef>. If there is a parse error,
- this method will croak just as C<decode> would do (one can then use
- C<incr_skip> 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<only> works when a preceding call to
- C<incr_parse> in I<scalar context> 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<will> 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<lvalue> 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<incr_parse>
- 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<JSON::XS/INCREMENTAL PARSING> for examples.
-
-
- =head1 JSON::PP OWN METHODS
-
- =head2 allow_singlequote
-
- $json = $json->allow_singlequote([$enable])
-
- If C<$enable> is true (or missing), then C<decode> 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<relaxed> 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<decode> will accept
- bare keys of JSON object that are invalid JSON format.
-
- As same as the C<relaxed> 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<decode> will convert
- the big integer Perl cannot handle as integer into a L<Math::BigInt>
- object and convert a floating number (any) into a L<Math::BigFloat>.
-
- On the contary, C<encode> converts C<Math::BigInt> objects and C<Math::BigFloat>
- objects into JSON numbers with C<allow_blessed> enable.
-
- $json->allow_nonref->allow_blessed->allow_bignum;
- $bigfloat = $json->decode('2.000000000000000000000000001');
- print $json->encode($bigfloat);
- # => 2.000000000000000000000000001
-
- See to L<JSON::XS/MAPPING> 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<decode> to these (except for \x2f).
- If C<$enable> is true (or missing), then C<decode> will accept these
- unescaped strings.
-
- $json->loose->decode(qq|["abc
- def"]|);
-
- See L<JSON::XS/SSECURITY CONSIDERATIONS>.
-
- =head2 escape_slash
-
- $json = $json->escape_slash([$enable])
-
- According to JSON Grammar, I<slash> (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<encode> 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<canonical> 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::PP>.
- JSON::XS and JSON::PP mapping mechanisms are almost equivalent.
-
- See to L<JSON::XS/MAPPING>.
-
- =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<JSON> 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<JSON> only guarantees precision up to but not including
- the leats significant bit.
-
- When C<allow_bignum> is enable, the big integers
- and the numeric can be optionally converted into L<Math::BigInt> and
- L<Math::BigFloat> objects.
-
- =item true, false
-
- These JSON atoms become C<JSON::PP::true> and C<JSON::PP::false>,
- 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<JSON::is_bool> function.
-
- print JSON::PP::true . "\n";
- => true
- print JSON::PP::true + 1;
- => 1
-
- ok(JSON::true eq '1');
- ok(JSON::true == 1);
-
- C<JSON> will install these missing overloading features to the backend modules.
-
-
- =item null
-
- A JSON null atom becomes C<undef> in Perl.
-
- C<JSON::PP::null> returns C<unddef>.
-
- =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<JSON>
- optionally sort the hash keys (determined by the I<canonical> 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<false> and C<true> atoms in JSON. You can
- also use C<JSON::false> and C<JSON::true> 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<undef>.
-
- =item blessed objects
-
- Blessed objects are not directly representable in JSON. See the
- C<allow_blessed> and C<convert_blessed> 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<convert_blessed>.
-
- =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<null> 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<allow_bignum> is enable,
- C<encode> converts C<Math::BigInt> objects and C<Math::BigFloat>
- objects into JSON numbers.
-
-
- =back
-
- =head1 UNICODE HANDLING ON PERLS
-
- If you do not know about Unicode on Perl well,
- please check L<JSON::XS/A FEW NOTES ON UNICODE AND PERL>.
-
- =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<U+3042> and C<U+12345>.
-
- Note that the versions from Perl 5.8.0 to 5.8.2, Perl built-in C<join> was broken,
- so JSON::PP wraps the C<join> 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<B> and C<E>, as C<chr> 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<HIRAGANA LETTER A>).
- And if it is represented in Unicode code point, C<U+3042>.
-
- Next,
-
- $json->decode('"\u3042"');
-
- We ordinary expect the returned value is a Unicode character C<U+3042>.
- But here is 5.005 world. This is C<0xE3 0x81 0x82>.
-
- $json->decode('"\ud808\udf45"');
-
- This is not a character C<U+12345> 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<JSON::XS>
-
- RFC4627 (L<http://www.ietf.org/rfc/rfc4627.txt>)
-
- =head1 AUTHOR
-
- Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
-
-
- =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
+ =encoding UTF-8
- $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<JSON::PP> for more info about this class.
-
- =cut
-
- use JSON::PP ();
- use strict;
-
- 1;
-
- =head1 AUTHOR
-
- This idea is from L<JSON::XS::Boolean> written by Marc Lehmann <schmorp[at]schmorp.de>
-
- =cut
-
- JSON_PP_BOOLEAN
+ =head1 NAME
- $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<cpanfile> 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<cpanfile> 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<CPAN::Meta>'s C<prereqs>, or L<CPAN::Meta::Prereqs>'
- C<as_string_hash>.
-
- # 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<CPAN::Meta::Prereqs> 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<CPAN::Meta::Feature>.
-
- =item prereqs_with(@identifiers), effective_prereqs(\@identifiers)
-
- Returns L<CPAN::Meta::Prereqs> 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<CPAN::Meta::Prereqs> 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<cpanfile> by calling
- C<to_string>. Beware B<this method will overwrite the existing
- cpanfile without any warning or backup>. 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<cpanfile>, L<CPAN::Meta>, L<CPAN::Meta::Spec>
-
- =cut
- MODULE_CPANFILE
+ CPAN::Common::Index::LocalPackage - Search index via custom local CPAN package flatfile
- $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(<<EVAL);
- package Module::CPANfile::Sandbox$file_id;
- no warnings;
- BEGIN { \$_environment->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
+ =head1 VERSION
- $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
+ version 0.010
- $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
+ =head1 SYNOPSIS
- $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
+ use CPAN::Common::Index::LocalPackage;
- $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 <equal sign> $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 C<eval>ed, as is traditional
- in the CPAN toolchain.
-
- =head1 CLASS METHODS
-
- =head2 C<< new_from_file($filename, collect_pod => 1) >>
-
- Constructs a C<Module::Metadata> object given the path to a file. Returns
- undef if the filename does not exist.
-
- C<collect_pod> 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<new_from_file>, 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<filename> 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<Module::Metadata> object given a module or package name.
- Returns undef if the module cannot be found.
-
- In addition to accepting the C<collect_pod> argument as described above,
- this method accepts a C<inc> 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<package_versions_from_directory>
- to generate a CPAN META C<provides> data structure. It takes key/value
- pairs. Valid option keys include:
-
- =over
-
- =item version B<(required)>
-
- Specifies which version of the L<CPAN::Meta::Spec> should be used as
- the format of the C<provides> 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<provides> changes.
-
- The C<version> option is required. If it is omitted or if
- an unsupported version is given, then C<provides> will throw an error.
-
- =item dir
-
- Directory to search recursively for F<.pm> files. May not be specified with
- C<files>.
-
- =item files
-
- Array reference of files to examine. May not be specified with C<dir>.
-
- =item prefix
-
- String to prepend to the C<file> field of the resulting output. This defaults
- to F<lib>, which is the common case for most CPAN distributions with their
- F<.pm> files in F<lib>. This option ensures the META information has the
- correct relative path even when the C<dir> or C<files> arguments are
- absolute or have relative paths from a location other than the distribution
- root.
-
- =back
-
- For example, given C<dir> of 'lib' and C<prefix> 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<DB> and C<main> packages are always omitted, as are any "private"
- packages that have leading underscores in the namespace (e.g.
- C<Foo::_private>)
-
- Note that the file path is relative to C<$dir> if that is specified.
- This B<must not> be used directly for CPAN META C<provides>. See
- the C<provides> 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<name> 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<main>). It is not
- filtered for C<DB>, C<main> or private packages the way the
- C<provides> 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<package> declarations, and does not take any
- ownership information into account.
-
- =head1 AUTHOR
-
- Original code from Module::Build::ModuleInfo by Ken Williams
- <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
-
- Released as Module::Metadata by Matt S Trout (mst) <mst@shadowcat.co.uk> with
- assistance from David Golden (xdg) <dagolden@cpan.org>.
-
- =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
+ $index = CPAN::Common::Index::LocalPackage->new(
+ { source => "mypackages.details.txt" }
+ );
- $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<Parse::CPAN::Meta> is a parser for F<META.json> and F<META.yml> files, using
- L<JSON::PP> and/or L<CPAN::Meta::YAML>.
-
- B<Parse::CPAN::Meta> provides three methods: C<load_file>, C<load_json_string>,
- and C<load_yaml_string>. These will read and deserialize CPAN metafiles, and
- are described below in detail.
-
- B<Parse::CPAN::Meta> 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<load_yaml_string>.
-
- =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<load_json_string>.
-
- =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</ENVIRONMENT>
- 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<JSON::PP> or L<JSON>. Even if C<PERL_JSON_BACKEND> is set,
- this will return L<JSON> as further delegation is handled by
- the L<JSON> module. See L</ENVIRONMENT> 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<load_file>.
-
- =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<JSON::PP> will be used for deserializing JSON data. If the
- C<PERL_JSON_BACKEND> environment variable exists, is true and is not
- "JSON::PP", then the L<JSON> module (version 2.5 or greater) will be loaded and
- used to interpret C<PERL_JSON_BACKEND>. If L<JSON> is not installed or is too
- old, an exception will be thrown.
-
- =head2 PERL_YAML_BACKEND
-
- By default, L<CPAN::Meta::YAML> will be used for deserializing YAML data. If
- the C<PERL_YAML_BACKEND> 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<Load()> 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<http://rt.cpan.org/Public/Dist/Display.html?Name=Parse-CPAN-Meta>.
- 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<https://github.com/Perl-Toolchain-Gang/Parse-CPAN-Meta>
-
- git clone https://github.com/Perl-Toolchain-Gang/Parse-CPAN-Meta.git
-
- =head1 AUTHORS
-
- =over 4
-
- =item *
-
- Adam Kennedy <adamk@cpan.org>
-
- =item *
-
- David Golden <dagolden@cpan.org>
-
- =back
-
- =head1 CONTRIBUTORS
-
- =over 4
-
- =item *
-
- Graham Knop <haarg@haarg.org>
-
- =item *
-
- Joshua ben Jore <jjore@cpan.org>
-
- =item *
-
- Neil Bowers <neil@bowers.com>
-
- =item *
-
- Ricardo Signes <rjbs@cpan.org>
-
- =item *
-
- Steffen Mueller <smueller@cpan.org>
-
- =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
+ =head1 DESCRIPTION
- $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
- (?<![*\$\\@%&]) # no sigils
- \bpackage\s+
- ([\w\:\']+)
- \s*
- (?: $ | [\}\;] | \{ | \s+($version::STRICT) )
- }x) {
- $pkg = $1;
- $strict_version = $2;
- if ($pkg eq "DB"){
- # XXX if pumpkin and perl make him comaintainer! I
- # think I always made the pumpkins comaint on DB
- # without further ado (?)
- next PLINE;
- }
- }
-
- if ($pkg) {
- # Found something
-
- # from package
- $pkg =~ s/\'/::/;
- next PLINE unless $pkg =~ /^[A-Za-z]/;
- next PLINE unless $pkg =~ /\w$/;
- next PLINE if $pkg eq "main";
- # Perl::Critic::Policy::TestingAndDebugging::ProhibitShebangWarningsArg
- # database for modid in mods, package in packages, package in perms
- # alter table mods modify modid varchar(128) binary NOT NULL default '';
- # alter table packages modify package varchar(128) binary NOT NULL default '';
- next PLINE if length($pkg) > 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 (<FH>) {
- $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 /(?<!\\)([\$*])(([\w\:\']*)\bVERSION)\b.*(?<![!><=])\=(?![=>])/;
- 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<PAUSE::Permissions>) 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<eval> to parse a version under older perls. If you want it to use always C<eval> (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<Parse::LocalDistribution>, L<PAUSE::Permissions>
-
- Most part of this module is derived from PAUSE and CPAN::Version.
-
- L<https://github.com/andk/pause>
-
- L<https://github.com/andk/cpanpm>
-
- =head1 AUTHOR
-
- Andreas Koenig E<lt>andreas.koenig@anima.deE<gt>
-
- Kenichi Ishigaki, E<lt>ishigaki@cpan.orgE<gt>
-
- =head1 COPYRIGHT AND LICENSE
-
- Copyright 1995 - 2013 by Andreas Koenig E<lt>andk@cpan.orgE<gt> 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<shell_quote> [I<string>]...
-
- B<shell_quote> quotes strings so they can be passed through the shell.
- Each I<string> is quoted so that the shell will pass it along as a
- single argument and without further interpretation. If no I<string>s
- are given an empty string is returned.
-
- If any I<string> can't be safely quoted B<shell_quote> will B<croak>.
-
- =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<shell_quote_best_effort> [I<string>]...
-
- This is like B<shell_quote>, 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<shell_comment_quote> [I<string>]
-
- B<shell_comment_quote> quotes the I<string> 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<string> arguments
- in the future. I haven't done this yet because I'm not sure if the
- I<string>s 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 <F<roderick@argon.org>>
-
- =head1 SEE ALSO
-
- perl(1).
-
- =cut
- STRING_SHELLQUOTE
+ This module implements a CPAN::Common::Index that searches for packages in a local
+ index file in the same form as the CPAN 02packages.details.txt file.
- $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<local::lib> twice for this to work.
- First so that C<lib::core::only> doesn't prevent C<local::lib> from loading
- (it's not currently in core) and then again after C<lib::core::only> 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<App::FatPacker|App::FatPacker> 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</CAVEATS>).
-
- This module was extracted from L<local::lib|local::lib>'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<not> propagate properly across perl invocations like local::lib's
- stuff does. It can't. It's only a module import, so it B<only affects the
- specific perl VM instance in which you load and import() it>.
-
- 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<lib|lib> 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<http://www.shadowcat.co.uk/blog/matt-s-trout/tainted-love> - and for ways
- to achieve the old --self-contained feature's results, look at
- L<App::FatPacker|App::FatPacker>'s tree function, and at
- L<App::cpanminus|cpanm>'s --local-lib-contained feature.
-
- =head1 AUTHOR
-
- Matt S. Trout <mst@shadowcat.co.uk>
-
- =head1 LICENSE
-
- This library is free software under the same terms as perl itself.
-
- =head1 COPYRIGHT
-
- (c) 2010 the lib::core::only L</AUTHOR> as specified above.
-
- =cut
-
- 1;
- LIB_CORE_ONLY
+ There is no support for searching on authors.
- $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</Differences when using this module under Win32>.
-
- =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<source ~/.cshrc>.
-
- =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<local::lib> 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<activated most recently> 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<local::lib> 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<CMD.exe>, 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<App::local::lib::Win32Helper>.
-
- 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<Invoke-Expression> 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<SHELL>
- 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<lib::core::only> 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<local::lib> import besides the
- directory to use. They are specified as C<use local::lib '--option'[, path];>
- or C<perl -Mlocal::lib=--option[,path]>.
-
- =head2 --deactivate
-
- Remove the chosen path (or the default path) from the module search paths if it
- was added by C<local::lib>, instead of adding it.
-
- =head2 --deactivate-all
-
- Remove all directories that were added to search paths by C<local::lib> 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<bourne>, C<csh>,
- C<cmd>, or C<powershell>.
-
- =head2 --no-create
-
- Prevents C<local::lib> 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</build_environment_vars_for>.
-
- =head2 active_paths
-
- =over 4
-
- =item Arguments: None
-
- =item Return value: @paths
-
- =back
-
- Returns a list of active C<local::lib> paths, according to the
- C<PERL_LOCAL_LIB_ROOT> 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<lib> and C<perl5> 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<bin> 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<File::HomeDir>
- 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</resolve_empty_path>, L</resolve_home_path>,
- L</resolve_relative_path>. Passes the given path argument to
- L</resolve_empty_path> which then returns a result that is passed to
- L</resolve_home_path>, which then has its result passed to
- L</resolve_relative_path>. The result of this final call is returned from
- L</resolve_path>.
-
- =head1 OBJECT INTERFACE
-
- =head2 new
-
- =over 4
-
- =item Arguments: %attributes
-
- =item Return value: $local_lib
-
- =back
-
- Constructs a new C<local::lib> object, representing the current state of
- C<@INC> and the relevant environment variables.
-
- =head1 ATTRIBUTES
-
- =head2 roots
-
- An arrayref representing active C<local::lib> 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<PERL_MM_OPT> and
- C<PERL_MB_OPT>)
-
- =head2 no_create
-
- If set, C<local::lib> 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<local::lib> 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<local::lib> 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<local::lib>, 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</build_environment_vars>.
-
- =head2 setup_local_lib
-
- Constructs the C<%ENV> hash using L</setup_env_hash>, 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<after> 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<SHELL> 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<File::Spec>.
- This means any L<File::Spec> version installed in the local::lib will be
- ignored by scripts using local::lib. A workaround for this is using
- C<use lib "$local_lib/lib/perl5";> instead of using C<local::lib> directly.
-
- =item * Conflicts with L<ExtUtils::MakeMaker>'s C<PREFIX> option.
- C<local::lib> uses the C<INSTALL_BASE> option, as it has more predictable and
- sane behavior. If something attempts to use the C<PREFIX> option when running
- a F<Makefile.PL>, L<ExtUtils::MakeMaker> will refuse to run, as the two
- options conflict. This can be worked around by temporarily unsetting the
- C<PERL_MM_OPT> environment variable.
-
- =item * Conflicts with L<Module::Build>'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<PERL_MB_OPT>
- 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<cpan
- -i Foo::Bar>, but it fails with an error like: C<Warning: You do not have
- permissions to install into /usr/lib64/perl5/site_perl/5.8.8/x86_64-linux at
- /usr/lib64/perl5/5.8.8/Foo/Bar.pm> 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<rm -r ~/.cpan/build/Foo-Bar*>
-
- Finally, re-run C<cpan -i Foo::Bar> and it should install without problems.
-
- =head1 ENVIRONMENT
-
- =over 4
-
- =item SHELL
-
- =item COMSPEC
-
- local::lib looks at the user's C<SHELL> environment variable when printing out
- commands to add to the shell configuration file.
-
- On Win32 systems, C<COMSPEC> is also examined.
-
- =back
-
- =head1 SEE ALSO
-
- =over 4
-
- =item * L<Perl Advent article, 2011|http://perladvent.org/2011/2011-12-01.html>
-
- =back
-
- =head1 SUPPORT
-
- IRC:
-
- Join #local-lib on irc.perl.org.
-
- =head1 AUTHOR
-
- Matt S Trout <mst@shadowcat.co.uk> 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 <apeiron@cpan.org>.
-
- Doc patches for a custom local::lib directory, more cleanups in the english
- documentation and a L<german documentation|POD2::DE::local::lib> contributed by
- Torsten Raudssus <torsten@raudssus.de>.
-
- Hans Dieter Pearcey <hdp@cpan.org> 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 <csjewell@cpan.org>.
-
- Warnings for missing PATH/PERL5LIB (as when not running interactively) silenced
- by a patch from Marco Emilio Poleggi.
-
- Mark Stosberg <mark@summersault.com> provided the code for the now deleted
- '--self-contained' option.
-
- Documentation patches to make win32 usage clearer by
- David Mertens <dcmertens.perl@gmail.com> (run4flat).
-
- Brazilian L<portuguese translation|POD2::PT_BR::local::lib> and minor doc
- patches contributed by Breno G. de Oliveira <garu@cpan.org>.
-
- Improvements to stacking multiple local::lib dirs and removing them from the
- environment later on contributed by Andrew Rodland <arodland@cpan.org>.
-
- Patch for Carp version mismatch contributed by Hakim Cassimally
- <osfameron@cpan.org>.
-
- Rewrite of internals and numerous bug fixes and added features contributed by
- Graham Knop <haarg@haarg.org>.
-
- =head1 COPYRIGHT
-
- Copyright (c) 2007 - 2013 the local::lib L</AUTHOR> and L</CONTRIBUTORS> 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
+ =head1 ATTRIBUTES
- $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<parent> 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<require> 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<base> to remove the cruft
- that had accumulated in it.
-
- =head1 CAVEATS
-
- =head1 SEE ALSO
-
- L<base>
-
- =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<< <corion@cpan.org> >>
- Based on the idea of C<base.pm>, which was introduced with Perl 5.004_04.
-
- =head1 LICENSE
-
- This module is released under the same terms as Perl itself.
-
- =cut
- PARENT
+ =head2 source (REQUIRED)
- $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
+ Path to a local file in the form of 02packages.details.txt. It may
+ be compressed with a ".gz" suffix or it may be uncompressed.
- $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
+ =head2 cache
- $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
+ Path to a local directory to store a (possibly uncompressed) copy
+ of the source index. Defaults to a temporary directory if not
+ specified.
- s/^ //mg for values %fatpacked;
+ =for Pod::Coverage attributes validate_attributes search_packages search_authors
+ cached_package BUILD
- my $class = 'FatPacked::'.(0+\%fatpacked);
- no strict 'refs';
- *{"${class}::files"} = sub { keys %{$_[0]} };
-
- if ($] < 5.008) {
- *{"${class}::INC"} = sub {
- if (my $fat = $_[0]{$_[1]}) {
- my $pos = 0;
- my $last = length $fat;
- return (sub {
- return 0 if $pos == $last;
- my $next = (1 + index $fat, "\n", $pos) || $last;
- $_ .= substr $fat, $pos, $next - $pos;
- $pos = $next;
- return 1;
- });
- }
- };
- }
+ =head1 AUTHOR
- 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;
- };
- }
+ David Golden <dagolden@cpan.org>
- unshift @INC, bless \%fatpacked, $class;
- } # END OF FATPACK CODE
+ =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
+CPAN_COMMON_INDEX_LOCALPACKAGE
+
+$fatpacked{"CPAN/Common/Index/MetaDB.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_COMMON_INDEX_METADB';
+ use 5.008001;
use strict;
- use App::cpanminus::script;
+ use warnings;
+
+ package CPAN::Common::Index::MetaDB;
+ # ABSTRACT: Search index via CPAN MetaDB
+
+ our $VERSION = '0.010';
+ use parent 'CPAN::Common::Index';
- unless (caller) {
- my $app = App::cpanminus::script->new;
- $app->parse_options(@ARGV);
- exit $app->doit;
+ use Class::Tiny qw/uri/;
+
+ use Carp;
+ use CPAN::Meta::YAML;
+ use HTTP::Tiny;
+
+ #pod =attr uri
+ #pod
+ #pod A URI for the endpoint of a CPAN MetaDB server. The
+ #pod default is L<http://cpanmetadb.plackperl.org/v1.0/>.
+ #pod
+ #pod =cut
+
+ sub BUILD {
+ my $self = shift;
+ my $uri = $self->uri;
+ $uri = "http://cpanmetadb.plackperl.org/v1.0/"
+ unless defined $uri;
+ # ensure URI ends in '/'
+ $uri =~ s{/?$}{/};
+ $self->uri($uri);
+ return;
}
- __END__
+ sub search_packages {
+ my ( $self, $args ) = @_;
+ Carp::croak("Argument to search_packages must be hash reference")
+ unless ref $args eq 'HASH';
- =head1 NAME
+ # only support direct package query
+ return
+ unless keys %$args == 1 && exists $args->{package} && ref $args->{package} eq '';
+
+ my $mod = $args->{package};
+ my $res = HTTP::Tiny->new->get( $self->uri . "package/$mod" );
+ return unless $res->{success};
+
+ if ( my $yaml = CPAN::Meta::YAML->read_string( $res->{content} ) ) {
+ my $meta = $yaml->[0];
+ if ( $meta && $meta->{distfile} ) {
+ my $file = $meta->{distfile};
+ $file =~ s{^./../}{}; # strip leading
+ return {
+ package => $mod,
+ version => $meta->{version},
+ uri => "cpan:///distfile/$file",
+ };
+ }
+ }
- cpanm - get, unpack build and install modules from CPAN
+ return;
+ }
- =head1 SYNOPSIS
+ sub index_age { return time }; # pretend always current
- 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
+ sub search_authors { return }; # not supported
- =head1 COMMANDS
+ 1;
- =over 4
- =item (arguments)
+ # vim: ts=4 sts=4 sw=4 et:
- 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.
+ __END__
- 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
+ =pod
- 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<CPAN::Meta::Spec> format, while C<@> pins the exact version, and
- is a shortcut for C<~"== VERSION">.
+ =encoding UTF-8
- 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"
+ =head1 NAME
- The version query including specific version or range will be sent to
- L<MetaCPAN> 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.
+ CPAN::Common::Index::MetaDB - Search index via CPAN MetaDB
- For a git repository, you can specify a branch, tag, or commit SHA to
- build. The default is C<master>
+ =head1 VERSION
- cpanm git://github.com/plack/Plack.git@1.0000 # tag
- cpanm git://github.com/plack/Plack.git@devel # branch
+ version 0.010
- =item -i, --install
+ =head1 SYNOPSIS
- Installs the modules. This is a default behavior and this is just a
- compatibility option to make it work like L<cpan> or L<cpanp>.
+ use CPAN::Common::Index::MetaDB;
- =item --self-upgrade
+ $index = CPAN::Common::Index::MetaDB->new;
- Upgrades itself. It's just an alias for:
+ =head1 DESCRIPTION
- cpanm App::cpanminus
+ This module implements a CPAN::Common::Index that searches for packages against
+ the same CPAN MetaDB API used by L<cpanminus>.
- =item --info
+ There is no support for advanced package queries or searching authors. It just
+ takes a package name and returns the corresponding version and distribution.
- Displays the distribution information in
- C<AUTHOR/Dist-Name-ver.tar.gz> format in the standard out.
+ =head1 ATTRIBUTES
- =item --installdeps
+ =head2 uri
- 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.
+ A URI for the endpoint of a CPAN MetaDB server. The
+ default is L<http://cpanmetadb.plackperl.org/v1.0/>.
- cpanm --installdeps .
+ =for Pod::Coverage attributes validate_attributes search_packages search_authors BUILD
- =item --look
+ =head1 AUTHOR
- Download and unpack the distribution and then open the directory with
- your shell. Handy to poke around the source code or do manual
- testing.
+ David Golden <dagolden@cpan.org>
- =item -h, --help
+ =head1 COPYRIGHT AND LICENSE
- Displays the help message.
+ This software is Copyright (c) 2013 by David Golden.
- =item -V, --version
+ This is free software, licensed under:
- Displays the version number.
+ The Apache License, Version 2.0, January 2004
- =back
+ =cut
+CPAN_COMMON_INDEX_METADB
+
+$fatpacked{"CPAN/Common/Index/Mirror.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_COMMON_INDEX_MIRROR';
+ use 5.008001;
+ use strict;
+ use warnings;
- =head1 OPTIONS
+ package CPAN::Common::Index::Mirror;
+ # ABSTRACT: Search index via CPAN mirror flatfiles
- You can specify the default options in C<PERL_CPANM_OPT> environment variable.
+ our $VERSION = '0.010';
- =over 4
+ use parent 'CPAN::Common::Index';
- =item -f, --force
+ use Class::Tiny qw/cache mirror/;
- Force install modules even when testing failed.
+ use Carp;
+ use CPAN::DistnameInfo;
+ use File::Basename ();
+ use File::Fetch;
+ use File::Temp 0.19; # newdir
+ use Search::Dict 1.07;
+ use Tie::Handle::SkipHeader;
+ use URI;
- =item -n, --notest
+ our $HAS_IO_UNCOMPRESS_GUNZIP = eval { require IO::Uncompress::Gunzip };
- 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.
+ #pod =attr mirror
+ #pod
+ #pod URI to a CPAN mirror. Defaults to C<http://www.cpan.org/>.
+ #pod
+ #pod =attr cache
+ #pod
+ #pod Path to a local directory to store copies of the source indices. Defaults to a
+ #pod temporary directory if not specified.
+ #pod
+ #pod =cut
- Defaults to false, and you can say C<--no-notest> to override when it
- is set in the default options in C<PERL_CPANM_OPT>.
+ sub BUILD {
+ my $self = shift;
- =item --test-only
+ # cache directory needs to exist
+ my $cache = $self->cache;
+ $cache = File::Temp->newdir
+ unless defined $cache;
+ if ( !-d $cache ) {
+ Carp::croak("Cache directory '$cache' does not exist");
+ }
+ $self->cache($cache);
- 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.
+ # ensure mirror URL ends in '/'
+ my $mirror = $self->mirror;
+ $mirror = "http://www.cpan.org/"
+ unless defined $mirror;
+ $mirror =~ s{/?$}{/};
+ $self->mirror($mirror);
- 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.
+ return;
+ }
- =item -S, --sudo
+ my %INDICES = (
+ mailrc => 'authors/01mailrc.txt.gz',
+ packages => 'modules/02packages.details.txt.gz',
+ );
- Switch to the root user with C<sudo> when installing modules. Use this
- if you want to install modules to the system perl include path.
+ # XXX refactor out from subs below
+ my %TEST_GENERATORS = (
+ regexp_nocase => sub {
+ my $arg = shift;
+ my $re = ref $arg eq 'Regexp' ? $arg : qr/\A\Q$arg\E\z/i;
+ return sub { $_[0] =~ $re };
+ },
+ regexp => sub {
+ my $arg = shift;
+ my $re = ref $arg eq 'Regexp' ? $arg : qr/\A\Q$arg\E\z/;
+ return sub { $_[0] =~ $re };
+ },
+ version => sub {
+ my $arg = shift;
+ my $v = version->parse($arg);
+ return sub {
+ eval { version->parse( $_[0] ) == $v };
+ };
+ },
+ );
- Defaults to false, and you can say C<--no-sudo> to override when it is
- set in the default options in C<PERL_CPANM_OPT>.
+ my %QUERY_TYPES = (
+ # package search
+ package => 'regexp',
+ version => 'version',
+ dist => 'regexp',
- =item -v, --verbose
+ # author search
+ id => 'regexp_nocase', # XXX need to add "alias " first
+ fullname => 'regexp_nocase',
+ email => 'regexp_nocase',
+ );
- Makes the output verbose. It also enables the interactive
- configuration. (See --interactive)
+ sub cached_package {
+ my ($self) = @_;
+ my $package = File::Spec->catfile( $self->cache,
+ File::Basename::basename( $INDICES{packages} ) );
+ $package =~ s/\.gz$//;
+ $self->refresh_index unless -r $package;
+ return $package;
+ }
- =item -q, --quiet
+ sub cached_mailrc {
+ my ($self) = @_;
+ my $mailrc =
+ File::Spec->catfile( $self->cache, File::Basename::basename( $INDICES{mailrc} ) );
+ $mailrc =~ s/\.gz$//;
+ $self->refresh_index unless -r $mailrc;
+ return $mailrc;
+ }
- Makes the output even more quiet than the default. It only shows the
- successful/failed dependencies to the output.
+ sub refresh_index {
+ my ($self) = @_;
+ for my $file ( values %INDICES ) {
+ my $remote = URI->new_abs( $file, $self->mirror );
+ $remote =~ s/\.gz$//
+ unless $HAS_IO_UNCOMPRESS_GUNZIP;
+ my $ff = File::Fetch->new( uri => $remote );
+ my $where = $ff->fetch( to => $self->cache )
+ or Carp::croak( $ff->error );
+ if ($HAS_IO_UNCOMPRESS_GUNZIP) {
+ ( my $uncompressed = $where ) =~ s/\.gz$//;
+ no warnings 'once';
+ IO::Uncompress::Gunzip::gunzip( $where, $uncompressed )
+ or Carp::croak "gunzip failed: $IO::Uncompress::Gunzip::GunzipError\n";
+ }
+ }
+ return 1;
+ }
- =item -l, --local-lib
+ # epoch secs
+ sub index_age {
+ my ($self) = @_;
+ my $package = $self->cached_package;
+ return ( -r $package ? ( stat($package) )[9] : 0 ); # mtime if readable
+ }
- Sets the L<local::lib> compatible path to install modules to. You
- don't need to set this if you already configure the shell environment
- variables using L<local::lib>, but this can be used to override that
- as well.
+ sub search_packages {
+ my ( $self, $args ) = @_;
+ Carp::croak("Argument to search_packages must be hash reference")
+ unless ref $args eq 'HASH';
+
+ my $index_path = $self->cached_package;
+ die "Can't read $index_path" unless -r $index_path;
+
+ my $fh = IO::Handle->new;
+ tie *$fh, 'Tie::Handle::SkipHeader', "<", $index_path
+ or die "Can't tie $index_path: $!";
+
+ # Convert scalars or regexps to subs
+ my $rules;
+ while ( my ( $k, $v ) = each %$args ) {
+ $rules->{$k} = _rulify( $k, $v );
+ }
+
+ my @found;
+ if ( $args->{package} and ref $args->{package} eq '' ) {
+ # binary search 02packages on package
+ my $pos = look $fh, $args->{package}, { xfrm => \&_xform_package, fold => 1 };
+ return if $pos == -1;
+ # loop over any case-insensitive matching lines
+ LINE: while ( my $line = <$fh> ) {
+ last unless $line =~ /\A\Q$args->{package}\E\s+/i;
+ push @found, _match_package_line( $line, $rules );
+ }
+ }
+ else {
+ # iterate all lines looking for match
+ LINE: while ( my $line = <$fh> ) {
+ push @found, _match_package_line( $line, $rules );
+ }
+ }
+ return wantarray ? @found : $found[0];
+ }
- =item -L, --local-lib-contained
+ sub search_authors {
+ my ( $self, $args ) = @_;
+ Carp::croak("Argument to search_authors must be hash reference")
+ unless ref $args eq 'HASH';
- Same with C<--local-lib> but with L<--self-contained> set. All
- non-core dependencies will be installed even if they're already
- installed.
+ my $index_path = $self->cached_mailrc;
+ die "Can't read $index_path" unless -r $index_path;
+ open my $fh, $index_path or die "Can't open $index_path: $!";
- For instance,
+ # Convert scalars or regexps to subs
+ my $rules;
+ while ( my ( $k, $v ) = each %$args ) {
+ $rules->{$k} = _rulify( $k, $v );
+ }
- cpanm -L extlib Plack
+ my @found;
+ if ( $args->{id} and ref $args->{id} eq '' ) {
+ # binary search mailrec on package
+ my $pos = look $fh, $args->{id}, { xfrm => \&_xform_mailrc, fold => 1 };
+ return if $pos == -1;
+ my $line = <$fh>;
+ push @found, _match_mailrc_line( $line, $rules );
+ }
+ else {
+ # iterate all lines looking for match
+ LINE: while ( my $line = <$fh> ) {
+ push @found, _match_mailrc_line( $line, $rules );
+ }
+ }
+ return wantarray ? @found : $found[0];
+ }
- would install Plack and all of its non-core dependencies into the
- directory C<extlib>, which can be loaded from your application with:
+ sub _rulify {
+ my ( $key, $arg ) = @_;
+ return $arg if ref($arg) eq 'CODE';
+ return $TEST_GENERATORS{ $QUERY_TYPES{$key} }->($arg);
+ }
- use local::lib '/path/to/extlib';
+ sub _xform_package {
+ my @fields = split " ", $_[0], 2;
+ return $fields[0];
+ }
- Note that this option does B<NOT> reliably work with perl installations
- supplied by operating system vendors that strips standard modules from perl,
- such as RHEL, Fedora and CentOS, B<UNLESS> you also install packages supplying
- all the modules that have been stripped. For these systems you will probably
- want to install the C<perl-core> meta-package which does just that.
+ sub _xform_mailrc {
+ my @fields = split " ", $_[0], 3;
+ return $fields[1];
+ }
- =item --self-contained
+ sub _match_package_line {
+ my ( $line, $rules ) = @_;
+ return unless defined $line;
+ my ( $mod, $version, $dist, $comment ) = split " ", $line, 4;
+ if ( $rules->{package} ) {
+ return unless $rules->{package}->($mod);
+ }
+ if ( $rules->{version} ) {
+ return unless $rules->{version}->($version);
+ }
+ if ( $rules->{dist} ) {
+ return unless $rules->{dist}->($dist);
+ }
+ $dist =~ s{\A./../}{};
+ return {
+ package => $mod,
+ version => $version,
+ uri => "cpan:///distfile/$dist",
+ };
+ }
- 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.
+ sub _match_mailrc_line {
+ my ( $line, $rules ) = @_;
+ return unless defined $line;
+ my ( $id, $address ) = $line =~ m{\Aalias\s+(\S+)\s+"(.*)"};
+ my ( $fullname, $email ) = $address =~ m{([^<]+)<([^>]+)>};
+ $fullname =~ s/\s*$//;
+ if ( $rules->{id} ) {
+ return unless $rules->{id}->($id);
+ }
+ if ( $rules->{fullname} ) {
+ return unless $rules->{fullname}->($fullname);
+ }
+ if ( $rules->{email} ) {
+ return unless $rules->{email}->($email);
+ }
+ return {
+ id => $id,
+ fullname => $fullname,
+ email => $email,
+ };
+ }
- =item --exclude-vendor
+ 1;
- 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
+ # vim: ts=4 sts=4 sw=4 et:
- Specifies the base URL for the CPAN mirror to use, such as
- C<http://cpan.cpantesters.org/> (you can omit the trailing slash). You
- can specify multiple mirror URLs by repeating the command line option.
+ __END__
- You can use a local directory that has a CPAN mirror structure
- (created by tools such as L<OrePAN> or L<Pinto>) by using a special
- URL scheme C<file://>. If the given URL begins with `/` (without any
- scheme), it is considered as a file scheme as well.
+ =pod
- cpanm --mirror file:///path/to/mirror
- cpanm --mirror ~/minicpan # Because shell expands ~ to /home/user
+ =encoding UTF-8
- Defaults to C<http://www.cpan.org/>.
+ =head1 NAME
- =item --mirror-only
+ CPAN::Common::Index::Mirror - Search index via CPAN mirror flatfiles
- 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.
+ =head1 VERSION
- 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).
+ version 0.010
- =item --from, -M
+ =head1 SYNOPSIS
- cpanm -M https://cpan.metacpan.org/
- cpanm --from https://cpan.metacpan.org/
+ use CPAN::Common::Index::Mirror;
- Use the given mirror URL and its index as the I<only> source to search
- and download modules from.
+ # default mirror is http://www.cpan.org/
+ $index = CPAN::Common::Index::Mirror->new;
- It works similar to C<--mirror> and C<--mirror-only> combined, with a
- small difference: unlike C<--mirror> which I<appends> the URL to the
- list of mirrors, C<--from> (or C<-M> for short) uses the specified URL
- as its I<only> 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<PERL_CPANM_OPT>
- environment variable.
+ # custom mirror
+ $index = CPAN::Common::Index::Mirror->new(
+ { mirror => "http://cpan.cpantesters.org" }
+ );
- B<Tip:> It might be useful if you name these options with your shell
- aliases, like:
+ =head1 DESCRIPTION
- alias minicpanm='cpanm --from ~/minicpan'
- alias darkpan='cpanm --from http://mycompany.example.com/DPAN'
+ This module implements a CPAN::Common::Index that retrieves and searches
+ 02packages.details.txt and 01mailrc.txt indices.
- =item --mirror-index
+ The default mirror is L<http://www.cpan.org/>. This is a globally balanced
+ fast mirror and is a great choice if you don't have a local fast mirror.
- B<EXPERIMENTAL>: Specifies the file path to C<02packages.details.txt>
- for module search index.
+ =head1 ATTRIBUTES
- =item --cpanmetadb
+ =head2 mirror
- B<EXPERIMENTAL>: Specifies an alternate URI for CPAN MetaDB index lookups.
+ URI to a CPAN mirror. Defaults to C<http://www.cpan.org/>.
- =item --metacpan
+ =head2 cache
- Prefers MetaCPAN API over CPAN MetaDB.
+ Path to a local directory to store copies of the source indices. Defaults to a
+ temporary directory if not specified.
- =item --cpanfile
+ =for Pod::Coverage attributes validate_attributes search_packages search_authors
+ cached_package cached_mailrc BUILD
- B<EXPERIMENTAL>: Specified an alternate path for cpanfile to search for,
- when C<--installdeps> command is in use. Defaults to C<cpanfile>.
+ =head1 AUTHOR
- =item --prompt
+ David Golden <dagolden@cpan.org>
- 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.
+ =head1 COPYRIGHT AND LICENSE
- Defaults to false, and you can say C<--no-prompt> to override if it's
- set in the default options in C<PERL_CPANM_OPT>.
+ This software is Copyright (c) 2013 by David Golden.
- =item --dev
+ This is free software, licensed under:
- B<EXPERIMENTAL>: search for a newer developer release as well. Defaults to false.
+ The Apache License, Version 2.0, January 2004
- =item --reinstall
+ =cut
+CPAN_COMMON_INDEX_MIRROR
+
+$fatpacked{"CPAN/Common/Index/Mux/Ordered.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_COMMON_INDEX_MUX_ORDERED';
+ use 5.008001;
+ use strict;
+ use warnings;
- cpanm, when given a module name in the command line (i.e. C<cpanm
- Plack>), checks the locally installed version first and skips if it is
- already installed. This option makes it skip the check, so:
+ package CPAN::Common::Index::Mux::Ordered;
+ # ABSTRACT: Consult indices in order and return the first result
- cpanm --reinstall Plack
+ our $VERSION = '0.010';
- would reinstall L<Plack> even if your locally installed version is
- latest, or even newer (which would happen if you install a developer
- release from version control repositories).
+ use parent 'CPAN::Common::Index';
- Defaults to false.
+ use Class::Tiny qw/resolvers/;
- =item --interactive
+ use Module::Load ();
- Makes the configuration (such as C<Makefile.PL> and C<Build.PL>)
- interactive, so you can answer questions in the distribution that
- requires custom configuration or Task:: distributions.
+ #pod =attr resolvers
+ #pod
+ #pod An array reference of CPAN::Common::Index::* objects
+ #pod
+ #pod =cut
- Defaults to false, and you can say C<--no-interactive> to override
- when it's set in the default options in C<PERL_CPANM_OPT>.
+ sub BUILD {
+ my $self = shift;
- =item --pp, --pureperl
+ my $resolvers = $self->resolvers;
+ $resolvers = [] unless defined $resolvers;
+ if ( ref $resolvers ne 'ARRAY' ) {
+ Carp::croak("The 'resolvers' argument must be an array reference");
+ }
+ for my $r (@$resolvers) {
+ if ( !eval { $r->isa("CPAN::Common::Index") } ) {
+ Carp::croak("Resolver '$r' is not a CPAN::Common::Index object");
+ }
+ }
+ $self->resolvers($resolvers);
- Prefer Pure perl build of modules by setting C<PUREPERL_ONLY=1> for
- MakeMaker and C<--pureperl-only> for Build.PL based
- distributions. Note that not all of the CPAN modules support this
- convention yet.
+ return;
+ }
- =item --with-recommends, --with-suggests
+ #pod =method assemble
+ #pod
+ #pod $index = CPAN::Common::Index::Mux::Ordered->assemble(
+ #pod MetaDB => {},
+ #pod Mirror => { mirror => "http://www.cpan.org" },
+ #pod );
+ #pod
+ #pod This class method provides a shorthand for constructing a multiplexer.
+ #pod The arguments must be pairs of subclass suffixes and arguments. For
+ #pod example, "MetaDB" means to use "CPAN::Common::Index::MetaDB". Empty
+ #pod arguments must be given as an empty hash reference.
+ #pod
+ #pod =cut
- B<EXPERIMENTAL>: Installs dependencies declared as C<recommends> and
- C<suggests> respectively, per META spec. When these dependencies fail
- to install, cpanm continues the installation, since they're just
- recommendation/suggestion.
+ sub assemble {
+ my ( $class, @backends ) = @_;
- Enabling this could potentially make a circular dependency for a few
- modules on CPAN, when C<recommends> adds a module that C<recommends>
- back the module in return.
+ my @resolvers;
- There's also C<--without-recommend> and C<--without-suggests> to
- override the default decision made earlier in C<PERL_CPANM_OPT>.
+ while (@backends) {
+ my ( $subclass, $config ) = splice @backends, 0, 2;
+ my $full_class = "CPAN::Common::Index::${subclass}";
+ eval { Module::Load::load($full_class); 1 }
+ or Carp::croak($@);
+ my $object = $full_class->new($config);
+ push @resolvers, $object;
+ }
- Defaults to false for both.
+ return $class->new( { resolvers => \@resolvers } );
+ }
- =item --with-develop
+ sub validate_attributes {
+ my ($self) = @_;
+ my $resolvers = $self->resolvers;
+ return 1;
+ }
- B<EXPERIMENTAL>: Installs develop phase dependencies in META files or
- C<cpanfile> when used with C<--installdeps>. Defaults to false.
+ # have to think carefully about the sematics of regex search when indices
+ # are stacked; only one result for any given package (or package/version)
+ sub search_packages {
+ my ( $self, $args ) = @_;
+ Carp::croak("Argument to search_packages must be hash reference")
+ unless ref $args eq 'HASH';
+ my @found;
+ if ( $args->{name} and ref $args->{name} eq '' ) {
+ # looking for exact match, so we just want the first hit
+ for my $source ( @{ $self->resolvers } ) {
+ if ( my @result = $source->search_packages($args) ) {
+ # XXX double check against remaining $args
+ push @found, @result;
+ last;
+ }
+ }
+ }
+ else {
+ # accumulate results from all resolvers
+ my %seen;
+ for my $source ( @{ $self->resolvers } ) {
+ my @result = $source->search_packages($args);
+ push @found, grep { !$seen{ $_->{package} }++ } @result;
+ }
+ }
+ return wantarray ? @found : $found[0];
+ }
- =item --with-configure
+ # have to think carefully about the sematics of regex search when indices
+ # are stacked; only one result for any given package (or package/version)
+ sub search_authors {
+ my ( $self, $args ) = @_;
+ Carp::croak("Argument to search_authors must be hash reference")
+ unless ref $args eq 'HASH';
+ my @found;
+ if ( $args->{name} and ref $args->{name} eq '' ) {
+ # looking for exact match, so we just want the first hit
+ for my $source ( @{ $self->resolvers } ) {
+ if ( my @result = $source->search_authors($args) ) {
+ # XXX double check against remaining $args
+ push @found, @result;
+ last;
+ }
+ }
+ }
+ else {
+ # accumulate results from all resolvers
+ my %seen;
+ for my $source ( @{ $self->resolvers } ) {
+ my @result = $source->search_authors($args);
+ push @found, grep { !$seen{ $_->{package} }++ } @result;
+ }
+ }
+ return wantarray ? @found : $found[0];
+ }
- B<EXPERIMENTAL>: Installs configure phase dependencies in C<cpanfile>
- when used with C<--installdeps>. Defaults to false.
+ 1;
- =item --with-feature, --without-feature, --with-all-features
- B<EXPERIMENTAL>: Specifies the feature to enable, if a module supports
- optional features per META spec 2.0.
+ # vim: ts=4 sts=4 sw=4 et:
- cpanm --with-feature=opt_csv Spreadsheet::Read
+ __END__
- the features can also be interactively chosen when C<--interactive>
- option is enabled.
+ =pod
- C<--with-all-features> enables all the optional features, and
- C<--without-feature> can select a feature to disable.
+ =encoding UTF-8
- =item --configure-timeout, --build-timeout, --test-timeout
+ =head1 NAME
- 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.
+ CPAN::Common::Index::Mux::Ordered - Consult indices in order and return the first result
- =item --configure-args, --build-args, --test-args, --install-args
+ =head1 VERSION
- B<EXPERIMENTAL>: Pass arguments for configure/build/test/install
- commands respectively, for a given module to install.
+ version 0.010
- cpanm DBD::mysql --configure-args="--cflags=... --libs=..."
+ =head1 SYNOPSIS
- The argument is only enabled for the module passed as a command line
- argument, not dependencies.
+ use CPAN::Common::Index::Mux::Ordered;
+ use Data::Dumper;
- =item --scandeps
+ $index = CPAN::Common::Index::Mux::Ordered->assemble(
+ MetaDB => {},
+ Mirror => { mirror => "http://cpan.cpantesters.org" },
+ );
- B<DEPRECATED>: Scans the depencencies of given modules and output the
- tree in a text format. (See C<--format> below for more options)
+ =head1 DESCRIPTION
- Because this command doesn't actually install any distributions, it
- will be useful that by typing:
+ This module multiplexes multiple CPAN::Common::Index objects, returning
+ results in order.
- cpanm --scandeps Catalyst::Runtime
+ For exact match queries, the first result is returned. For search queries,
+ results from each index object are concatenated.
- you can make sure what modules will be installed.
+ =head1 ATTRIBUTES
- 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.
+ =head2 resolvers
- =item --format
+ An array reference of CPAN::Common::Index::* objects
- B<DEPRECATED>: Determines what format to display the scanned
- dependency tree. Available options are C<tree>, C<json>, C<yaml> and
- C<dists>.
+ =head1 METHODS
- =over 8
+ =head2 assemble
- =item tree
+ $index = CPAN::Common::Index::Mux::Ordered->assemble(
+ MetaDB => {},
+ Mirror => { mirror => "http://www.cpan.org" },
+ );
- Displays the tree in a plain text format. This is the default value.
+ This class method provides a shorthand for constructing a multiplexer.
+ The arguments must be pairs of subclass suffixes and arguments. For
+ example, "MetaDB" means to use "CPAN::Common::Index::MetaDB". Empty
+ arguments must be given as an empty hash reference.
- =item json, yaml
+ =for Pod::Coverage attributes validate_attributes search_packages search_authors BUILD
- Outputs the tree in a JSON or YAML format. L<JSON> and L<YAML> modules
- need to be installed respectively. The output tree is represented as a
- recursive tuple of:
+ =head1 AUTHOR
- [ distribution, dependencies ]
+ David Golden <dagolden@cpan.org>
- 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.
+ =head1 COPYRIGHT AND LICENSE
- =item dists
+ This software is Copyright (c) 2013 by David Golden.
- C<dists> is a special output format, where it prints the distribution
- filename in the I<depth first order> after the dependency resolution,
- like:
+ This is free software, licensed under:
- 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
+ The Apache License, Version 2.0, January 2004
- 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.
+ =cut
+CPAN_COMMON_INDEX_MUX_ORDERED
+
+$fatpacked{"CPAN/DistnameInfo.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_DISTNAMEINFO';
- =back
+ package CPAN::DistnameInfo;
- =item --save-dists
+ $VERSION = "0.12";
+ use strict;
- Specifies the optional directory path to copy downloaded tarballs in
- the CPAN mirror compatible directory structure
- i.e. I<authors/id/A/AU/AUTHORS/Foo-Bar-version.tar.gz>
+ sub distname_info {
+ my $file = shift or return;
- 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<vendor/Foo-Bar-version.tar.gz>.
+ my ($dist, $version) = $file =~ /^
+ ((?:[-+.]*(?:[A-Za-z0-9]+|(?<=\D)_|_(?=\D))*
+ (?:
+ [A-Za-z](?=[^A-Za-z]|$)
+ |
+ \d(?=-)
+ )(?<![._-][vV])
+ )+)(.*)
+ $/xs or return ($file,undef,undef);
- =item --uninst-shadows
+ if ($dist =~ /-undef\z/ and ! length $version) {
+ $dist =~ s/-undef\z//;
+ }
- 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.
+ # Remove potential -withoutworldwriteables suffix
+ $version =~ s/-withoutworldwriteables$//;
- If you run cpanm as root and use C<INSTALL_BASE> 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.
+ if ($version =~ /^(-[Vv].*)-(\d.*)/) {
+
+ # Catch names like Unicode-Collate-Standard-V3_1_1-0.1
+ # where the V3_1_1 is part of the distname
+ $dist .= $1;
+ $version = $2;
+ }
- Defaults to true if your perl version is smaller than 5.12, and you
- can disable that with C<--no-uninst-shadows>.
+ if ($version =~ /(.+_.*)-(\d.*)/) {
+ # Catch names like Task-Deprecations5_14-1.00.tar.gz where the 5_14 is
+ # part of the distname. However, names like libao-perl_0.03-1.tar.gz
+ # should still have 0.03-1 as their version.
+ $dist .= $1;
+ $version = $2;
+ }
- B<NOTE>: 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<before> the perl core library path, and uninstalling shadows is not
- necessary anymore and does more harm by deleting files from the core
- library path.
+ # Normalize the Dist.pm-1.23 convention which CGI.pm and
+ # a few others use.
+ $dist =~ s{\.pm$}{};
- =item --uninstall, -U
+ $version = $1
+ if !length $version and $dist =~ s/-(\d+\w)$//;
- Uninstalls a module from the library path. It finds a packlist for
- given modules, and removes all the files included in the same
- distribution.
+ $version = $1 . $version
+ if $version =~ /^\d+$/ and $dist =~ s/-(\w+)$//;
- If you enable local::lib, it only removes files from the local::lib
- directory.
+ if ($version =~ /\d\.\d/) {
+ $version =~ s/^[-_.]+//;
+ }
+ else {
+ $version =~ s/^[-_]+//;
+ }
- If you try to uninstall a module in C<perl> directory (i.e. core
- module), an error will be thrown.
+ my $dev;
+ if (length $version) {
+ if ($file =~ /^perl-?\d+\.(\d+)(?:\D(\d+))?(-(?:TRIAL|RC)\d+)?$/) {
+ $dev = 1 if (($1 > 6 and $1 & 1) or ($2 and $2 >= 50)) or $3;
+ }
+ elsif ($version =~ /\d\D\d+_\d/ or $version =~ /-TRIAL/) {
+ $dev = 1;
+ }
+ }
+ else {
+ $version = undef;
+ }
- 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.
+ ($dist, $version, $dev);
+ }
- =item --cascade-search
+ sub new {
+ my $class = shift;
+ my $distfile = shift;
- B<EXPERIMENTAL>: 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.
+ $distfile =~ s,//+,/,g;
- =item --skip-installed
+ my %info = ( pathname => $distfile );
- Specifies whether a module given in the command line is skipped if its latest
- version is already installed. Defaults to true.
+ ($info{filename} = $distfile) =~ s,^(((.*?/)?authors/)?id/)?([A-Z])/(\4[A-Z])/(\5[-A-Z0-9]*)/,,
+ and $info{cpanid} = $6;
- B<NOTE>: The C<PERL5LIB> environment variable have to be correctly set
- for this to work with modules installed using L<local::lib>, unless
- you always use the C<-l> option.
+ if ($distfile =~ m,([^/]+)\.(tar\.(?:g?z|bz2)|zip|tgz)$,i) { # support more ?
+ $info{distvname} = $1;
+ $info{extension} = $2;
+ }
- =item --skip-satisfied
+ @info{qw(dist version beta)} = distname_info($info{distvname});
+ $info{maturity} = delete $info{beta} ? 'developer' : 'released';
- B<EXPERIMENTAL>: Specifies whether a module (and version) given in the
- command line is skipped if it's already installed.
+ return bless \%info, $class;
+ }
- If you run:
+ 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} }
- cpanm --skip-satisfied CGI DBI~1.2
+ sub properties { %{ $_[0] } }
- 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<latest> version of CPAN is installed, C<--skip-satisfied> checks if
- a requested version (or not, which means any version) is installed.
+ 1;
- Defaults to false.
+ __END__
- =item --verify
+ =head1 NAME
- Verify the integrity of distribution files retrieved from PAUSE using
- CHECKSUMS and SIGNATURES (if found). Defaults to false.
+ CPAN::DistnameInfo - Extract distribution name and version from a distribution filename
- =item --report-perl-version
+ =head1 SYNOPSIS
- 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<TRAVIS>, C<CI> or C<AUTOMATED_TESTING>
- is enabled. You can disable it by using C<--no-report-perl-version>.
+ my $pathname = "authors/id/G/GB/GBARR/CPAN-DistnameInfo-0.02.tar.gz";
- =item --auto-cleanup
+ my $d = CPAN::DistnameInfo->new($pathname);
- 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.
+ 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/..."
- You can set the value to C<0> to make cpan never cleanup those
- directories.
+ my %prop = $d->properties;
- =item --man-pages
+ =head1 DESCRIPTION
- Generates man pages for executables (man1) and libraries (man3).
+ 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.
- 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>.
+ C<CPAN::DistnameInfo> uses heuristics that have been learnt by
+ L<http://search.cpan.org/> to extract the distribution name and
+ version from filenames and also report if the version is to be
+ treated as a developer release
- =item --lwp
+ The constructor takes a single pathname, returning an object with the following methods
- Uses L<LWP> 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.
+ =over
- =item --wget
+ =item cpanid
- 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).
+ If the path given looked like a CPAN authors directory path, then this will be the
+ the CPAN id of the author.
- =item --curl
+ =item dist
- Uses cURL (if available) to download stuff. Defaults to true, and
- you can say C<--no-curl> to disable using cURL.
+ The name of the distribution
- Normally with C<--lwp>, C<--wget> and C<--curl> options set to true
- (which is the default) cpanm tries L<LWP>, Wget, cURL and L<HTTP::Tiny>
- (in that order) and uses the first one available.
+ =item distvname
- =back
+ The file name with any suffix and leading directory names removed
- =head1 ENVIRONMENT VARIABLES
+ =item filename
- =over 4
+ 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 PERL_CPANM_HOME
+ =item maturity
- The directory cpanm should use to store downloads and build and test
- modules. Defaults to the C<.cpanm> directory in your user's home
- directory.
+ The maturity of the distribution. This will be either C<released> or C<developer>
- =item PERL_CPANM_OPT
+ =item extension
- If set, adds a set of default options to every cpanm command. These
- options come first, and so are overridden by command-line options.
+ The extension of the distribution, often used to denote the archive type (e.g. 'tar.gz')
- =back
+ =item pathname
- =head1 SEE ALSO
+ The pathname that was passed to the constructor when creating the object.
- L<App::cpanminus>
+ =item properties
- =head1 COPYRIGHT
+ This will return a list of key-value pairs, suitable for assigning to a hash,
+ for the known properties.
- Copyright 2010- Tatsuhiko Miyagawa.
+ =item version
+
+ The extracted version
+
+ =back
=head1 AUTHOR
- Tatsuhiko Miyagawa
+ Graham Barr <gbarr@pobox.com>
+
+ =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
-APP_CPANMINUS_FATSCRIPT
+
+CPAN_DISTNAMEINFO
$fatpacked{"CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META';
use 5.006;
@@ -26782,6 +2538,141 @@ $fatpacked{"CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_
=cut
CPAN_META
+$fatpacked{"CPAN/Meta/Check.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_CHECK';
+ package CPAN::Meta::Check;
+ $CPAN::Meta::Check::VERSION = '0.014';
+ 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 sprintf 'Installed version (%s) of %s is not in range \'%s\'',
+ (defined $version ? $version : 'undef'), $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 sprintf 'Installed version (%s) of %s is in range \'%s\'',
+ (defined $version ? $version : 'undef'), $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.014
+
+ =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<CPAN::Meta::Requirements|CPAN::Meta::Requirements> 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<CPAN::Meta::Prereqs> or L<CPAN::Meta> 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<CPAN::Meta::Requirements|CPAN::Meta::Requirements> 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<CPAN::Meta spec|CPAN::Meta::Spec>. C<$type> must be a relationship as defined by the same spec. C<$meta> should be a L<CPAN::Meta::Prereqs> or L<CPAN::Meta> object.
+
+ =head1 SEE ALSO
+
+ =over 4
+
+ =item * L<Test::CheckDeps|Test::CheckDeps>
+
+ =item * L<CPAN::Meta|CPAN::Meta>
+
+ =for comment # vi:noet:sts=2:sw=2:ts=2
+
+ =back
+
+ =head1 AUTHOR
+
+ Leon Timmermans <leont@cpan.org>
+
+ =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;
@@ -34110,11 +10001,915 @@ $fatpacked{"CPAN/Meta/YAML.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'
CPAN_META_YAML
+$fatpacked{"Capture/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CAPTURE_TINY';
+ use 5.006;
+ use strict;
+ use warnings;
+ package Capture::Tiny;
+ # ABSTRACT: Capture STDOUT and STDERR from Perl, XS or external programs
+ our $VERSION = '0.48';
+ use Carp ();
+ use Exporter ();
+ use IO::Handle ();
+ use File::Spec ();
+ use File::Temp qw/tempfile tmpnam/;
+ use Scalar::Util qw/reftype blessed/;
+ # Get PerlIO or fake it
+ BEGIN {
+ local $@;
+ eval { require PerlIO; PerlIO->can('get_layers') }
+ or *PerlIO::get_layers = sub { return () };
+ }
+
+ #--------------------------------------------------------------------------#
+ # create API subroutines and export them
+ # [do STDOUT flag, do STDERR flag, do merge flag, do tee flag]
+ #--------------------------------------------------------------------------#
+
+ my %api = (
+ capture => [1,1,0,0],
+ capture_stdout => [1,0,0,0],
+ capture_stderr => [0,1,0,0],
+ capture_merged => [1,1,1,0],
+ tee => [1,1,0,1],
+ tee_stdout => [1,0,0,1],
+ tee_stderr => [0,1,0,1],
+ tee_merged => [1,1,1,1],
+ );
+
+ for my $sub ( keys %api ) {
+ my $args = join q{, }, @{$api{$sub}};
+ eval "sub $sub(&;@) {unshift \@_, $args; goto \\&_capture_tee;}"; ## no critic
+ }
+
+ our @ISA = qw/Exporter/;
+ our @EXPORT_OK = keys %api;
+ our %EXPORT_TAGS = ( 'all' => \@EXPORT_OK );
+
+ #--------------------------------------------------------------------------#
+ # constants and fixtures
+ #--------------------------------------------------------------------------#
+
+ my $IS_WIN32 = $^O eq 'MSWin32';
+
+ ##our $DEBUG = $ENV{PERL_CAPTURE_TINY_DEBUG};
+ ##
+ ##my $DEBUGFH;
+ ##open $DEBUGFH, "> DEBUG" if $DEBUG;
+ ##
+ ##*_debug = $DEBUG ? sub(@) { print {$DEBUGFH} @_ } : sub(){0};
+
+ our $TIMEOUT = 30;
+
+ #--------------------------------------------------------------------------#
+ # command to tee output -- the argument is a filename that must
+ # be opened to signal that the process is ready to receive input.
+ # This is annoying, but seems to be the best that can be done
+ # as a simple, portable IPC technique
+ #--------------------------------------------------------------------------#
+ my @cmd = ($^X, '-C0', '-e', <<'HERE');
+ use Fcntl;
+ $SIG{HUP}=sub{exit};
+ if ( my $fn=shift ) {
+ sysopen(my $fh, qq{$fn}, O_WRONLY|O_CREAT|O_EXCL) or die $!;
+ print {$fh} $$;
+ close $fh;
+ }
+ my $buf; while (sysread(STDIN, $buf, 2048)) {
+ syswrite(STDOUT, $buf); syswrite(STDERR, $buf);
+ }
+ HERE
+
+ #--------------------------------------------------------------------------#
+ # filehandle manipulation
+ #--------------------------------------------------------------------------#
+
+ sub _relayer {
+ my ($fh, $apply_layers) = @_;
+ # _debug("# requested layers (@{$layers}) for @{[fileno $fh]}\n");
+
+ # eliminate pseudo-layers
+ binmode( $fh, ":raw" );
+ # strip off real layers until only :unix is left
+ while ( 1 < ( my $layers =()= PerlIO::get_layers( $fh, output => 1 ) ) ) {
+ binmode( $fh, ":pop" );
+ }
+ # apply other layers
+ my @to_apply = @$apply_layers;
+ shift @to_apply; # eliminate initial :unix
+ # _debug("# applying layers (unix @to_apply) to @{[fileno $fh]}\n");
+ binmode($fh, ":" . join(":",@to_apply));
+ }
+
+ sub _name {
+ my $glob = shift;
+ no strict 'refs'; ## no critic
+ return *{$glob}{NAME};
+ }
+
+ sub _open {
+ open $_[0], $_[1] or Carp::confess "Error from open(" . join(q{, }, @_) . "): $!";
+ # _debug( "# open " . join( ", " , map { defined $_ ? _name($_) : 'undef' } @_ ) . " as " . fileno( $_[0] ) . "\n" );
+ }
+
+ sub _close {
+ # _debug( "# closing " . ( defined $_[0] ? _name($_[0]) : 'undef' ) . " on " . fileno( $_[0] ) . "\n" );
+ close $_[0] or Carp::confess "Error from close(" . join(q{, }, @_) . "): $!";
+ }
+
+ my %dup; # cache this so STDIN stays fd0
+ my %proxy_count;
+ sub _proxy_std {
+ my %proxies;
+ if ( ! defined fileno STDIN ) {
+ $proxy_count{stdin}++;
+ if (defined $dup{stdin}) {
+ _open \*STDIN, "<&=" . fileno($dup{stdin});
+ # _debug( "# restored proxy STDIN as " . (defined fileno STDIN ? fileno STDIN : 'undef' ) . "\n" );
+ }
+ else {
+ _open \*STDIN, "<" . File::Spec->devnull;
+ # _debug( "# proxied STDIN as " . (defined fileno STDIN ? fileno STDIN : 'undef' ) . "\n" );
+ _open $dup{stdin} = IO::Handle->new, "<&=STDIN";
+ }
+ $proxies{stdin} = \*STDIN;
+ binmode(STDIN, ':utf8') if $] >= 5.008; ## no critic
+ }
+ if ( ! defined fileno STDOUT ) {
+ $proxy_count{stdout}++;
+ if (defined $dup{stdout}) {
+ _open \*STDOUT, ">&=" . fileno($dup{stdout});
+ # _debug( "# restored proxy STDOUT as " . (defined fileno STDOUT ? fileno STDOUT : 'undef' ) . "\n" );
+ }
+ else {
+ _open \*STDOUT, ">" . File::Spec->devnull;
+ # _debug( "# proxied STDOUT as " . (defined fileno STDOUT ? fileno STDOUT : 'undef' ) . "\n" );
+ _open $dup{stdout} = IO::Handle->new, ">&=STDOUT";
+ }
+ $proxies{stdout} = \*STDOUT;
+ binmode(STDOUT, ':utf8') if $] >= 5.008; ## no critic
+ }
+ if ( ! defined fileno STDERR ) {
+ $proxy_count{stderr}++;
+ if (defined $dup{stderr}) {
+ _open \*STDERR, ">&=" . fileno($dup{stderr});
+ # _debug( "# restored proxy STDERR as " . (defined fileno STDERR ? fileno STDERR : 'undef' ) . "\n" );
+ }
+ else {
+ _open \*STDERR, ">" . File::Spec->devnull;
+ # _debug( "# proxied STDERR as " . (defined fileno STDERR ? fileno STDERR : 'undef' ) . "\n" );
+ _open $dup{stderr} = IO::Handle->new, ">&=STDERR";
+ }
+ $proxies{stderr} = \*STDERR;
+ binmode(STDERR, ':utf8') if $] >= 5.008; ## no critic
+ }
+ return %proxies;
+ }
+
+ sub _unproxy {
+ my (%proxies) = @_;
+ # _debug( "# unproxying: " . join(" ", keys %proxies) . "\n" );
+ for my $p ( keys %proxies ) {
+ $proxy_count{$p}--;
+ # _debug( "# unproxied " . uc($p) . " ($proxy_count{$p} left)\n" );
+ if ( ! $proxy_count{$p} ) {
+ _close $proxies{$p};
+ _close $dup{$p} unless $] < 5.008; # 5.6 will have already closed this as dup
+ delete $dup{$p};
+ }
+ }
+ }
+
+ sub _copy_std {
+ my %handles;
+ for my $h ( qw/stdout stderr stdin/ ) {
+ next if $h eq 'stdin' && ! $IS_WIN32; # WIN32 hangs on tee without STDIN copied
+ my $redir = $h eq 'stdin' ? "<&" : ">&";
+ _open $handles{$h} = IO::Handle->new(), $redir . uc($h); # ">&STDOUT" or "<&STDIN"
+ }
+ return \%handles;
+ }
+
+ # In some cases we open all (prior to forking) and in others we only open
+ # the output handles (setting up redirection)
+ sub _open_std {
+ my ($handles) = @_;
+ _open \*STDIN, "<&" . fileno $handles->{stdin} if defined $handles->{stdin};
+ _open \*STDOUT, ">&" . fileno $handles->{stdout} if defined $handles->{stdout};
+ _open \*STDERR, ">&" . fileno $handles->{stderr} if defined $handles->{stderr};
+ }
+
+ #--------------------------------------------------------------------------#
+ # private subs
+ #--------------------------------------------------------------------------#
+
+ sub _start_tee {
+ my ($which, $stash) = @_; # $which is "stdout" or "stderr"
+ # setup pipes
+ $stash->{$_}{$which} = IO::Handle->new for qw/tee reader/;
+ pipe $stash->{reader}{$which}, $stash->{tee}{$which};
+ # _debug( "# pipe for $which\: " . _name($stash->{tee}{$which}) . " " . fileno( $stash->{tee}{$which} ) . " => " . _name($stash->{reader}{$which}) . " " . fileno( $stash->{reader}{$which}) . "\n" );
+ select((select($stash->{tee}{$which}), $|=1)[0]); # autoflush
+ # setup desired redirection for parent and child
+ $stash->{new}{$which} = $stash->{tee}{$which};
+ $stash->{child}{$which} = {
+ stdin => $stash->{reader}{$which},
+ stdout => $stash->{old}{$which},
+ stderr => $stash->{capture}{$which},
+ };
+ # flag file is used to signal the child is ready
+ $stash->{flag_files}{$which} = scalar( tmpnam() ) . $$;
+ # execute @cmd as a separate process
+ if ( $IS_WIN32 ) {
+ my $old_eval_err=$@;
+ undef $@;
+
+ eval "use Win32API::File qw/GetOsFHandle SetHandleInformation fileLastError HANDLE_FLAG_INHERIT INVALID_HANDLE_VALUE/ ";
+ # _debug( "# Win32API::File loaded\n") unless $@;
+ my $os_fhandle = GetOsFHandle( $stash->{tee}{$which} );
+ # _debug( "# Couldn't get OS handle: " . fileLastError() . "\n") if ! defined $os_fhandle || $os_fhandle == INVALID_HANDLE_VALUE();
+ my $result = SetHandleInformation( $os_fhandle, HANDLE_FLAG_INHERIT(), 0);
+ # _debug( $result ? "# set no-inherit flag on $which tee\n" : ("# can't disable tee handle flag inherit: " . fileLastError() . "\n"));
+ _open_std( $stash->{child}{$which} );
+ $stash->{pid}{$which} = system(1, @cmd, $stash->{flag_files}{$which});
+ # not restoring std here as it all gets redirected again shortly anyway
+ $@=$old_eval_err;
+ }
+ else { # use fork
+ _fork_exec( $which, $stash );
+ }
+ }
+
+ sub _fork_exec {
+ my ($which, $stash) = @_; # $which is "stdout" or "stderr"
+ my $pid = fork;
+ if ( not defined $pid ) {
+ Carp::confess "Couldn't fork(): $!";
+ }
+ elsif ($pid == 0) { # child
+ # _debug( "# in child process ...\n" );
+ untie *STDIN; untie *STDOUT; untie *STDERR;
+ _close $stash->{tee}{$which};
+ # _debug( "# redirecting handles in child ...\n" );
+ _open_std( $stash->{child}{$which} );
+ # _debug( "# calling exec on command ...\n" );
+ exec @cmd, $stash->{flag_files}{$which};
+ }
+ $stash->{pid}{$which} = $pid
+ }
+
+ my $have_usleep = eval "use Time::HiRes 'usleep'; 1";
+ sub _files_exist {
+ return 1 if @_ == grep { -f } @_;
+ Time::HiRes::usleep(1000) if $have_usleep;
+ return 0;
+ }
+
+ sub _wait_for_tees {
+ my ($stash) = @_;
+ my $start = time;
+ my @files = values %{$stash->{flag_files}};
+ my $timeout = defined $ENV{PERL_CAPTURE_TINY_TIMEOUT}
+ ? $ENV{PERL_CAPTURE_TINY_TIMEOUT} : $TIMEOUT;
+ 1 until _files_exist(@files) || ($timeout && (time - $start > $timeout));
+ Carp::confess "Timed out waiting for subprocesses to start" if ! _files_exist(@files);
+ unlink $_ for @files;
+ }
+
+ sub _kill_tees {
+ my ($stash) = @_;
+ if ( $IS_WIN32 ) {
+ # _debug( "# closing handles\n");
+ close($_) for values %{ $stash->{tee} };
+ # _debug( "# waiting for subprocesses to finish\n");
+ my $start = time;
+ 1 until wait == -1 || (time - $start > 30);
+ }
+ else {
+ _close $_ for values %{ $stash->{tee} };
+ waitpid $_, 0 for values %{ $stash->{pid} };
+ }
+ }
+
+ sub _slurp {
+ my ($name, $stash) = @_;
+ my ($fh, $pos) = map { $stash->{$_}{$name} } qw/capture pos/;
+ # _debug( "# slurping captured $name from " . fileno($fh) . " at pos $pos with layers: @{[PerlIO::get_layers($fh)]}\n");
+ seek( $fh, $pos, 0 ) or die "Couldn't seek on capture handle for $name\n";
+ my $text = do { local $/; scalar readline $fh };
+ return defined($text) ? $text : "";
+ }
+
+ #--------------------------------------------------------------------------#
+ # _capture_tee() -- generic main sub for capturing or teeing
+ #--------------------------------------------------------------------------#
+
+ sub _capture_tee {
+ # _debug( "# starting _capture_tee with (@_)...\n" );
+ my ($do_stdout, $do_stderr, $do_merge, $do_tee, $code, @opts) = @_;
+ my %do = ($do_stdout ? (stdout => 1) : (), $do_stderr ? (stderr => 1) : ());
+ Carp::confess("Custom capture options must be given as key/value pairs\n")
+ unless @opts % 2 == 0;
+ my $stash = { capture => { @opts } };
+ for ( keys %{$stash->{capture}} ) {
+ my $fh = $stash->{capture}{$_};
+ Carp::confess "Custom handle for $_ must be seekable\n"
+ unless ref($fh) eq 'GLOB' || (blessed($fh) && $fh->isa("IO::Seekable"));
+ }
+ # save existing filehandles and setup captures
+ local *CT_ORIG_STDIN = *STDIN ;
+ local *CT_ORIG_STDOUT = *STDOUT;
+ local *CT_ORIG_STDERR = *STDERR;
+ # find initial layers
+ my %layers = (
+ stdin => [PerlIO::get_layers(\*STDIN) ],
+ stdout => [PerlIO::get_layers(\*STDOUT, output => 1)],
+ stderr => [PerlIO::get_layers(\*STDERR, output => 1)],
+ );
+ # _debug( "# existing layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/;
+ # get layers from underlying glob of tied filehandles if we can
+ # (this only works for things that work like Tie::StdHandle)
+ $layers{stdout} = [PerlIO::get_layers(tied *STDOUT)]
+ if tied(*STDOUT) && (reftype tied *STDOUT eq 'GLOB');
+ $layers{stderr} = [PerlIO::get_layers(tied *STDERR)]
+ if tied(*STDERR) && (reftype tied *STDERR eq 'GLOB');
+ # _debug( "# tied object corrected layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/;
+ # bypass scalar filehandles and tied handles
+ # localize scalar STDIN to get a proxy to pick up FD0, then restore later to CT_ORIG_STDIN
+ my %localize;
+ $localize{stdin}++, local(*STDIN)
+ if grep { $_ eq 'scalar' } @{$layers{stdin}};
+ $localize{stdout}++, local(*STDOUT)
+ if $do_stdout && grep { $_ eq 'scalar' } @{$layers{stdout}};
+ $localize{stderr}++, local(*STDERR)
+ if ($do_stderr || $do_merge) && grep { $_ eq 'scalar' } @{$layers{stderr}};
+ $localize{stdin}++, local(*STDIN), _open( \*STDIN, "<&=0")
+ if tied *STDIN && $] >= 5.008;
+ $localize{stdout}++, local(*STDOUT), _open( \*STDOUT, ">&=1")
+ if $do_stdout && tied *STDOUT && $] >= 5.008;
+ $localize{stderr}++, local(*STDERR), _open( \*STDERR, ">&=2")
+ if ($do_stderr || $do_merge) && tied *STDERR && $] >= 5.008;
+ # _debug( "# localized $_\n" ) for keys %localize;
+ # proxy any closed/localized handles so we don't use fds 0, 1 or 2
+ my %proxy_std = _proxy_std();
+ # _debug( "# proxy std: @{ [%proxy_std] }\n" );
+ # update layers after any proxying
+ $layers{stdout} = [PerlIO::get_layers(\*STDOUT, output => 1)] if $proxy_std{stdout};
+ $layers{stderr} = [PerlIO::get_layers(\*STDERR, output => 1)] if $proxy_std{stderr};
+ # _debug( "# post-proxy layers for $_\: @{$layers{$_}}\n" ) for qw/stdin stdout stderr/;
+ # store old handles and setup handles for capture
+ $stash->{old} = _copy_std();
+ $stash->{new} = { %{$stash->{old}} }; # default to originals
+ for ( keys %do ) {
+ $stash->{new}{$_} = ($stash->{capture}{$_} ||= File::Temp->new);
+ seek( $stash->{capture}{$_}, 0, 2 ) or die "Could not seek on capture handle for $_\n";
+ $stash->{pos}{$_} = tell $stash->{capture}{$_};
+ # _debug("# will capture $_ on " . fileno($stash->{capture}{$_})."\n" );
+ _start_tee( $_ => $stash ) if $do_tee; # tees may change $stash->{new}
+ }
+ _wait_for_tees( $stash ) if $do_tee;
+ # finalize redirection
+ $stash->{new}{stderr} = $stash->{new}{stdout} if $do_merge;
+ # _debug( "# redirecting in parent ...\n" );
+ _open_std( $stash->{new} );
+ # execute user provided code
+ my ($exit_code, $inner_error, $outer_error, $orig_pid, @result);
+ {
+ $orig_pid = $$;
+ local *STDIN = *CT_ORIG_STDIN if $localize{stdin}; # get original, not proxy STDIN
+ # _debug( "# finalizing layers ...\n" );
+ _relayer(\*STDOUT, $layers{stdout}) if $do_stdout;
+ _relayer(\*STDERR, $layers{stderr}) if $do_stderr;
+ # _debug( "# running code $code ...\n" );
+ my $old_eval_err=$@;
+ undef $@;
+ eval { @result = $code->(); $inner_error = $@ };
+ $exit_code = $?; # save this for later
+ $outer_error = $@; # save this for later
+ STDOUT->flush if $do_stdout;
+ STDERR->flush if $do_stderr;
+ $@ = $old_eval_err;
+ }
+ # restore prior filehandles and shut down tees
+ # _debug( "# restoring filehandles ...\n" );
+ _open_std( $stash->{old} );
+ _close( $_ ) for values %{$stash->{old}}; # don't leak fds
+ # shouldn't need relayering originals, but see rt.perl.org #114404
+ _relayer(\*STDOUT, $layers{stdout}) if $do_stdout;
+ _relayer(\*STDERR, $layers{stderr}) if $do_stderr;
+ _unproxy( %proxy_std );
+ # _debug( "# killing tee subprocesses ...\n" ) if $do_tee;
+ _kill_tees( $stash ) if $do_tee;
+ # return captured output, but shortcut in void context
+ # unless we have to echo output to tied/scalar handles;
+ my %got;
+ if ( $orig_pid == $$ and ( defined wantarray or ($do_tee && keys %localize) ) ) {
+ for ( keys %do ) {
+ _relayer($stash->{capture}{$_}, $layers{$_});
+ $got{$_} = _slurp($_, $stash);
+ # _debug("# slurped " . length($got{$_}) . " bytes from $_\n");
+ }
+ print CT_ORIG_STDOUT $got{stdout}
+ if $do_stdout && $do_tee && $localize{stdout};
+ print CT_ORIG_STDERR $got{stderr}
+ if $do_stderr && $do_tee && $localize{stderr};
+ }
+ $? = $exit_code;
+ $@ = $inner_error if $inner_error;
+ die $outer_error if $outer_error;
+ # _debug( "# ending _capture_tee with (@_)...\n" );
+ return unless defined wantarray;
+ my @return;
+ push @return, $got{stdout} if $do_stdout;
+ push @return, $got{stderr} if $do_stderr && ! $do_merge;
+ push @return, @result;
+ return wantarray ? @return : $return[0];
+ }
+
+ 1;
+
+ __END__
+
+ =pod
+
+ =encoding UTF-8
+
+ =head1 NAME
+
+ Capture::Tiny - Capture STDOUT and STDERR from Perl, XS or external programs
+
+ =head1 VERSION
+
+ version 0.48
+
+ =head1 SYNOPSIS
+
+ use Capture::Tiny ':all';
+
+ # capture from external command
+
+ ($stdout, $stderr, $exit) = capture {
+ system( $cmd, @args );
+ };
+
+ # capture from arbitrary code (Perl or external)
+
+ ($stdout, $stderr, @result) = capture {
+ # your code here
+ };
+
+ # capture partial or merged output
+
+ $stdout = capture_stdout { ... };
+ $stderr = capture_stderr { ... };
+ $merged = capture_merged { ... };
+
+ # tee output
+
+ ($stdout, $stderr) = tee {
+ # your code here
+ };
+
+ $stdout = tee_stdout { ... };
+ $stderr = tee_stderr { ... };
+ $merged = tee_merged { ... };
+
+ =head1 DESCRIPTION
+
+ Capture::Tiny provides a simple, portable way to capture almost anything sent
+ to STDOUT or STDERR, regardless of whether it comes from Perl, from XS code or
+ from an external program. Optionally, output can be teed so that it is
+ captured while being passed through to the original filehandles. Yes, it even
+ works on Windows (usually). Stop guessing which of a dozen capturing modules
+ to use in any particular situation and just use this one.
+
+ =head1 USAGE
+
+ The following functions are available. None are exported by default.
+
+ =head2 capture
+
+ ($stdout, $stderr, @result) = capture \&code;
+ $stdout = capture \&code;
+
+ The C<capture> function takes a code reference and returns what is sent to
+ STDOUT and STDERR as well as any return values from the code reference. In
+ scalar context, it returns only STDOUT. If no output was received for a
+ filehandle, it returns an empty string for that filehandle. Regardless of calling
+ context, all output is captured -- nothing is passed to the existing filehandles.
+
+ It is prototyped to take a subroutine reference as an argument. Thus, it
+ can be called in block form:
+
+ ($stdout, $stderr) = capture {
+ # your code here ...
+ };
+
+ Note that the coderef is evaluated in list context. If you wish to force
+ scalar context on the return value, you must use the C<scalar> keyword.
+
+ ($stdout, $stderr, $count) = capture {
+ my @list = qw/one two three/;
+ return scalar @list; # $count will be 3
+ };
+
+ Also note that within the coderef, the C<@_> variable will be empty. So don't
+ use arguments from a surrounding subroutine without copying them to an array
+ first:
+
+ sub wont_work {
+ my ($stdout, $stderr) = capture { do_stuff( @_ ) }; # WRONG
+ ...
+ }
+
+ sub will_work {
+ my @args = @_;
+ my ($stdout, $stderr) = capture { do_stuff( @args ) }; # RIGHT
+ ...
+ }
+
+ Captures are normally done to an anonymous temporary filehandle. To
+ capture via a named file (e.g. to externally monitor a long-running capture),
+ provide custom filehandles as a trailing list of option pairs:
+
+ my $out_fh = IO::File->new("out.txt", "w+");
+ my $err_fh = IO::File->new("out.txt", "w+");
+ capture { ... } stdout => $out_fh, stderr => $err_fh;
+
+ The filehandles must be read/write and seekable. Modifying the files or
+ filehandles during a capture operation will give unpredictable results.
+ Existing IO layers on them may be changed by the capture.
+
+ When called in void context, C<capture> saves memory and time by
+ not reading back from the capture handles.
+
+ =head2 capture_stdout
+
+ ($stdout, @result) = capture_stdout \&code;
+ $stdout = capture_stdout \&code;
+
+ The C<capture_stdout> function works just like C<capture> except only
+ STDOUT is captured. STDERR is not captured.
+
+ =head2 capture_stderr
+
+ ($stderr, @result) = capture_stderr \&code;
+ $stderr = capture_stderr \&code;
+
+ The C<capture_stderr> function works just like C<capture> except only
+ STDERR is captured. STDOUT is not captured.
+
+ =head2 capture_merged
+
+ ($merged, @result) = capture_merged \&code;
+ $merged = capture_merged \&code;
+
+ The C<capture_merged> function works just like C<capture> except STDOUT and
+ STDERR are merged. (Technically, STDERR is redirected to the same capturing
+ handle as STDOUT before executing the function.)
+
+ Caution: STDOUT and STDERR output in the merged result are not guaranteed to be
+ properly ordered due to buffering.
+
+ =head2 tee
+
+ ($stdout, $stderr, @result) = tee \&code;
+ $stdout = tee \&code;
+
+ The C<tee> function works just like C<capture>, except that output is captured
+ as well as passed on to the original STDOUT and STDERR.
+
+ When called in void context, C<tee> saves memory and time by
+ not reading back from the capture handles, except when the
+ original STDOUT OR STDERR were tied or opened to a scalar
+ handle.
+
+ =head2 tee_stdout
+
+ ($stdout, @result) = tee_stdout \&code;
+ $stdout = tee_stdout \&code;
+
+ The C<tee_stdout> function works just like C<tee> except only
+ STDOUT is teed. STDERR is not teed (output goes to STDERR as usual).
+
+ =head2 tee_stderr
+
+ ($stderr, @result) = tee_stderr \&code;
+ $stderr = tee_stderr \&code;
+
+ The C<tee_stderr> function works just like C<tee> except only
+ STDERR is teed. STDOUT is not teed (output goes to STDOUT as usual).
+
+ =head2 tee_merged
+
+ ($merged, @result) = tee_merged \&code;
+ $merged = tee_merged \&code;
+
+ The C<tee_merged> function works just like C<capture_merged> except that output
+ is captured as well as passed on to STDOUT.
+
+ Caution: STDOUT and STDERR output in the merged result are not guaranteed to be
+ properly ordered due to buffering.
+
+ =head1 LIMITATIONS
+
+ =head2 Portability
+
+ Portability is a goal, not a guarantee. C<tee> requires fork, except on
+ Windows where C<system(1, @cmd)> is used instead. Not tested on any
+ particularly esoteric platforms yet. See the
+ L<CPAN Testers Matrix|http://matrix.cpantesters.org/?dist=Capture-Tiny>
+ for test result by platform.
+
+ =head2 PerlIO layers
+
+ Capture::Tiny does its best to preserve PerlIO layers such as ':utf8' or
+ ':crlf' when capturing (only for Perl 5.8.1+) . Layers should be applied to
+ STDOUT or STDERR I<before> the call to C<capture> or C<tee>. This may not work
+ for tied filehandles (see below).
+
+ =head2 Modifying filehandles before capturing
+
+ Generally speaking, you should do little or no manipulation of the standard IO
+ filehandles prior to using Capture::Tiny. In particular, closing, reopening,
+ localizing or tying standard filehandles prior to capture may cause a variety of
+ unexpected, undesirable and/or unreliable behaviors, as described below.
+ Capture::Tiny does its best to compensate for these situations, but the
+ results may not be what you desire.
+
+ =head3 Closed filehandles
+
+ Capture::Tiny will work even if STDIN, STDOUT or STDERR have been previously
+ closed. However, since they will be reopened to capture or tee output, any
+ code within the captured block that depends on finding them closed will, of
+ course, not find them to be closed. If they started closed, Capture::Tiny will
+ close them again when the capture block finishes.
+
+ Note that this reopening will happen even for STDIN or a filehandle not being
+ captured to ensure that the filehandle used for capture is not opened to file
+ descriptor 0, as this causes problems on various platforms.
+
+ Prior to Perl 5.12, closed STDIN combined with PERL_UNICODE=D leaks filehandles
+ and also breaks tee() for undiagnosed reasons. So don't do that.
+
+ =head3 Localized filehandles
+
+ If code localizes any of Perl's standard filehandles before capturing, the capture
+ will affect the localized filehandles and not the original ones. External system
+ calls are not affected by localizing a filehandle in Perl and will continue
+ to send output to the original filehandles (which will thus not be captured).
+
+ =head3 Scalar filehandles
+
+ If STDOUT or STDERR are reopened to scalar filehandles prior to the call to
+ C<capture> or C<tee>, then Capture::Tiny will override the output filehandle for
+ the duration of the C<capture> or C<tee> call and then, for C<tee>, send captured
+ output to the output filehandle after the capture is complete. (Requires Perl
+ 5.8)
+
+ Capture::Tiny attempts to preserve the semantics of STDIN opened to a scalar
+ reference, but note that external processes will not be able to read from such
+ a handle. Capture::Tiny tries to ensure that external processes will read from
+ the null device instead, but this is not guaranteed.
+
+ =head3 Tied output filehandles
+
+ If STDOUT or STDERR are tied prior to the call to C<capture> or C<tee>, then
+ Capture::Tiny will attempt to override the tie for the duration of the
+ C<capture> or C<tee> call and then send captured output to the tied filehandle after
+ the capture is complete. (Requires Perl 5.8)
+
+ Capture::Tiny may not succeed resending UTF-8 encoded data to a tied
+ STDOUT or STDERR filehandle. Characters may appear as bytes. If the tied filehandle
+ is based on L<Tie::StdHandle>, then Capture::Tiny will attempt to determine
+ appropriate layers like C<:utf8> from the underlying filehandle and do the right
+ thing.
+
+ =head3 Tied input filehandle
+
+ Capture::Tiny attempts to preserve the semantics of tied STDIN, but this
+ requires Perl 5.8 and is not entirely predictable. External processes
+ will not be able to read from such a handle.
+
+ Unless having STDIN tied is crucial, it may be safest to localize STDIN when
+ capturing:
+
+ my ($out, $err) = do { local *STDIN; capture { ... } };
+
+ =head2 Modifying filehandles during a capture
+
+ Attempting to modify STDIN, STDOUT or STDERR I<during> C<capture> or C<tee> is
+ almost certainly going to cause problems. Don't do that.
+
+ =head3 Forking inside a capture
+
+ Forks aren't portable. The behavior of filehandles during a fork is even
+ less so. If Capture::Tiny detects that a fork has occurred within a
+ capture, it will shortcut in the child process and return empty strings for
+ captures. Other problems may occur in the child or parent, as well.
+ Forking in a capture block is not recommended.
+
+ =head3 Using threads
+
+ Filehandles are global. Mixing up I/O and captures in different threads
+ without coordination is going to cause problems. Besides, threads are
+ officially discouraged.
+
+ =head3 Dropping privileges during a capture
+
+ If you drop privileges during a capture, temporary files created to
+ facilitate the capture may not be cleaned up afterwards.
+
+ =head2 No support for Perl 5.8.0
+
+ It's just too buggy when it comes to layers and UTF-8. Perl 5.8.1 or later
+ is recommended.
+
+ =head2 Limited support for Perl 5.6
+
+ Perl 5.6 predates PerlIO. UTF-8 data may not be captured correctly.
+
+ =head1 ENVIRONMENT
+
+ =head2 PERL_CAPTURE_TINY_TIMEOUT
+
+ Capture::Tiny uses subprocesses internally for C<tee>. By default,
+ Capture::Tiny will timeout with an error if such subprocesses are not ready to
+ receive data within 30 seconds (or whatever is the value of
+ C<$Capture::Tiny::TIMEOUT>). An alternate timeout may be specified by setting
+ the C<PERL_CAPTURE_TINY_TIMEOUT> environment variable. Setting it to zero will
+ disable timeouts. B<NOTE>, this does not timeout the code reference being
+ captured -- this only prevents Capture::Tiny itself from hanging your process
+ waiting for its child processes to be ready to proceed.
+
+ =head1 SEE ALSO
+
+ This module was inspired by L<IO::CaptureOutput>, which provides
+ similar functionality without the ability to tee output and with more
+ complicated code and API. L<IO::CaptureOutput> does not handle layers
+ or most of the unusual cases described in the L</Limitations> section and
+ I no longer recommend it.
+
+ There are many other CPAN modules that provide some sort of output capture,
+ albeit with various limitations that make them appropriate only in particular
+ circumstances. I'm probably missing some. The long list is provided to show
+ why I felt Capture::Tiny was necessary.
+
+ =over 4
+
+ =item *
+
+ L<IO::Capture>
+
+ =item *
+
+ L<IO::Capture::Extended>
+
+ =item *
+
+ L<IO::CaptureOutput>
+
+ =item *
+
+ L<IPC::Capture>
+
+ =item *
+
+ L<IPC::Cmd>
+
+ =item *
+
+ L<IPC::Open2>
+
+ =item *
+
+ L<IPC::Open3>
+
+ =item *
+
+ L<IPC::Open3::Simple>
+
+ =item *
+
+ L<IPC::Open3::Utils>
+
+ =item *
+
+ L<IPC::Run>
+
+ =item *
+
+ L<IPC::Run::SafeHandles>
+
+ =item *
+
+ L<IPC::Run::Simple>
+
+ =item *
+
+ L<IPC::Run3>
+
+ =item *
+
+ L<IPC::System::Simple>
+
+ =item *
+
+ L<Tee>
+
+ =item *
+
+ L<IO::Tee>
+
+ =item *
+
+ L<File::Tee>
+
+ =item *
+
+ L<Filter::Handle>
+
+ =item *
+
+ L<Tie::STDERR>
+
+ =item *
+
+ L<Tie::STDOUT>
+
+ =item *
+
+ L<Test::Output>
+
+ =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<https://github.com/dagolden/Capture-Tiny/issues>.
+ 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<https://github.com/dagolden/Capture-Tiny>
+
+ git clone https://github.com/dagolden/Capture-Tiny.git
+
+ =head1 AUTHOR
+
+ David Golden <dagolden@cpan.org>
+
+ =head1 CONTRIBUTORS
+
+ =for stopwords Dagfinn Ilmari Mannsåker David E. Wheeler fecundf Graham Knop Peter Rabbitson
+
+ =over 4
+
+ =item *
+
+ Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>
+
+ =item *
+
+ David E. Wheeler <david@justatheory.com>
+
+ =item *
+
+ fecundf <not.com+github@gmail.com>
+
+ =item *
+
+ Graham Knop <haarg@haarg.org>
+
+ =item *
+
+ Peter Rabbitson <ribasushi@cpan.org>
+
+ =back
+
+ =head1 COPYRIGHT AND LICENSE
+
+ This software is Copyright (c) 2009 by David Golden.
+
+ This is free software, licensed under:
+
+ The Apache License, Version 2.0, January 2004
+
+ =cut
+CAPTURE_TINY
+
$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.28");
+ use version; our $VERSION = version->declare("v1.0.34");
1;
__END__
@@ -34138,6 +10933,10 @@ $fatpacked{"Carton.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON';
> carton install
> carton exec starman -p 8080 myapp.psgi
+ # carton exec is optional
+ > perl -Ilocal/lib/perl5 local/bin/starman -p 8080 myapp.psgi
+ > PERL5LIB=/path/to/local/lib/perl5 /path/to/local/bin/starman -p 8080 myapp.psgi
+
=head1 AVAILABILITY
Carton only works with perl installation with the complete set of core
@@ -34145,8 +10944,9 @@ $fatpacked{"Carton.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON';
stripped from core, Carton is not expected to work correctly.
Also, Carton requires you to run your command/application with
- C<carton exec> command, which means it's difficult or impossible to
- run in an embedded perl use case such as mod_perl.
+ C<carton exec> command or to include the I<local/lib/perl5> directory
+ in your Perl library search path (using C<PERL5LIB>, C<-I>, or
+ L<lib>).
=head1 DESCRIPTION
@@ -34196,6 +10996,24 @@ $fatpacked{"Carton.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON';
> git add cpanfile cpanfile.snapshot
> git commit -m "Added Plack and Starman"
+ =head2 Specifying a CPAN distribution
+
+ You can pin a module resolution to a specific distribution using a
+ combination of C<dist>, C<mirror> and C<url> options in C<cpanfile>.
+
+ # specific distribution on PAUSE
+ requires 'Plack', '== 0.9980',
+ dist => 'MIYAGAWA/Plack-0.9980.tar.gz';
+
+ # local mirror (darkpan)
+ requires 'Plack', '== 0.9981',
+ dist => 'MYCOMPANY/Plack-0.9981-p1.tar.gz',
+ mirror => 'https://pause.local/';
+
+ # URL
+ requires 'Plack', '== 1.1000',
+ url => 'https://pause.local/authors/id/M/MY/MYCOMPANY/Plack-1.1000.tar.gz';
+
=head2 Deploying your application
Once you've done installing all the dependencies, you can push your
@@ -34229,6 +11047,13 @@ $fatpacked{"Carton.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CARTON';
CPAN Meta DB or downloading files from CPAN mirrors upon deployment
time.
+ As of Carton v1.0.32, the bundle also includes a package index
+ allowing you to simply use L<cpanm> (which has a
+ L<standalone version|App::cpanminus/"Downloading the standalone executable">)
+ instead of installing Carton on a remote machine.
+
+ > cpanm -L local --from "$PWD/vendor/cache" --installdeps --notest --quiet .
+
=head1 PERL VERSIONS
When you take a snapshot in one perl version and deploy on another
@@ -34301,7 +11126,6 @@ $fatpacked{"Carton/Builder.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'
cascade => sub { 1 },
without => sub { [] },
cpanfile => undef,
- fatscript => sub { $_[0]->_build_fatscript },
};
sub effective_mirrors {
@@ -34337,12 +11161,35 @@ $fatpacked{"Carton/Builder.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'
warn "Couldn't find @{[ $dist->pathname ]}\n";
}
}
+
+ my $has_io_gzip = eval { require IO::Compress::Gzip; 1 };
+
+ my $ext = $has_io_gzip ? ".txt.gz" : ".txt";
+ my $index = $cache_path->child("modules/02packages.details$ext");
+ $index->parent->mkpath;
+
+ warn "Writing $index\n";
+
+ my $out = $index->openw;
+ if ($has_io_gzip) {
+ $out = IO::Compress::Gzip->new($out)
+ or die "gzip failed: $IO::Compress::Gzip::GzipError";
+ }
+
+ $snapshot->index->write($out);
+ close $out;
+
+ unless ($has_io_gzip) {
+ unlink "$index.gz";
+ !system 'gzip', $index
+ or die "Running gzip command failed: $!";
+ }
}
sub install {
my($self, $path) = @_;
- $self->run_cpanm(
+ $self->run_install(
"-L", $path,
(map { ("--mirror", $_->url) } $self->effective_mirrors),
( $self->index ? ("--mirror-index", $self->index) : () ),
@@ -34372,7 +11219,7 @@ $fatpacked{"Carton/Builder.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'
sub update {
my($self, $path, @modules) = @_;
- $self->run_cpanm(
+ $self->run_install(
"-L", $path,
(map { ("--mirror", $_->url) } $self->effective_mirrors),
( $self->custom_mirror ? "--mirror-only" : () ),
@@ -34381,29 +11228,17 @@ $fatpacked{"Carton/Builder.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'
) or die "Updating modules failed\n";
}
- sub _build_fatscript {
- my $self = shift;
+ sub run_install {
+ my($self, @args) = @_;
- 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";
- }
+ require Menlo::CLI::Compat;
+ local $ENV{PERL_CPANM_OPT};
- return $fatscript;
- }
+ my $cli = Menlo::CLI::Compat->new;
+ $cli->parse_options("--quiet", "--notest", @args);
+ $cli->run;
- sub run_cpanm {
- my($self, @args) = @_;
- local $ENV{PERL_CPANM_OPT};
- !system $^X, $self->fatscript, "--quiet", "--notest", @args;
+ !$cli->status;
}
1;
@@ -35278,10 +12113,24 @@ $fatpacked{"Carton/Packer.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'C
}
sub required_modules {
- my($self, $packer) = @_;
+ my $self = shift;
+
+ my %requirements;
+ for my $dist (qw( Carton Menlo-Legacy Menlo )) {
+ $requirements{$_} = 1 for $self->required_modules_for($dist);
+ }
+
+ # these modules are needed, but lazy-loaded, so FatPacker wont bundle them by default.
+ my @extra = qw(Menlo::Index::Mirror);
+
+ [ keys %requirements, @extra ];
+ }
+
+ sub required_modules_for {
+ my($self, $dist) = @_;
- my $meta = $self->installed_meta('Carton')
- or die "Couldn't find install metadata for Carton";
+ my $meta = $self->installed_meta($dist)
+ or die "Couldn't find install metadata for $dist";
my %excludes = (
perl => 1,
@@ -35289,10 +12138,8 @@ $fatpacked{"Carton/Packer.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'C
'Module::Build' => 1,
);
- my @requirements = grep !$excludes{$_},
+ grep !$excludes{$_},
$meta->effective_prereqs->requirements_for('runtime', 'requires')->required_modules;
-
- return \@requirements;
}
sub installed_meta {
@@ -35769,14 +12616,14 @@ $fatpacked{"Carton/Util.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CAR
}
sub from_json {
- require JSON;
- JSON::decode_json(@_);
+ require JSON::PP;
+ JSON::PP->new->utf8->decode($_[0])
}
sub to_json {
my($data) = @_;
- require JSON;
- JSON->new->utf8->pretty->canonical->encode($data);
+ require JSON::PP;
+ JSON::PP->new->utf8->pretty->canonical->encode($data);
}
1;
@@ -36422,8 +13269,8 @@ $fatpacked{"ExtUtils/Command.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
@ISA = qw(Exporter);
@EXPORT = qw(cp rm_f rm_rf mv cat eqtime mkpath touch test_f test_d chmod
dos2unix);
- $VERSION = '7.30';
- $VERSION = eval $VERSION;
+ $VERSION = '7.36';
+ $VERSION =~ tr/_//d;
my $Is_VMS = $^O eq 'VMS';
my $Is_VMS_mode = $Is_VMS;
@@ -36809,8 +13656,8 @@ $fatpacked{"ExtUtils/Command/MM.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
our @EXPORT = qw(test_harness pod2man perllocal_install uninstall
warn_if_old_packlist test_s cp_nonempty);
- our $VERSION = '7.30';
- $VERSION = eval $VERSION;
+ our $VERSION = '7.36';
+ $VERSION =~ tr/_//d;
my $Is_VMS = $^O eq 'VMS';
@@ -37004,7 +13851,7 @@ $fatpacked{"ExtUtils/Command/MM.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
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
+ EXE_FILES any executables installed in a space separated
list
=cut
@@ -37122,6 +13969,539 @@ $fatpacked{"ExtUtils/Command/MM.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
1;
EXTUTILS_COMMAND_MM
+$fatpacked{"ExtUtils/Config.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_CONFIG';
+ package ExtUtils::Config;
+ $ExtUtils::Config::VERSION = '0.008';
+ use strict;
+ use warnings;
+ use Config;
+ use Data::Dumper ();
+
+ sub new {
+ my ($pack, $args) = @_;
+ return bless {
+ values => ($args ? { %$args } : {}),
+ }, $pack;
+ }
+
+ sub get {
+ my ($self, $key) = @_;
+ return exists $self->{values}{$key} ? $self->{values}{$key} : $Config{$key};
+ }
+
+ sub exists {
+ my ($self, $key) = @_;
+ return exists $self->{values}{$key} || exists $Config{$key};
+ }
+
+ sub values_set {
+ my $self = shift;
+ return { %{$self->{values}} };
+ }
+
+ sub all_config {
+ my $self = shift;
+ return { %Config, %{ $self->{values}} };
+ }
+
+ sub serialize {
+ my $self = shift;
+ return $self->{serialized} ||= Data::Dumper->new([$self->values_set])->Terse(1)->Sortkeys(1)->Dump;
+ }
+
+ 1;
+
+ # ABSTRACT: A wrapper for perl's configuration
+
+ __END__
+
+ =pod
+
+ =encoding UTF-8
+
+ =head1 NAME
+
+ ExtUtils::Config - A wrapper for perl's configuration
+
+ =head1 VERSION
+
+ version 0.008
+
+ =head1 SYNOPSIS
+
+ my $config = ExtUtils::Config->new();
+ $config->get('installsitelib');
+
+ =head1 DESCRIPTION
+
+ ExtUtils::Config is an abstraction around the %Config hash. By itself it is not a particularly interesting module by any measure, however it ties together a family of modern toolchain modules.
+
+ =head1 METHODS
+
+ =head2 new(\%config)
+
+ Create a new ExtUtils::Config object. The values in C<\%config> are used to initialize the object.
+
+ =head2 get($key)
+
+ Get the value of C<$key>. If not overridden it will return the value in %Config.
+
+ =head2 exists($key)
+
+ Tests for the existence of $key.
+
+ =head2 values_set()
+
+ Get a hashref of all overridden values.
+
+ =head2 all_config()
+
+ Get a hashref of the complete configuration, including overrides.
+
+ =head2 serialize()
+
+ This method serializes the object to some kind of string.
+
+ =head1 AUTHORS
+
+ =over 4
+
+ =item *
+
+ Ken Williams <kwilliams@cpan.org>
+
+ =item *
+
+ Leon Timmermans <leont@cpan.org>
+
+ =back
+
+ =head1 COPYRIGHT AND LICENSE
+
+ This software is copyright (c) 2006 by Ken Williams, 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
+EXTUTILS_CONFIG
+
+$fatpacked{"ExtUtils/Helpers.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_HELPERS';
+ package ExtUtils::Helpers;
+ $ExtUtils::Helpers::VERSION = '0.026';
+ use strict;
+ use warnings FATAL => 'all';
+ use Exporter 5.57 'import';
+
+ use Config;
+ use File::Basename qw/basename/;
+ use File::Spec::Functions qw/splitpath canonpath abs2rel splitdir/;
+ use Text::ParseWords 3.24 ();
+
+ our @EXPORT_OK = qw/make_executable split_like_shell man1_pagename man3_pagename detildefy/;
+
+ BEGIN {
+ my %impl_for = ( MSWin32 => 'Windows', VMS => 'VMS');
+ my $package = 'ExtUtils::Helpers::' . ($impl_for{$^O} || 'Unix');
+ my $impl = $impl_for{$^O} || 'Unix';
+ require "ExtUtils/Helpers/$impl.pm";
+ "ExtUtils::Helpers::$impl"->import();
+ }
+
+ sub split_like_shell {
+ my ($string) = @_;
+
+ return if not defined $string;
+ $string =~ s/^\s+|\s+$//g;
+ return if not length $string;
+
+ return Text::ParseWords::shellwords($string);
+ }
+
+ sub man1_pagename {
+ my $filename = shift;
+ return basename($filename).".$Config{man1ext}";
+ }
+
+ my %separator = (
+ MSWin32 => '.',
+ VMS => '__',
+ os2 => '.',
+ cygwin => '.',
+ );
+ my $separator = $separator{$^O} || '::';
+
+ sub man3_pagename {
+ my ($filename, $base) = @_;
+ $base ||= 'lib';
+ my ($vols, $dirs, $file) = splitpath(canonpath(abs2rel($filename, $base)));
+ $file = basename($file, qw/.pm .pod/);
+ my @dirs = grep { length } splitdir($dirs);
+ return join $separator, @dirs, "$file.$Config{man3ext}";
+ }
+
+ 1;
+
+ # ABSTRACT: Various portability utilities for module builders
+
+ __END__
+
+ =pod
+
+ =encoding utf-8
+
+ =head1 NAME
+
+ ExtUtils::Helpers - Various portability utilities for module builders
+
+ =head1 VERSION
+
+ version 0.026
+
+ =head1 SYNOPSIS
+
+ use ExtUtils::Helpers qw/make_executable split_like_shell/;
+
+ unshift @ARGV, split_like_shell($ENV{PROGRAM_OPTS});
+ write_script_to('Build');
+ make_executable('Build');
+
+ =head1 DESCRIPTION
+
+ This module provides various portable helper functions for module building modules.
+
+ =head1 FUNCTIONS
+
+ =head2 make_executable($filename)
+
+ This makes a perl script executable.
+
+ =head2 split_like_shell($string)
+
+ This function splits a string the same way as the local platform does.
+
+ =head2 detildefy($path)
+
+ This function substitutes a tilde at the start of a path with the users homedir in an appropriate manner.
+
+ =head2 man1_pagename($filename)
+
+ Returns the man page filename for a script.
+
+ =head2 man3_pagename($filename, $basedir)
+
+ Returns the man page filename for a Perl library.
+
+ =head1 ACKNOWLEDGEMENTS
+
+ Olivier Mengué and Christian Walde made C<make_executable> work on Windows.
+
+ =head1 AUTHORS
+
+ =over 4
+
+ =item *
+
+ Ken Williams <kwilliams@cpan.org>
+
+ =item *
+
+ Leon Timmermans <leont@cpan.org>
+
+ =back
+
+ =head1 COPYRIGHT AND LICENSE
+
+ This software is copyright (c) 2004 by Ken Williams, 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
+EXTUTILS_HELPERS
+
+$fatpacked{"ExtUtils/Helpers/Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_HELPERS_UNIX';
+ package ExtUtils::Helpers::Unix;
+ $ExtUtils::Helpers::Unix::VERSION = '0.026';
+ use strict;
+ use warnings FATAL => 'all';
+
+ use Exporter 5.57 'import';
+ our @EXPORT = qw/make_executable detildefy/;
+
+ use Carp qw/croak/;
+ use Config;
+
+ my $layer = $] >= 5.008001 ? ":raw" : "";
+
+ sub make_executable {
+ my $filename = shift;
+ my $current_mode = (stat $filename)[2] + 0;
+ if (-T $filename) {
+ open my $fh, "<$layer", $filename;
+ my @lines = <$fh>;
+ if (@lines and $lines[0] =~ s{ \A \#! \s* (?:/\S+/)? perl \b (.*) \z }{$Config{startperl}$1}xms) {
+ open my $out, ">$layer", "$filename.new" or croak "Couldn't open $filename.new: $!";
+ print $out @lines;
+ close $out;
+ rename $filename, "$filename.bak" or croak "Couldn't rename $filename to $filename.bak";
+ rename "$filename.new", $filename or croak "Couldn't rename $filename.new to $filename";
+ unlink "$filename.bak";
+ }
+ }
+ chmod $current_mode | oct(111), $filename;
+ return;
+ }
+
+ sub detildefy {
+ my $value = shift;
+ # tilde with optional username
+ for ($value) {
+ s{ ^ ~ (?= /|$)} [ $ENV{HOME} || (getpwuid $>)[7] ]ex or # tilde without user name
+ s{ ^ ~ ([^/]+) (?= /|$) } { (getpwnam $1)[7] || "~$1" }ex; # tilde with user name
+ }
+ return $value;
+ }
+
+ 1;
+
+ # ABSTRACT: Unix specific helper bits
+
+ __END__
+
+ =pod
+
+ =encoding UTF-8
+
+ =head1 NAME
+
+ ExtUtils::Helpers::Unix - Unix specific helper bits
+
+ =head1 VERSION
+
+ version 0.026
+
+ =for Pod::Coverage make_executable
+ split_like_shell
+ detildefy
+
+ =head1 AUTHORS
+
+ =over 4
+
+ =item *
+
+ Ken Williams <kwilliams@cpan.org>
+
+ =item *
+
+ Leon Timmermans <leont@cpan.org>
+
+ =back
+
+ =head1 COPYRIGHT AND LICENSE
+
+ This software is copyright (c) 2004 by Ken Williams, 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
+EXTUTILS_HELPERS_UNIX
+
+$fatpacked{"ExtUtils/Helpers/VMS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_HELPERS_VMS';
+ package ExtUtils::Helpers::VMS;
+ $ExtUtils::Helpers::VMS::VERSION = '0.026';
+ use strict;
+ use warnings FATAL => 'all';
+
+ use Exporter 5.57 'import';
+ our @EXPORT = qw/make_executable detildefy/;
+
+ use File::Copy qw/copy/;
+
+ sub make_executable {
+ my $filename = shift;
+ my $batchname = "$filename.com";
+ copy($filename, $batchname);
+ ExtUtils::Helpers::Unix::make_executable($batchname);
+ return;
+ }
+
+ sub detildefy {
+ my $arg = shift;
+
+ # Apparently double ~ are not translated.
+ return $arg if ($arg =~ /^~~/);
+
+ # Apparently ~ followed by whitespace are not translated.
+ return $arg if ($arg =~ /^~ /);
+
+ if ($arg =~ /^~/) {
+ my $spec = $arg;
+
+ # Remove the tilde
+ $spec =~ s/^~//;
+
+ # Remove any slash following the tilde if present.
+ $spec =~ s#^/##;
+
+ # break up the paths for the merge
+ my $home = VMS::Filespec::unixify($ENV{HOME});
+
+ # In the default VMS mode, the trailing slash is present.
+ # In Unix report mode it is not. The parsing logic assumes that
+ # it is present.
+ $home .= '/' unless $home =~ m#/$#;
+
+ # Trivial case of just ~ by it self
+ if ($spec eq '') {
+ $home =~ s#/$##;
+ return $home;
+ }
+
+ my ($hvol, $hdir, $hfile) = File::Spec::Unix->splitpath($home);
+ if ($hdir eq '') {
+ # Someone has tampered with $ENV{HOME}
+ # So hfile is probably the directory since this should be
+ # a path.
+ $hdir = $hfile;
+ }
+
+ my ($vol, $dir, $file) = File::Spec::Unix->splitpath($spec);
+
+ my @hdirs = File::Spec::Unix->splitdir($hdir);
+ my @dirs = File::Spec::Unix->splitdir($dir);
+
+ unless ($arg =~ m#^~/#) {
+ # There is a home directory after the tilde, but it will already
+ # be present in in @hdirs so we need to remove it by from @dirs.
+
+ shift @dirs;
+ }
+ my $newdirs = File::Spec::Unix->catdir(@hdirs, @dirs);
+
+ $arg = File::Spec::Unix->catpath($hvol, $newdirs, $file);
+ }
+ return $arg;
+ }
+
+ # ABSTRACT: VMS specific helper bits
+
+ __END__
+
+ =pod
+
+ =encoding UTF-8
+
+ =head1 NAME
+
+ ExtUtils::Helpers::VMS - VMS specific helper bits
+
+ =head1 VERSION
+
+ version 0.026
+
+ =for Pod::Coverage make_executable
+ detildefy
+
+ =head1 AUTHORS
+
+ =over 4
+
+ =item *
+
+ Ken Williams <kwilliams@cpan.org>
+
+ =item *
+
+ Leon Timmermans <leont@cpan.org>
+
+ =back
+
+ =head1 COPYRIGHT AND LICENSE
+
+ This software is copyright (c) 2004 by Ken Williams, 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
+EXTUTILS_HELPERS_VMS
+
+$fatpacked{"ExtUtils/Helpers/Windows.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_HELPERS_WINDOWS';
+ package ExtUtils::Helpers::Windows;
+ $ExtUtils::Helpers::Windows::VERSION = '0.026';
+ use strict;
+ use warnings FATAL => 'all';
+
+ use Exporter 5.57 'import';
+ our @EXPORT = qw/make_executable detildefy/;
+
+ use Config;
+ use Carp qw/carp croak/;
+ use ExtUtils::PL2Bat 'pl2bat';
+
+ sub make_executable {
+ my $script = shift;
+ if (-T $script && $script !~ / \. (?:bat|cmd) $ /x) {
+ pl2bat(in => $script, update => 1);
+ }
+ return;
+ }
+
+ sub detildefy {
+ my $value = shift;
+ $value =~ s{ ^ ~ (?= [/\\] | $ ) }[$ENV{USERPROFILE}]x if $ENV{USERPROFILE};
+ return $value;
+ }
+
+ 1;
+
+ # ABSTRACT: Windows specific helper bits
+
+ __END__
+
+ =pod
+
+ =encoding UTF-8
+
+ =head1 NAME
+
+ ExtUtils::Helpers::Windows - Windows specific helper bits
+
+ =head1 VERSION
+
+ version 0.026
+
+ =for Pod::Coverage make_executable
+ split_like_shell
+ detildefy
+
+ =head1 AUTHORS
+
+ =over 4
+
+ =item *
+
+ Ken Williams <kwilliams@cpan.org>
+
+ =item *
+
+ Leon Timmermans <leont@cpan.org>
+
+ =back
+
+ =head1 COPYRIGHT AND LICENSE
+
+ This software is copyright (c) 2004 by Ken Williams, 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
+EXTUTILS_HELPERS_WINDOWS
+
$fatpacked{"ExtUtils/Install.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_INSTALL';
package ExtUtils::Install;
use strict;
@@ -38481,6 +15861,634 @@ $fatpacked{"ExtUtils/Install.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
1;
EXTUTILS_INSTALL
+$fatpacked{"ExtUtils/InstallPaths.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_INSTALLPATHS';
+ package ExtUtils::InstallPaths;
+ $ExtUtils::InstallPaths::VERSION = '0.012';
+ use 5.006;
+ use strict;
+ use warnings;
+
+ use File::Spec ();
+ use Carp ();
+ use ExtUtils::Config 0.002;
+
+ my %complex_accessors = map { $_ => 1 } qw/prefix_relpaths install_sets/;
+ my %hash_accessors = map { $_ => 1 } qw/install_path install_base_relpaths original_prefix /;
+
+ my %defaults = (
+ installdirs => 'site',
+ install_base => undef,
+ prefix => undef,
+ verbose => 0,
+ create_packlist => 1,
+ dist_name => undef,
+ module_name => undef,
+ destdir => undef,
+ install_path => sub { {} },
+ install_sets => \&_default_install_sets,
+ original_prefix => \&_default_original_prefix,
+ install_base_relpaths => \&_default_base_relpaths,
+ prefix_relpaths => \&_default_prefix_relpaths,
+ );
+
+ sub _merge_shallow {
+ my ($name, $filter) = @_;
+ return sub {
+ my ($override, $config) = @_;
+ my $defaults = $defaults{$name}->($config);
+ $filter->($_) for grep $filter, values %$override;
+ return { %$defaults, %$override };
+ }
+ }
+
+ sub _merge_deep {
+ my ($name, $filter) = @_;
+ return sub {
+ my ($override, $config) = @_;
+ my $defaults = $defaults{$name}->($config);
+ my $pair_for = sub {
+ my $key = shift;
+ my %override = %{ $override->{$key} || {} };
+ $filter && $filter->($_) for values %override;
+ return $key => { %{ $defaults->{$key} }, %override };
+ };
+ return { map { $pair_for->($_) } keys %$defaults };
+ }
+ }
+
+ my %allowed_installdir = map { $_ => 1 } qw/core site vendor/;
+ my $must_be_relative = sub { Carp::croak('Value must be a relative path') if File::Spec->file_name_is_absolute($_[0]) };
+ my %deep_filter = map { $_ => $must_be_relative } qw/install_base_relpaths prefix_relpaths/;
+ my %filter = (
+ installdirs => sub {
+ my $value = shift;
+ $value = 'core', Carp::carp('Perhaps you meant installdirs to be "core" rather than "perl"?') if $value eq 'perl';
+ Carp::croak('installdirs must be one of "core", "site", or "vendor"') if not $allowed_installdir{$value};
+ return $value;
+ },
+ (map { $_ => _merge_shallow($_, $deep_filter{$_}) } qw/original_prefix install_base_relpaths/),
+ (map { $_ => _merge_deep($_, $deep_filter{$_}) } qw/install_sets prefix_relpaths/),
+ );
+
+ sub new {
+ my ($class, %args) = @_;
+ my $config = $args{config} || ExtUtils::Config->new;
+ my %self = (
+ config => $config,
+ map { $_ => exists $args{$_} ? $filter{$_} ? $filter{$_}->($args{$_}, $config) : $args{$_} : ref $defaults{$_} ? $defaults{$_}->($config) : $defaults{$_} } keys %defaults,
+ );
+ $self{module_name} ||= do { my $module_name = $self{dist_name}; $module_name =~ s/-/::/g; $module_name } if defined $self{dist_name};
+ return bless \%self, $class;
+ }
+
+ for my $attribute (keys %defaults) {
+ no strict qw/refs/;
+ *{$attribute} = $hash_accessors{$attribute} ?
+ sub {
+ my ($self, $key) = @_;
+ Carp::confess("$attribute needs key") if not defined $key;
+ return $self->{$attribute}{$key};
+ } :
+ $complex_accessors{$attribute} ?
+ sub {
+ my ($self, $installdirs, $key) = @_;
+ Carp::confess("$attribute needs installdir") if not defined $installdirs;
+ Carp::confess("$attribute needs key") if not defined $key;
+ return $self->{$attribute}{$installdirs}{$key};
+ } :
+ sub {
+ my $self = shift;
+ return $self->{$attribute};
+ };
+ }
+
+ my $script = $] > 5.008000 ? 'script' : 'bin';
+ my @install_sets_keys = qw/lib arch bin script bindoc libdoc binhtml libhtml/;
+ my @install_sets_tail = ('bin', $script, qw/man1dir man3dir html1dir html3dir/);
+ my %install_sets_values = (
+ core => [ qw/privlib archlib /, @install_sets_tail ],
+ site => [ map { "site$_" } qw/lib arch/, @install_sets_tail ],
+ vendor => [ map { "vendor$_" } qw/lib arch/, @install_sets_tail ],
+ );
+
+ sub _default_install_sets {
+ my $c = shift;
+
+ my %ret;
+ for my $installdir (qw/core site vendor/) {
+ @{$ret{$installdir}}{@install_sets_keys} = map { $c->get("install$_") } @{ $install_sets_values{$installdir} };
+ }
+ return \%ret;
+ }
+
+ sub _default_base_relpaths {
+ my $config = shift;
+ return {
+ lib => ['lib', 'perl5'],
+ arch => ['lib', 'perl5', $config->get('archname')],
+ bin => ['bin'],
+ script => ['bin'],
+ bindoc => ['man', 'man1'],
+ libdoc => ['man', 'man3'],
+ binhtml => ['html'],
+ libhtml => ['html'],
+ };
+ }
+
+ my %common_prefix_relpaths = (
+ bin => ['bin'],
+ script => ['bin'],
+ bindoc => ['man', 'man1'],
+ libdoc => ['man', 'man3'],
+ binhtml => ['html'],
+ libhtml => ['html'],
+ );
+
+ sub _default_prefix_relpaths {
+ my $c = shift;
+
+ my @libstyle = $c->get('installstyle') ? File::Spec->splitdir($c->get('installstyle')) : qw(lib perl5);
+ my $arch = $c->get('archname');
+ my $version = $c->get('version');
+
+ return {
+ core => {
+ lib => [@libstyle],
+ arch => [@libstyle, $version, $arch],
+ %common_prefix_relpaths,
+ },
+ vendor => {
+ lib => [@libstyle],
+ arch => [@libstyle, $version, $arch],
+ %common_prefix_relpaths,
+ },
+ site => {
+ lib => [@libstyle, 'site_perl'],
+ arch => [@libstyle, 'site_perl', $version, $arch],
+ %common_prefix_relpaths,
+ },
+ };
+ }
+
+ sub _default_original_prefix {
+ my $c = shift;
+
+ my %ret = (
+ core => $c->get('installprefixexp'),
+ site => $c->get('siteprefixexp'),
+ vendor => $c->get('usevendorprefix') ? $c->get('vendorprefixexp') : '',
+ );
+
+ return \%ret;
+ }
+
+ sub _log_verbose {
+ my $self = shift;
+ print @_ if $self->verbose;
+ return;
+ }
+
+ # Given a file type, will return true if the file type would normally
+ # be installed when neither install-base nor prefix has been set.
+ # I.e. it will be true only if the path is set from Config.pm or
+ # set explicitly by the user via install-path.
+ sub is_default_installable {
+ my $self = shift;
+ my $type = shift;
+ my $installable = $self->install_destination($type) && ( $self->install_path($type) || $self->install_sets($self->installdirs, $type));
+ return $installable ? 1 : 0;
+ }
+
+ sub _prefixify_default {
+ my $self = shift;
+ my $type = shift;
+ my $rprefix = shift;
+
+ my $default = $self->prefix_relpaths($self->installdirs, $type);
+ if( !$default ) {
+ $self->_log_verbose(" no default install location for type '$type', using prefix '$rprefix'.\n");
+ return $rprefix;
+ } else {
+ return File::Spec->catdir(@{$default});
+ }
+ }
+
+ # Translated from ExtUtils::MM_Unix::prefixify()
+ sub _prefixify_novms {
+ my($self, $path, $sprefix, $type) = @_;
+
+ my $rprefix = $self->prefix;
+ $rprefix .= '/' if $sprefix =~ m{/$};
+
+ $self->_log_verbose(" prefixify $path from $sprefix to $rprefix\n") if defined $path && length $path;
+
+ if (not defined $path or length $path == 0 ) {
+ $self->_log_verbose(" no path to prefixify, falling back to default.\n");
+ return $self->_prefixify_default( $type, $rprefix );
+ } elsif( !File::Spec->file_name_is_absolute($path) ) {
+ $self->_log_verbose(" path is relative, not prefixifying.\n");
+ } elsif( $path !~ s{^\Q$sprefix\E\b}{}s ) {
+ $self->_log_verbose(" cannot prefixify, falling back to default.\n");
+ return $self->_prefixify_default( $type, $rprefix );
+ }
+
+ $self->_log_verbose(" now $path in $rprefix\n");
+
+ return $path;
+ }
+
+ sub _catprefix_vms {
+ my ($self, $rprefix, $default) = @_;
+
+ my ($rvol, $rdirs) = File::Spec->splitpath($rprefix);
+ if ($rvol) {
+ return File::Spec->catpath($rvol, File::Spec->catdir($rdirs, $default), '');
+ }
+ else {
+ return File::Spec->catdir($rdirs, $default);
+ }
+ }
+ sub _prefixify_vms {
+ my($self, $path, $sprefix, $type) = @_;
+ my $rprefix = $self->prefix;
+
+ return '' unless defined $path;
+
+ $self->_log_verbose(" prefixify $path from $sprefix to $rprefix\n");
+
+ require VMS::Filespec;
+ # Translate $(PERLPREFIX) to a real path.
+ $rprefix = VMS::Filespec::vmspath($rprefix) if $rprefix;
+ $sprefix = VMS::Filespec::vmspath($sprefix) if $sprefix;
+
+ $self->_log_verbose(" rprefix translated to $rprefix\n sprefix translated to $sprefix\n");
+
+ if (length($path) == 0 ) {
+ $self->_log_verbose(" no path to prefixify.\n")
+ }
+ elsif (!File::Spec->file_name_is_absolute($path)) {
+ $self->_log_verbose(" path is relative, not prefixifying.\n");
+ }
+ elsif ($sprefix eq $rprefix) {
+ $self->_log_verbose(" no new prefix.\n");
+ }
+ else {
+ my ($path_vol, $path_dirs) = File::Spec->splitpath( $path );
+ my $vms_prefix = $self->config->get('vms_prefix');
+ if ($path_vol eq $vms_prefix.':') {
+ $self->_log_verbose(" $vms_prefix: seen\n");
+
+ $path_dirs =~ s{^\[}{\[.} unless $path_dirs =~ m{^\[\.};
+ $path = $self->_catprefix_vms($rprefix, $path_dirs);
+ }
+ else {
+ $self->_log_verbose(" cannot prefixify.\n");
+ return File::Spec->catdir($self->prefix_relpaths($self->installdirs, $type));
+ }
+ }
+
+ $self->_log_verbose(" now $path\n");
+
+ return $path;
+ }
+
+ BEGIN { *_prefixify = $^O eq 'VMS' ? \&_prefixify_vms : \&_prefixify_novms }
+
+ # Translated from ExtUtils::MM_Any::init_INSTALL_from_PREFIX
+ sub prefix_relative {
+ my ($self, $installdirs, $type) = @_;
+
+ my $relpath = $self->install_sets($installdirs, $type);
+
+ return $self->_prefixify($relpath, $self->original_prefix($installdirs), $type);
+ }
+
+ sub install_destination {
+ my ($self, $type) = @_;
+
+ return $self->install_path($type) if $self->install_path($type);
+
+ if ( $self->install_base ) {
+ my $relpath = $self->install_base_relpaths($type);
+ return $relpath ? File::Spec->catdir($self->install_base, @{$relpath}) : undef;
+ }
+
+ if ( $self->prefix ) {
+ my $relpath = $self->prefix_relative($self->installdirs, $type);
+ return $relpath ? File::Spec->catdir($self->prefix, $relpath) : undef;
+ }
+ return $self->install_sets($self->installdirs, $type);
+ }
+
+ sub install_types {
+ my $self = shift;
+
+ my %types = ( %{ $self->{install_path} },
+ $self->install_base ? %{ $self->{install_base_relpaths} }
+ : $self->prefix ? %{ $self->{prefix_relpaths}{ $self->installdirs } }
+ : %{ $self->{install_sets}{ $self->installdirs } });
+
+ return sort keys %types;
+ }
+
+ sub install_map {
+ my ($self, $dirs) = @_;
+
+ my %localdir_for;
+ if ($dirs && %$dirs) {
+ %localdir_for = %$dirs;
+ }
+ else {
+ foreach my $type ($self->install_types) {
+ $localdir_for{$type} = File::Spec->catdir('blib', $type);
+ }
+ }
+
+ my (%map, @skipping);
+ foreach my $type (keys %localdir_for) {
+ next if not -e $localdir_for{$type};
+ if (my $dest = $self->install_destination($type)) {
+ $map{$localdir_for{$type}} = $dest;
+ } else {
+ push @skipping, $type;
+ }
+ }
+
+ warn "WARNING: Can't figure out install path for types: @skipping\nFiles will not be installed.\n" if @skipping;
+
+ # Write the packlist into the same place as ExtUtils::MakeMaker.
+ if ($self->create_packlist and my $module_name = $self->module_name) {
+ my $archdir = $self->install_destination('arch');
+ my @ext = split /::/, $module_name;
+ $map{write} = File::Spec->catfile($archdir, 'auto', @ext, '.packlist');
+ }
+
+ # Handle destdir
+ if (length(my $destdir = $self->destdir || '')) {
+ foreach (keys %map) {
+ # Need to remove volume from $map{$_} using splitpath, or else
+ # we'll create something crazy like C:\Foo\Bar\E:\Baz\Quux
+ # VMS will always have the file separate than the path.
+ my ($volume, $path, $file) = File::Spec->splitpath( $map{$_}, 0 );
+
+ # catdir needs a list of directories, or it will create something
+ # crazy like volume:[Foo.Bar.volume.Baz.Quux]
+ my @dirs = File::Spec->splitdir($path);
+
+ # First merge the directories
+ $path = File::Spec->catdir($destdir, @dirs);
+
+ # Then put the file back on if there is one.
+ if ($file ne '') {
+ $map{$_} = File::Spec->catfile($path, $file)
+ } else {
+ $map{$_} = $path;
+ }
+ }
+ }
+
+ $map{read} = ''; # To keep ExtUtils::Install quiet
+
+ return \%map;
+ }
+
+ 1;
+
+ # ABSTRACT: Build.PL install path logic made easy
+
+ __END__
+
+ =pod
+
+ =encoding UTF-8
+
+ =head1 NAME
+
+ ExtUtils::InstallPaths - Build.PL install path logic made easy
+
+ =head1 VERSION
+
+ version 0.012
+
+ =head1 SYNOPSIS
+
+ use ExtUtils::InstallPaths;
+ use ExtUtils::Install 'install';
+ GetOptions(\my %opt, 'install_base=s', 'install_path=s%', 'installdirs=s', 'destdir=s', 'prefix=s', 'uninst:1', 'verbose:1');
+ my $paths = ExtUtils::InstallPaths->new(%opt, dist_name => $dist_name);
+ install($paths->install_map, $opt{verbose}, 0, $opt{uninst});
+
+ =head1 DESCRIPTION
+
+ This module tries to make install path resolution as easy as possible.
+
+ When you want to install a module, it needs to figure out where to install things. The nutshell version of how this works is that default installation locations are determined from L<ExtUtils::Config>, and they may be individually overridden by using the C<install_path> attribute. An C<install_base> attribute lets you specify an alternative installation root like F</home/foo> and C<prefix> does something similar in a rather different (and more complicated) way. C<destdir> lets you specify a temporary installation directory like F</tmp/install> in case you want to create bundled-up installable packages.
+
+ The following types are supported by default.
+
+ =over 4
+
+ =item * lib
+
+ Usually pure-Perl module files ending in F<.pm> or F<.pod>.
+
+ =item * arch
+
+ "Architecture-dependent" module files, usually produced by compiling XS, L<Inline>, or similar code.
+
+ =item * script
+
+ Programs written in pure Perl. In order to improve reuse, you may want to make these as small as possible - put the code into modules whenever possible.
+
+ =item * bin
+
+ "Architecture-dependent" executable programs, i.e. compiled C code or something. Pretty rare to see this in a perl distribution, but it happens.
+
+ =item * bindoc
+
+ Documentation for the stuff in C<script> and C<bin>. Usually generated from the POD in those files. Under Unix, these are manual pages belonging to the 'man1' category. Unless explicitly set, this is only available on platforms supporting manpages.
+
+ =item * libdoc
+
+ Documentation for the stuff in C<lib> and C<arch>. This is usually generated from the POD in F<.pm> and F<.pod> files. Under Unix, these are manual pages belonging to the 'man3' category. Unless explicitly set, this is only available on platforms supporting manpages.
+
+ =item * binhtml
+
+ This is the same as C<bindoc> above, but applies to HTML documents. Unless explicitly set, this is only available when perl was configured to do so.
+
+ =item * libhtml
+
+ This is the same as C<libdoc> above, but applies to HTML documents. Unless explicitly set, this is only available when perl was configured to do so.
+
+ =back
+
+ =head1 ATTRIBUTES
+
+ =head2 installdirs
+
+ The default destinations for these installable things come from entries in your system's configuration. You can select from three different sets of default locations by setting the C<installdirs> parameter as follows:
+
+ 'installdirs' set to:
+ core site vendor
+
+ uses the following defaults from ExtUtils::Config:
+
+ lib => installprivlib installsitelib installvendorlib
+ arch => installarchlib installsitearch installvendorarch
+ script => installscript installsitescript installvendorscript
+ bin => installbin installsitebin installvendorbin
+ bindoc => installman1dir installsiteman1dir installvendorman1dir
+ libdoc => installman3dir installsiteman3dir installvendorman3dir
+ binhtml => installhtml1dir installsitehtml1dir installvendorhtml1dir [*]
+ libhtml => installhtml3dir installsitehtml3dir installvendorhtml3dir [*]
+
+ * Under some OS (eg. MSWin32) the destination for HTML documents is determined by the C<Config.pm> entry C<installhtmldir>.
+
+ The default value of C<installdirs> is "site".
+
+ =head2 install_base
+
+ You can also set the whole bunch of installation paths by supplying the C<install_base> parameter to point to a directory on your system. For instance, if you set C<install_base> to "/home/ken" on a Linux system, you'll install as follows:
+
+ lib => /home/ken/lib/perl5
+ arch => /home/ken/lib/perl5/i386-linux
+ script => /home/ken/bin
+ bin => /home/ken/bin
+ bindoc => /home/ken/man/man1
+ libdoc => /home/ken/man/man3
+ binhtml => /home/ken/html
+ libhtml => /home/ken/html
+
+ =head2 prefix
+
+ This sets a prefix, identical to ExtUtils::MakeMaker's PREFIX option. This does something similar to C<install_base> in a much more complicated way.
+
+ =head2 config()
+
+ The L<ExtUtils::Config|ExtUtils::Config> object used for this object.
+
+ =head2 verbose
+
+ The verbosity of ExtUtils::InstallPaths. It defaults to 0
+
+ =head2 create_packlist
+
+ Together with C<module_name> this controls whether a packlist will be added; it defaults to 1.
+
+ =head2 dist_name
+
+ The name of the current module.
+
+ =head2 module_name
+
+ The name of the main module of the package. This is required for packlist creation, but in the future it may be replaced by dist_name. It defaults to C<dist_name =~ s/-/::/gr> if dist_name is set.
+
+ =head2 destdir
+
+ If you want to install everything into a temporary directory first (for instance, if you want to create a directory tree that a package manager like C<rpm> or C<dpkg> could create a package from), you can use the C<destdir> parameter. E.g. Setting C<destdir> to C<"/tmp/foo"> will effectively install to "/tmp/foo/$sitelib", "/tmp/foo/$sitearch", and the like, except that it will use C<File::Spec> to make the pathnames work correctly on whatever platform you're installing on.
+
+ =head1 METHODS
+
+ =head2 new
+
+ Create a new ExtUtils::InstallPaths object. B<All attributes are valid arguments> to the constructor, as well as this:
+
+ =over 4
+
+ =item * install_path
+
+ This must be a hashref with the type as keys and the destination as values.
+
+ =item * install_base_relpaths
+
+ This must be a hashref with types as keys and a path relative to the install_base as value.
+
+ =item * prefix_relpaths
+
+ This must be a hashref any of these three keys: core, vendor, site. Each of the values mush be a hashref with types as keys and a path relative to the prefix as value. You probably want to make these three hashrefs identical.
+
+ =item * original_prefix
+
+ This must be a hashref with the legal installdirs values as keys and the prefix directories as values.
+
+ =item * install_sets
+
+ This mush be a hashref with the legal installdirs are keys, and the values being hashrefs with types as keys and locations as values.
+
+ =back
+
+ =head2 install_map()
+
+ Return a map suitable for use with L<ExtUtils::Install>. B<In most cases, this is the only method you'll need>.
+
+ =head2 install_destination($type)
+
+ Returns the destination of a certain type.
+
+ =head2 install_types()
+
+ Return a list of all supported install types in the current configuration.
+
+ =head2 is_default_installable($type)
+
+ Given a file type, will return true if the file type would normally be installed when neither install-base nor prefix has been set. I.e. it will be true only if the path is set from the configuration object or set explicitly by the user via install_path.
+
+ =head2 install_path($type)
+
+ Gets the install path for a certain type.
+
+ =head2 install_sets($installdirs, $type)
+
+ Get the path for a certain C<$type> with a certain C<$installdirs>.
+
+ =head2 install_base_relpaths($type, $relpath)
+
+ Get the relative paths for use with install_base for a certain type.
+
+ =head2 prefix_relative($installdirs, $type)
+
+ Gets the path of a certain C<$type> and C<$installdirs> relative to the prefix.
+
+ =head2 prefix_relpaths($install_dirs, $type)
+
+ Get the default relative path to use in case the config install paths cannot be prefixified. You do not want to use this to get any relative path, but may require it to set it for custom types.
+
+ =head2 original_prefix($installdirs)
+
+ Get the original prefix for a certain type of $installdirs.
+
+ =head1 SEE ALSO
+
+ =over 4
+
+ =item * L<Build.PL spec|http://github.com/dagolden/cpan-api-buildpl/blob/master/lib/CPAN/API/BuildPL.pm>
+
+ =back
+
+ =head1 AUTHORS
+
+ =over 4
+
+ =item *
+
+ Ken Williams <kwilliams@cpan.org>
+
+ =item *
+
+ Leon Timmermans <leont@cpan.org>
+
+ =back
+
+ =head1 COPYRIGHT AND LICENSE
+
+ This software is copyright (c) 2011 by Ken Williams, 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
+EXTUTILS_INSTALLPATHS
+
$fatpacked{"ExtUtils/Installed.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXTUTILS_INSTALLED';
package ExtUtils::Installed;
@@ -38960,8 +16968,8 @@ $fatpacked{"ExtUtils/Liblist.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
use strict;
- our $VERSION = '7.30';
- $VERSION = eval $VERSION;
+ our $VERSION = '7.36';
+ $VERSION =~ tr/_//d;
use File::Spec;
require ExtUtils::Liblist::Kid;
@@ -39259,8 +17267,8 @@ $fatpacked{"ExtUtils/Liblist/Kid.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\
use strict;
use warnings;
- our $VERSION = '7.30';
- $VERSION = eval $VERSION;
+ our $VERSION = '7.36';
+ $VERSION =~ tr/_//d;
use ExtUtils::MakeMaker::Config;
use Cwd 'cwd';
@@ -39297,15 +17305,23 @@ $fatpacked{"ExtUtils/Liblist/Kid.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\
# $potential_libs
# this is a rewrite of Andy Dougherty's extliblist in perl
+ require Text::ParseWords;
+
my ( @searchpath ); # from "-L/path" entries in $potential_libs
- my ( @libpath ) = split " ", $Config{'libpth'} || '';
+ my ( @libpath ) = Text::ParseWords::quotewords( '\s+', 0, $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 ) {
+ if ( $^O eq 'darwin' or $^O eq 'next' ) {
+ # 'escape' Mach-O ld -framework and -F flags, so they aren't dropped later on
+ $potential_libs =~ s/(^|\s)(-(?:weak_|reexport_|lazy_)?framework)\s+(\S+)/$1-Wl,$2 -Wl,$3/g;
+ $potential_libs =~ s/(^|\s)(-F)\s*(\S+)/$1-Wl,$2 -Wl,$3/g;
+ }
+
+ foreach my $thislib ( Text::ParseWords::quotewords( '\s+', 0, $potential_libs) ) {
my ( $custom_name ) = '';
# Handle possible linker path arguments.
@@ -39330,6 +17346,7 @@ $fatpacked{"ExtUtils/Liblist/Kid.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\
$thislib = $self->catdir( $pwd, $thislib );
}
push( @searchpath, $thislib );
+ $thislib = qq{"$thislib"} if $thislib =~ / /; # protect spaces if there
push( @extralibs, "$ptype$thislib" );
push( @ldloadlibs, "$rtype$thislib" );
next;
@@ -39899,8 +17916,8 @@ $fatpacked{"ExtUtils/MM.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXT
use strict;
use ExtUtils::MakeMaker::Config;
- our $VERSION = '7.30';
- $VERSION = eval $VERSION;
+ our $VERSION = '7.36';
+ $VERSION =~ tr/_//d;
require ExtUtils::Liblist;
require ExtUtils::MakeMaker;
@@ -39991,8 +18008,8 @@ $fatpacked{"ExtUtils/MM_AIX.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
package ExtUtils::MM_AIX;
use strict;
- our $VERSION = '7.30';
- $VERSION = eval $VERSION;
+ our $VERSION = '7.36';
+ $VERSION =~ tr/_//d;
use ExtUtils::MakeMaker::Config;
require ExtUtils::MM_Unix;
@@ -40040,7 +18057,9 @@ $fatpacked{"ExtUtils/MM_AIX.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
sub xs_dlsyms_arg {
my($self, $file) = @_;
- return qq{-bE:${file}};
+ my $arg = qq{-bE:${file}};
+ $arg = '-Wl,'.$arg if $Config{lddlflags} =~ /-Wl,-bE:/;
+ return $arg;
}
sub init_others {
@@ -40071,8 +18090,8 @@ $fatpacked{"ExtUtils/MM_Any.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
package ExtUtils::MM_Any;
use strict;
- our $VERSION = '7.30';
- $VERSION = eval $VERSION;
+ our $VERSION = '7.36';
+ $VERSION =~ tr/_//d;
use Carp;
use File::Spec;
@@ -40265,7 +18284,7 @@ $fatpacked{"ExtUtils/MM_Any.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
my $is_dmake = $self->is_make_type('dmake');
- Returns true if C<<$self->make>> is the given type; possibilities are:
+ Returns true if C<< $self->make >> is the given type; possibilities are:
gmake GNU make
dmake
@@ -41160,7 +19179,7 @@ $fatpacked{"ExtUtils/MM_Any.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
my @man_cmds;
foreach my $section (qw(1 3)) {
my $pods = $self->{"MAN${section}PODS"};
- my $p2m = sprintf <<'CMD', $section, $] > 5.008 ? " -u" : "";
+ 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);
@@ -42284,7 +20303,9 @@ $fatpacked{"ExtUtils/MM_Any.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
my $key = "INSTALL".$dir.$uc_thing;
$install{$key} ||=
- $self->catdir('$(INSTALL_BASE)', @{$map{$thing}});
+ ($thing =~ /^man.dir$/ and not $Config{lc $key})
+ ? 'none'
+ : $self->catdir('$(INSTALL_BASE)', @{$map{$thing}});
}
}
@@ -42969,13 +20990,20 @@ $fatpacked{"ExtUtils/MM_Any.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
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.
+ Mainly used to exclude version control administrative directories
+ and base-level F<README.pod> from installation.
=cut
sub libscan {
my($self,$path) = @_;
+
+ if ($path =~ m<^README\.pod$>i) {
+ warn "WARNING: Older versions of ExtUtils::MakeMaker may errantly install $path as part of this distribution. It is recommended to avoid using this path in CPAN modules.\n"
+ unless $ENV{PERL_CORE};
+ return '';
+ }
+
my($dirs,$file) = ($self->splitpath($path))[1,2];
return '' if grep /^(?:RCS|CVS|SCCS|\.svn|_darcs)$/,
$self->splitdir($dirs), $file;
@@ -43191,8 +21219,8 @@ $fatpacked{"ExtUtils/MM_BeOS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
require ExtUtils::MM_Unix;
our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix );
- our $VERSION = '7.30';
- $VERSION = eval $VERSION;
+ our $VERSION = '7.36';
+ $VERSION =~ tr/_//d;
=item os_flavor
@@ -43223,6 +21251,8 @@ $fatpacked{"ExtUtils/MM_BeOS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
=back
+ =cut
+
1;
__END__
@@ -43240,8 +21270,8 @@ $fatpacked{"ExtUtils/MM_Cygwin.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
require ExtUtils::MM_Win32;
our @ISA = qw( ExtUtils::MM_Unix );
- our $VERSION = '7.30';
- $VERSION = eval $VERSION;
+ our $VERSION = '7.36';
+ $VERSION =~ tr/_//d;
=head1 NAME
@@ -43317,7 +21347,7 @@ $fatpacked{"ExtUtils/MM_Cygwin.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
if ($Config{useshrplib} eq 'true') {
my $libperl = '$(PERL_INC)' .'/'. "$Config{libperl}";
- if( $] >= 5.006002 ) {
+ if( "$]" >= 5.006002 ) {
$libperl =~ s/(dll\.)?a$/dll.a/;
}
$self->{PERL_ARCHIVE} = $libperl;
@@ -43411,8 +21441,8 @@ $fatpacked{"ExtUtils/MM_DOS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
use strict;
- our $VERSION = '7.30';
- $VERSION = eval $VERSION;
+ our $VERSION = '7.36';
+ $VERSION =~ tr/_//d;
require ExtUtils::MM_Any;
require ExtUtils::MM_Unix;
@@ -43460,6 +21490,14 @@ $fatpacked{"ExtUtils/MM_DOS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
return $man;
}
+ =item xs_static_lib_is_xs
+
+ =cut
+
+ sub xs_static_lib_is_xs {
+ return 1;
+ }
+
=back
=head1 AUTHOR
@@ -43485,8 +21523,8 @@ $fatpacked{"ExtUtils/MM_Darwin.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
our @ISA = qw( ExtUtils::MM_Unix );
}
- our $VERSION = '7.30';
- $VERSION = eval $VERSION;
+ our $VERSION = '7.36';
+ $VERSION =~ tr/_//d;
=head1 NAME
@@ -43502,7 +21540,7 @@ $fatpacked{"ExtUtils/MM_Darwin.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
See L<ExtUtils::MM_Unix> for L<ExtUtils::MM_Any> for documentation on the
methods overridden here.
- =head2 Overriden Methods
+ =head2 Overridden Methods
=head3 init_dist
@@ -43531,8 +21569,8 @@ $fatpacked{"ExtUtils/MM_MacOS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".
use strict;
- our $VERSION = '7.30';
- $VERSION = eval $VERSION;
+ our $VERSION = '7.36';
+ $VERSION =~ tr/_//d;
sub new {
die 'MacOS Classic (MacPerl) is no longer supported by MakeMaker';
@@ -43588,8 +21626,8 @@ $fatpacked{"ExtUtils/MM_NW5.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
use ExtUtils::MakeMaker::Config;
use File::Basename;
- our $VERSION = '7.30';
- $VERSION = eval $VERSION;
+ our $VERSION = '7.36';
+ $VERSION =~ tr/_//d;
require ExtUtils::MM_Win32;
our @ISA = qw(ExtUtils::MM_Win32);
@@ -43703,6 +21741,14 @@ $fatpacked{"ExtUtils/MM_NW5.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
: '-type library -o $@ ' . $src));
}
+ =item xs_static_lib_is_xs
+
+ =cut
+
+ sub xs_static_lib_is_xs {
+ return 1;
+ }
+
=item dynamic_lib
Override of utility methods for OS-specific work.
@@ -43750,7 +21796,7 @@ $fatpacked{"ExtUtils/MM_NW5.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
}
# Reconstruct the X.Y.Z version.
my $version = join '.', map { sprintf "%d", $_ }
- $] =~ /(\d)\.(\d{3})(\d{2})/;
+ "$]" =~ /(\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 $@
@@ -43774,8 +21820,8 @@ $fatpacked{"ExtUtils/MM_OS2.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
use ExtUtils::MakeMaker qw(neatvalue);
use File::Spec;
- our $VERSION = '7.30';
- $VERSION = eval $VERSION;
+ our $VERSION = '7.36';
+ $VERSION =~ tr/_//d;
require ExtUtils::MM_Any;
require ExtUtils::MM_Unix;
@@ -43900,6 +21946,14 @@ $fatpacked{"ExtUtils/MM_OS2.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
return('OS/2');
}
+ =item xs_static_lib_is_xs
+
+ =cut
+
+ sub xs_static_lib_is_xs {
+ return 1;
+ }
+
=back
=cut
@@ -43911,8 +21965,8 @@ $fatpacked{"ExtUtils/MM_QNX.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
package ExtUtils::MM_QNX;
use strict;
- our $VERSION = '7.30';
- $VERSION = eval $VERSION;
+ our $VERSION = '7.36';
+ $VERSION =~ tr/_//d;
require ExtUtils::MM_Unix;
our @ISA = qw(ExtUtils::MM_Unix);
@@ -43972,8 +22026,8 @@ $fatpacked{"ExtUtils/MM_UWIN.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
package ExtUtils::MM_UWIN;
use strict;
- our $VERSION = '7.30';
- $VERSION = eval $VERSION;
+ our $VERSION = '7.36';
+ $VERSION =~ tr/_//d;
require ExtUtils::MM_Unix;
our @ISA = qw(ExtUtils::MM_Unix);
@@ -44053,8 +22107,8 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
# If we make $VERSION an our variable parse_version() breaks
use vars qw($VERSION);
- $VERSION = '7.30';
- $VERSION = eval $VERSION; ## no critic [BuiltinFunctions::ProhibitStringyEval]
+ $VERSION = '7.36';
+ $VERSION =~ tr/_//d;
require ExtUtils::MM_Any;
our @ISA = qw(ExtUtils::MM_Any);
@@ -44076,6 +22130,10 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
grep( $^O eq $_, qw(bsdos interix dragonfly) )
);
$Is{Android} = $^O =~ /android/;
+ if ( $^O eq 'darwin' && $^X eq '/usr/bin/perl' ) {
+ my @osvers = split /\./, $Config{osvers};
+ $Is{ApplCor} = ( $osvers[0] >= 18 );
+ }
}
BEGIN {
@@ -44093,7 +22151,7 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
=head1 SYNOPSIS
- C<require ExtUtils::MM_Unix;>
+ require ExtUtils::MM_Unix;
=head1 DESCRIPTION
@@ -44171,6 +22229,10 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
my $command = '$(CCCMD)';
my $flags = '$(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) $(DEFINE)';
+ if ( $Is{ApplCor} ) {
+ $flags =~ s/"-I(\$\(PERL_INC\))"/-iwithsysroot "$1"/;
+ }
+
if (my $cpp = $Config{cpprun}) {
my $cpp_cmd = $self->const_cccmd;
$cpp_cmd =~ s/^CCCMD\s*=\s*\$\(CC\)/$cpp/;
@@ -44190,8 +22252,11 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
my @exts = qw(c cpp cxx cc);
push @exts, 'C' if !$Is{OS2} and !$Is{Win32} and !$Is{Dos}; #Case-specific
$m_o = $self->{XSMULTI} ? $self->xs_obj_opt('$*$(OBJ_EXT)') : '';
+ my $dbgout = $self->dbgoutflag;
for my $ext (@exts) {
- push @m, "\n.$ext\$(OBJ_EXT) :\n\t$command $flags \$*.$ext" . ( $m_o ? " $m_o" : '' ) . "\n";
+ push @m, "\n.$ext\$(OBJ_EXT) :\n\t$command $flags "
+ .($dbgout?"$dbgout ":'')
+ ."\$*.$ext" . ( $m_o ? " $m_o" : '' ) . "\n";
}
return join "", @m;
}
@@ -44209,6 +22274,16 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
"-o $output_file";
}
+ =item dbgoutflag
+
+ Returns a CC flag that tells the CC to emit a separate debugging symbol file
+ when compiling an object file.
+
+ =cut
+
+ sub dbgoutflag {
+ '';
+ }
=item cflags (o)
@@ -44500,12 +22575,20 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
MAN3PODS = ".$self->wraplist(sort keys %{$self->{MAN3PODS}})."
";
+ push @m, q{
+ SDKROOT := $(shell xcrun --show-sdk-path)
+ PERL_SYSROOT = $(SDKROOT)
+ } if $Is{ApplCor} && $self->{'PERL_INC'} =~ m!^/System/Library/Perl/!;
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 $self->catfile( $self->{PERL_INC}, 'config.h' );
+ CONFIGDEP = $(PERL_ARCHLIBDEP)$(DFSEP)Config.pm $(PERL_SYSROOT)$(PERL_INCDEP)$(DFSEP)config.h
+ } if $Is{ApplCor};
+ 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 $self->catfile( $self->{PERL_INC}, 'config.h' ) && !$Is{ApplCor};
push @m, qq{
# Where to build things
@@ -45129,7 +23212,6 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
sub find_perl {
my($self, $ver, $names, $dirs, $trace) = @_;
-
if ($trace >= 2){
print "Looking for perl $ver by these names:
@$names
@@ -45282,12 +23364,15 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
my ( $self, $file, $line ) = @_;
# Now figure out the interpreter name.
- my ( $cmd, $arg ) = split ' ', $line, 2;
- $cmd =~ s!^.*/!!;
+ my ( $origcmd, $arg ) = split ' ', $line, 2;
+ (my $cmd = $origcmd) =~ s!^.*/!!;
# Now look (in reverse) for interpreter in absolute PATH (unless perl).
my $interpreter;
- if ( $cmd =~ m{^perl(?:\z|[^a-z])} ) {
+ if ( defined $ENV{PERL_MM_SHEBANG} && $ENV{PERL_MM_SHEBANG} eq "relocatable" ) {
+ $interpreter = "/usr/bin/env perl";
+ }
+ elsif ( $cmd =~ m{^perl(?:\z|[^a-z])} ) {
if ( $Config{startperl} =~ m,^\#!.*/perl, ) {
$interpreter = $Config{startperl};
$interpreter =~ s,^\#!,,;
@@ -45309,6 +23394,24 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
$interpreter = $maybefile;
}
}
+
+ # If the shebang is absolute and exists in PATH, but was not
+ # the first one found, leave it alone if it's actually the
+ # same file as first one. This avoids packages built on
+ # merged-/usr systems with /usr/bin before /bin in the path
+ # breaking when installed on systems without merged /usr
+ if ($origcmd ne $interpreter and $self->file_name_is_absolute($origcmd)) {
+ my $origdir = dirname($origcmd);
+ if ($self->maybe_command($origcmd) && grep { $_ eq $origdir } @absdirs) {
+ my ($odev, $oino) = stat $origcmd;
+ my ($idev, $iino) = stat $interpreter;
+ if ($odev == $idev && $oino == $iino) {
+ warn "$origcmd is the same as $interpreter, leaving alone"
+ if $Verbose;
+ $interpreter = $origcmd;
+ }
+ }
+ }
}
# Figure out how to invoke interpreter on this machine.
@@ -46082,6 +24185,11 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
# already escaped spaces.
$self->{FULLPERL} =~ tr/"//d if $Is{VMS};
+ # `dmake` can fail for image (aka, executable) names which start with double-quotes
+ # * push quote inward by at least one character (or the drive prefix, if present)
+ # * including any initial directory separator preserves the `file_name_is_absolute` property
+ $self->{FULLPERL} =~ s/^"(\S(:\\|:)?)/$1"/ if $self->is_make_type('dmake');
+
# Little hack to get around VMS's find_perl putting "MCR" in front
# sometimes.
$self->{ABSPERL} = $self->{PERL};
@@ -46104,6 +24212,11 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
# already escaped spaces.
$self->{PERL} =~ tr/"//d if $Is{VMS};
+ # `dmake` can fail for image (aka, executable) names which start with double-quotes
+ # * push quote inward by at least one character (or the drive prefix, if present)
+ # * including any initial directory separator preserves the `file_name_is_absolute` property
+ $self->{PERL} =~ s/^"(\S(:\\|:)?)/$1"/ if $self->is_make_type('dmake');
+
# 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};
@@ -46569,78 +24682,13 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
$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 {
- if ($File::Find::name =~ m{/auto/share\z}) {
- # in a subdir of auto/share, prune because e.g.
- # Alien::pkgconfig uses File::ShareDir to put .a files
- # there. do not want
- $File::Find::prune = 1;
- return;
- }
-
- return unless m/\Q$self->{LIB_EXT}\E$/;
-
- return unless -f 'extralibs.ld'; # this checks is a "proper" XS installation
-
- # 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 $_, map { $self->catdir($_, 'auto') } @{$searchdirs || []}) );
-
+ my $staticlib21 = $self->_find_static_libs($searchdirs);
# We trust that what has been handed in as argument, will be buildable
$static = [] unless $static;
- @static{@{$static}} = (1) x @{$static};
+ @$staticlib21{@{$static}} = (1) x @{$static};
$extra = [] unless $extra && ref $extra eq 'ARRAY';
- for (sort keys %static) {
+ for (sort keys %$staticlib21) {
next unless /\Q$self->{LIB_EXT}\E\z/;
$_ = dirname($_) . "/extralibs.ld";
push @$extra, $_;
@@ -46654,7 +24702,7 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
# 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;
+ my @map_static = reverse sort keys %$staticlib21;
push @m, "
MAP_LINKCMD = $linkcmd
MAP_STATIC = ", join(" \\\n\t", map { qq{"$_"} } @map_static), "
@@ -46766,6 +24814,92 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
join '', @m;
}
+ # utility method
+ sub _find_static_libs {
+ my ($self, $searchdirs) = @_;
+ # 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}"
+ );
+ my %staticlib21;
+ require File::Find;
+ File::Find::find(sub {
+ if ($File::Find::name =~ m{/auto/share\z}) {
+ # in a subdir of auto/share, prune because e.g.
+ # Alien::pkgconfig uses File::ShareDir to put .a files
+ # there. do not want
+ $File::Find::prune = 1;
+ return;
+ }
+
+ return unless m/\Q$self->{LIB_EXT}\E$/;
+
+ return unless -f 'extralibs.ld'; # this checks is a "proper" XS installation
+
+ # 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:;
+ return if !$self->xs_static_lib_is_xs($_);
+ use Cwd 'cwd';
+ $staticlib21{cwd() . "/" . $_}++;
+ }, grep( -d $_, map { $self->catdir($_, 'auto') } @{$searchdirs || []}) );
+ return \%staticlib21;
+ }
+
+ =item xs_static_lib_is_xs (o)
+
+ Called by a utility method of makeaperl. Checks whether a given file
+ is an XS library by seeing whether it defines any symbols starting
+ with C<boot_>.
+
+ =cut
+
+ sub xs_static_lib_is_xs {
+ my ($self, $libfile) = @_;
+ my $devnull = File::Spec->devnull;
+ return `nm $libfile 2>$devnull` =~ /\bboot_/;
+ }
+
=item makefile (o)
Defines how to rewrite the Makefile.
@@ -46890,7 +25024,7 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
}
close $fh;
- if ( $pod_encoding and !( $] < 5.008 or !$Config{useperlio} ) ) {
+ 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
@@ -46912,7 +25046,7 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
is. $VERSION should be for all to see, so C<our $VERSION> or plain $VERSION
are okay, but C<my $VERSION> is not.
- C<<package Foo VERSION>> is also checked for. The first version
+ C<package Foo VERSION> is also checked for. The first version
declaration found is used, but this may change as it differs from how
Perl does it.
@@ -47169,7 +25303,7 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
}
my $archname = $Config{archname};
- if ($] >= 5.008) {
+ 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
@@ -47286,9 +25420,11 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
my $m = '';
foreach my $plfile (sort keys %$pl_files) {
- my $list = ref($pl_files->{$plfile})
- ? $pl_files->{$plfile}
- : [$pl_files->{$plfile}];
+ my $targets = $pl_files->{$plfile};
+ my $list =
+ ref($targets) eq 'HASH' ? [ sort keys %$targets ] :
+ ref($targets) eq 'ARRAY' ? $pl_files->{$plfile} :
+ [$pl_files->{$plfile}];
foreach my $target (@$list) {
if( $Is{VMS} ) {
@@ -47312,13 +25448,27 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
$perlrun = 'PERLRUNINST';
}
+ my $extra_inputs = '';
+ if( ref($targets) eq 'HASH' ) {
+ my $inputs = ref($targets->{$target})
+ ? $targets->{$target}
+ : [$targets->{$target}];
+
+ for my $input (@$inputs) {
+ if( $Is{VMS} ) {
+ $input = vmsify($self->eliminate_macros($input));
+ }
+ $extra_inputs .= ' '.$input;
+ }
+ }
+
$m .= <<MAKE_FRAG;
pure_all :: $target
\$(NOECHO) \$(NOOP)
- $target :: $plfile $pm_dep
- \$($perlrun) $plfile $target
+ $target :: $plfile $pm_dep $extra_inputs
+ \$($perlrun) $plfile $target $extra_inputs
MAKE_FRAG
}
@@ -47975,13 +26125,15 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
my ($self) = @_;
return '' unless $self->needs_linking();
my $m_o = $self->{XSMULTI} ? $self->xs_obj_opt('$*$(OBJ_EXT)') : '';
+ my $dbgout = $self->dbgoutflag;
+ $dbgout = $dbgout ? "$dbgout " : '';
my $frag = '';
# dmake makes noise about ambiguous rule
- $frag .= sprintf <<'EOF', $m_o unless $self->is_make_type('dmake');
+ $frag .= sprintf <<'EOF', $dbgout, $m_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
+ $(CCCMD) $(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) $(DEFINE) %s$*.c %s
EOF
if ($self->{XSMULTI}) {
for my $ext ($self->_xs_list_basenames) {
@@ -47995,16 +26147,17 @@ $fatpacked{"ExtUtils/MM_Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
$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, $m_o, $define;
+ # 1 2 3 4 5
+ $frag .= _sprintf562 <<'EOF', $ext, $cccmd, $m_o, $define, $dbgout;
%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
+ %2$s $(CCCDLFLAGS) "-I$(PERL_INC)" $(PASTHRU_DEFINE) %4$s %5$s$*.c %3$s
EOF
}
}
+ $frag =~ s/"-I(\$\(PERL_INC\))"/-iwithsysroot "$1"/sg if $Is{ApplCor};
$frag;
}
@@ -48056,8 +26209,8 @@ $fatpacked{"ExtUtils/MM_VMS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
use File::Basename;
- our $VERSION = '7.30';
- $VERSION = eval $VERSION;
+ our $VERSION = '7.36';
+ $VERSION =~ tr/_//d;
require ExtUtils::MM_Any;
require ExtUtils::MM_Unix;
@@ -48628,9 +26781,10 @@ $fatpacked{"ExtUtils/MM_VMS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
# Cleanup paths for directories in MMS macros.
foreach my $macro ( qw [
INST_BIN INST_SCRIPT INST_LIB INST_ARCHLIB
- PERL_LIB PERL_ARCHLIB
+ PERL_LIB PERL_ARCHLIB PERL_ARCHLIBDEP
PERL_INC PERL_SRC ],
- (map { 'INSTALL'.$_ } $self->installvars)
+ (map { 'INSTALL'.$_ } $self->installvars),
+ (map { 'DESTINSTALL'.$_ } $self->installvars)
)
{
next unless defined $self->{$macro};
@@ -49283,6 +27437,29 @@ $fatpacked{"ExtUtils/MM_VMS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
}
+ =item static_lib_pure_cmd (override)
+
+ Use VMS commands to manipulate object library.
+
+ =cut
+
+ sub static_lib_pure_cmd {
+ my ($self, $from) = @_;
+
+ sprintf <<'MAKE_FRAG', $from;
+ If F$Search("$(MMS$TARGET)").eqs."" Then Library/Object/Create $(MMS$TARGET)
+ Library/Object/Replace $(MMS$TARGET) %s
+ MAKE_FRAG
+ }
+
+ =item xs_static_lib_is_xs
+
+ =cut
+
+ sub xs_static_lib_is_xs {
+ return 1;
+ }
+
=item extra_clean_files
Clean up some OS specific files. Plus the temp file used to shorten
@@ -49327,7 +27504,7 @@ $fatpacked{"ExtUtils/MM_VMS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
$(DISTVNAME).tar$(SUFFIX) : distdir
$(PREOP)
$(TO_UNIX)
- $(TAR) "$(TARFLAGS)" $(DISTVNAME).tar [.$(DISTVNAME)...]
+ $(TAR) "$(TARFLAGS)" $(DISTVNAME).tar [.$(DISTVNAME)...]
$(RM_RF) $(DISTVNAME)
$(COMPRESS) $(DISTVNAME).tar
$(POSTOP)
@@ -49377,7 +27554,7 @@ $fatpacked{"ExtUtils/MM_VMS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
$(NOECHO) $(NOOP)
doc_install :: doc_$(INSTALLDIRS)_install
- $(NOECHO) $(NOOP)
+ $(NOECHO) $(NOOP)
pure__install : pure_site_install
$(NOECHO) $(ECHO) "INSTALLDIRS not defined, defaulting to INSTALLDIRS=site"
@@ -50302,8 +28479,8 @@ $fatpacked{"ExtUtils/MM_VOS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
package ExtUtils::MM_VOS;
use strict;
- our $VERSION = '7.30';
- $VERSION = eval $VERSION;
+ our $VERSION = '7.36';
+ $VERSION =~ tr/_//d;
require ExtUtils::MM_Unix;
our @ISA = qw(ExtUtils::MM_Unix);
@@ -50382,8 +28559,8 @@ $fatpacked{"ExtUtils/MM_Win32.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".
require ExtUtils::MM_Any;
require ExtUtils::MM_Unix;
our @ISA = qw( ExtUtils::MM_Any ExtUtils::MM_Unix );
- our $VERSION = '7.30';
- $VERSION = eval $VERSION;
+ our $VERSION = '7.36';
+ $VERSION =~ tr/_//d;
$ENV{EMXSHELL} = 'sh'; # to run `commands`
@@ -50432,7 +28609,7 @@ $fatpacked{"ExtUtils/MM_Win32.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".
sub replace_manpage_separator {
my($self,$man) = @_;
- $man =~ s,/+,.,g;
+ $man =~ s,[/\\]+,.,g;
$man;
}
@@ -50498,7 +28675,7 @@ $fatpacked{"ExtUtils/MM_Win32.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".
$self->{DEV_NULL} ||= '> NUL';
$self->{FIXIN} ||= $self->{PERL_CORE} ?
- "\$(PERLRUN) $self->{PERL_SRC}\\win32\\bin\\pl2bat.pl" :
+ "\$(PERLRUN) -I$self->{PERL_SRC}\\cpan\\ExtUtils-PL2Bat\\lib $self->{PERL_SRC}\\win32\\bin\\pl2bat.pl" :
'pl2bat.bat';
$self->SUPER::init_tools;
@@ -50861,7 +29038,7 @@ $fatpacked{"ExtUtils/MM_Win32.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".
$text =~ s{\\\\"}{\\\\\\\\\\"}g; # \\" -> \\\\\"
$text =~ s{(?<!\\)\\"}{\\\\\\"}g; # \" -> \\\"
$text =~ s{(?<!\\)"}{\\"}g; # " -> \"
- $text = qq{"$text"} if $text =~ /[ \t]/;
+ $text = qq{"$text"} if $text =~ /[ \t#]/; # hash because gmake 4.2.1
# Apply the Command Prompt parsing rules (cmd.exe)
my @text = split /("[^"]*")/, $text;
@@ -50950,6 +29127,16 @@ $fatpacked{"ExtUtils/MM_Win32.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".
return('Win32');
}
+ =item dbgoutflag
+
+ Returns a CC flag that tells the CC to emit a separate debugging symbol file
+ when compiling an object file.
+
+ =cut
+
+ sub dbgoutflag {
+ $MSVC ? '-Fd$(*).pdb' : '';
+ }
=item cflags
@@ -51006,8 +29193,8 @@ $fatpacked{"ExtUtils/MM_Win95.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".
use strict;
- our $VERSION = '7.30';
- $VERSION = eval $VERSION;
+ our $VERSION = '7.36';
+ $VERSION =~ tr/_//d;
require ExtUtils::MM_Win32;
our @ISA = qw(ExtUtils::MM_Win32);
@@ -51086,8 +29273,8 @@ $fatpacked{"ExtUtils/MY.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXT
use strict;
require ExtUtils::MM;
- our $VERSION = '7.30';
- $VERSION = eval $VERSION;
+ our $VERSION = '7.36';
+ $VERSION =~ tr/_//d;
our @ISA = qw(ExtUtils::MM);
{
@@ -51151,8 +29338,8 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
our %macro_fsentity; # whether a macro is a filesystem name
our %macro_dep; # whether a macro is a dependency
- our $VERSION = '7.30';
- $VERSION = eval $VERSION; ## no critic [BuiltinFunctions::ProhibitStringyEval]
+ our $VERSION = '7.36';
+ $VERSION =~ tr/_//d;
# Emulate something resembling CVS $Revision$
(our $Revision = $VERSION) =~ s{_}{};
@@ -51443,7 +29630,7 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
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
+ PREREQ_FATAL PREREQ_PM PREREQ_PRINT PRINT_PREREQ PUREPERL_ONLY
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
@@ -51525,7 +29712,7 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
);
# 5.5.3 doesn't have any concept of vendor libs
- push @Get_from_Config, qw( vendorarchexp vendorlibexp ) if $] >= 5.006;
+ push @Get_from_Config, qw( vendorarchexp vendorlibexp ) if "$]" >= 5.006;
foreach my $item (@attrib_help){
$Recognized_Att_Keys{$item} = 1;
@@ -51661,7 +29848,7 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
# simulate "use warnings FATAL => 'all'" for vintage perls
die @_;
};
- !$self->{MIN_PERL_VERSION} or $self->{MIN_PERL_VERSION} <= $]
+ !$self->{MIN_PERL_VERSION} or $self->{MIN_PERL_VERSION} <= "$]"
};
if (!$perl_version_ok) {
if (!defined $perl_version_ok) {
@@ -51820,6 +30007,7 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
} else {
my $value = $self->{$key};
# not going to test in FS so only stripping start
+ $value =~ s/"// if $key =~ /PERL$/ and $self->is_make_type('dmake');
$value =~ s/^"// if $key =~ /PERL$/;
$value = $self->catdir("..", $value)
unless $self->file_name_is_absolute($value);
@@ -51829,7 +30017,8 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
}
if ($self->{PARENT}) {
$self->{PARENT}->{CHILDREN}->{$newclass} = $self;
- foreach my $opt (qw(POLLUTE PERL_CORE LINKTYPE LD OPTIMIZE)) {
+ foreach my $opt (qw(POLLUTE PERL_CORE LINKTYPE AR FULL_AR CC CCFLAGS
+ OPTIMIZE LD LDDLFLAGS LDFLAGS PERL_ARCHLIB DESTDIR)) {
if (exists $self->{PARENT}->{$opt}
and not exists $self->{$opt})
{
@@ -52391,7 +30580,7 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
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;
+ 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: $!";
@@ -52944,7 +31133,7 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
=item BUILD_REQUIRES
- Available in version 6.5503 and above.
+ Available in version 6.55_03 and above.
A hash of modules that are needed to build your module but not run it.
@@ -53196,6 +31385,8 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
=item INSTALLSCRIPT
+ Available in version 6.30_02 and above.
+
Used by 'make install' which copies files from INST_SCRIPT to this
directory if INSTALLDIRS=perl.
@@ -53232,7 +31423,9 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
=item INSTALLVENDORARCH
Used by 'make install', which copies files from INST_ARCHLIB to this
- directory if INSTALLDIRS is set to vendor.
+ directory if INSTALLDIRS is set to vendor. Note that if you do not set
+ this, the value of INSTALLVENDORLIB will be used, which is probably not
+ what you want.
=item INSTALLVENDORBIN
@@ -53255,6 +31448,8 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
=item INSTALLVENDORSCRIPT
+ Available in version 6.30_02 and above.
+
Used by 'make install' which copies files from INST_SCRIPT to this
directory if INSTALLDIRS is set to vendor.
@@ -53360,11 +31555,15 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
=item MAGICXS
+ Available in version 6.8305 and above.
+
When this is set to C<1>, C<OBJECT> will be automagically derived from
C<O_FILES>.
=item MAKE
+ Available in version 6.30_01 and above.
+
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.
@@ -53536,6 +31735,8 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
=item NO_MYMETA
+ Available in version 6.57_02 and above.
+
When true, suppresses the generation of MYMETA.yml and MYMETA.json module
meta-data files during 'perl Makefile.PL'.
@@ -53543,12 +31744,16 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
=item NO_PACKLIST
+ Available in version 6.7501 and above.
+
When true, suppresses the writing of C<packlist> files for installs.
Defaults to false.
=item NO_PERLLOCAL
+ Available in version 6.7501 and above.
+
When true, suppresses the appending of installations to C<perllocal>.
Defaults to false.
@@ -53666,6 +31871,8 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
=item PERM_DIR
+ Available in version 6.51_01 and above.
+
Desired permission for directories. Defaults to C<755>.
=item PERM_RW
@@ -53708,6 +31915,20 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
perl bin/foobar.PL bin/foobar1
perl bin/foobar.PL bin/foobar2
+ If an output file depends on extra input files beside the script itself,
+ a hash ref can be used in version 7.36 and above:
+
+ PL_FILES => { 'foo.PL' => {
+ 'foo.out' => 'foo.in',
+ 'bar.out' => [qw(bar1.in bar2.in)],
+ }
+
+ In this case the extra input files will be passed to the program after
+ the target file:
+
+ perl foo.PL foo.out foo.in
+ perl foo.PL bar.out bar1.in bar2.in
+
PL files are normally run B<after> 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
@@ -53787,10 +32008,14 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
=item PPM_UNINSTALL_EXEC
+ Available in version 6.8502 and above.
+
Name of the executable used to run C<PPM_UNINSTALL_SCRIPT> below. (e.g. perl)
=item PPM_UNINSTALL_SCRIPT
+ Available in version 6.8502 and above.
+
Name of the script that gets executed by the Perl Package Manager before
the removal of a package.
@@ -53888,6 +32113,8 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
=item SIGN
+ Available in version 6.18 and above.
+
When true, perform the generation and addition to the MANIFEST of the
SIGNATURE file in the distdir during 'make distdir', via 'cpansign
-s'.
@@ -54008,6 +32235,8 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
=item XSBUILD
+ Available in version 7.12 and above.
+
Hashref with options controlling the operation of C<XSMULTI>:
{
@@ -54040,6 +32269,8 @@ $fatpacked{"ExtUtils/MakeMaker.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n"
=item XSMULTI
+ Available in version 7.12 and above.
+
When this is set to C<1>, multiple XS files may be placed under F<lib/>
next to their corresponding C<*.pm> files (this is essential for compiling
with the correct C<VERSION> values). This feature should be considered
@@ -54516,8 +32747,8 @@ $fatpacked{"ExtUtils/MakeMaker/Config.pm"} = '#line '.(1+__LINE__).' "'.__FILE__
use strict;
- our $VERSION = '7.30';
- $VERSION = eval $VERSION;
+ our $VERSION = '7.36';
+ $VERSION =~ tr/_//d;
use Config ();
@@ -54558,8 +32789,8 @@ $fatpacked{"ExtUtils/MakeMaker/Locale.pm"} = '#line '.(1+__LINE__).' "'.__FILE__
package ExtUtils::MakeMaker::Locale;
use strict;
- our $VERSION = "7.30";
- $VERSION = eval $VERSION;
+ our $VERSION = "7.36";
+ $VERSION =~ tr/_//d;
use base 'Exporter';
our @EXPORT_OK = qw(
@@ -54604,7 +32835,10 @@ $fatpacked{"ExtUtils/MakeMaker/Locale.pm"} = '#line '.(1+__LINE__).' "'.__FILE__
unless (defined &GetInputCP) {
eval {
require Win32;
- eval { Win32::GetConsoleCP() };
+ eval {
+ local $SIG{__WARN__} = sub {} if ( "$]" < 5.014 ); # suppress deprecation warning for inherited AUTOLOAD of Win32::GetConsoleCP()
+ Win32::GetConsoleCP();
+ };
# manually "import" it since Win32->import refuses
*GetInputCP = sub { &Win32::GetConsoleCP } if defined &Win32::GetConsoleCP;
*GetOutputCP = sub { &Win32::GetConsoleOutputCP } if defined &Win32::GetConsoleOutputCP;
@@ -54653,6 +32887,13 @@ $fatpacked{"ExtUtils/MakeMaker/Locale.pm"} = '#line '.(1+__LINE__).' "'.__FILE__
$ENCODING_LOCALE ||= $ENCODING_CONSOLE_IN;
}
+ # Workaround of Encode < v2.71 for "cp65000" and "cp65001"
+ # The "cp65000" and "cp65001" aliases were added in [Encode v2.71](https://github.com/dankogai/p5-encode/commit/7874bd95aa10967a3b5dbae333d16bcd703ac6c6)
+ # via commit <https://github.com/dankogai/p5-encode/commit/84b9c1101d5251d37e226f80d1c6781718779047>.
+ # This will avoid test failures for Win32 machines using the UTF-7 or UTF-8 code pages.
+ $ENCODING_LOCALE = 'UTF-7' if $ENCODING_LOCALE && lc($ENCODING_LOCALE) eq "cp65000";
+ $ENCODING_LOCALE = 'utf-8-strict' if $ENCODING_LOCALE && lc($ENCODING_LOCALE) eq "cp65001";
+
if ($^O eq "darwin") {
$ENCODING_LOCALE_FS ||= "UTF-8";
}
@@ -54948,8 +33189,8 @@ $fatpacked{"ExtUtils/MakeMaker/version.pm"} = '#line '.(1+__LINE__).' "'.__FILE_
use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv);
- $VERSION = '7.30';
- $VERSION = eval $VERSION;
+ $VERSION = '7.36';
+ $VERSION =~ tr/_//d;
$CLASS = 'version';
{
@@ -54968,7 +33209,7 @@ $fatpacked{"ExtUtils/MakeMaker/version.pm"} = '#line '.(1+__LINE__).' "'.__FILE_
*version::_VERSION = \&ExtUtils::MakeMaker::version::vpp::_VERSION;
*version::vcmp = \&ExtUtils::MakeMaker::version::vpp::vcmp;
*version::new = \&ExtUtils::MakeMaker::version::vpp::new;
- if ($] >= 5.009000) {
+ if ("$]" >= 5.009000) {
no strict 'refs';
*version::stringify = \&ExtUtils::MakeMaker::version::vpp::stringify;
*{'version::(""'} = \&ExtUtils::MakeMaker::version::vpp::stringify;
@@ -55002,8 +33243,8 @@ $fatpacked{"ExtUtils/MakeMaker/version/regex.pm"} = '#line '.(1+__LINE__).' "'._
use vars qw($VERSION $CLASS $STRICT $LAX);
- $VERSION = '7.30';
- $VERSION = eval $VERSION;
+ $VERSION = '7.36';
+ $VERSION =~ tr/_//d;
#--------------------------------------------------------------------------#
# Version regexp components
@@ -55247,8 +33488,8 @@ $fatpacked{"ExtUtils/MakeMaker/version/vpp.pm"} = '#line '.(1+__LINE__).' "'.__F
use Config;
use vars qw($VERSION $CLASS @ISA $LAX $STRICT);
- $VERSION = '7.30';
- $VERSION = eval $VERSION;
+ $VERSION = '7.36';
+ $VERSION =~ tr/_//d;
$CLASS = 'ExtUtils::MakeMaker::version::vpp';
require ExtUtils::MakeMaker::version::regex;
@@ -56053,11 +34294,11 @@ $fatpacked{"ExtUtils/MakeMaker/version/vpp.pm"} = '#line '.(1+__LINE__).' "'.__F
if ( length($value) >= 3 && $value !~ /[._]/
&& _is_non_alphanumeric($value)) {
my $tvalue;
- if ( $] ge 5.008_001 ) {
+ if ( "$]" >= 5.008_001 ) {
$tvalue = _find_magic_vstring($value);
$value = $tvalue if length $tvalue;
}
- elsif ( $] ge 5.006_000 ) {
+ elsif ( "$]" >= 5.006_000 ) {
$tvalue = sprintf("v%vd",$value);
if ( $tvalue =~ /^v\d+(\.\d+){2,}$/ ) {
# must be a v-string
@@ -56092,7 +34333,7 @@ $fatpacked{"ExtUtils/MakeMaker/version/vpp.pm"} = '#line '.(1+__LINE__).' "'.__F
my $class = ref($obj) || $obj;
no strict 'refs';
- if ( exists $INC{"$class.pm"} and not %{"$class\::"} and $] >= 5.008) {
+ 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"
@@ -56101,14 +34342,14 @@ $fatpacked{"ExtUtils/MakeMaker/version/vpp.pm"} = '#line '.(1+__LINE__).' "'.__F
my $version = eval "\$$class\::VERSION";
if ( defined $version ) {
- local $^W if $] <= 5.008;
+ local $^W if "$]" <= 5.008;
$version = ExtUtils::MakeMaker::version::vpp->new($version);
}
if ( defined $req ) {
unless ( defined $version ) {
require Carp;
- my $msg = $] < 5.006
+ my $msg = "$]" < 5.006
? "$class version $req required--this is only version "
: "$class does not define \$$class\::VERSION"
."--version check failed";
@@ -57068,8 +35309,8 @@ $fatpacked{"ExtUtils/Mkbootstrap.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\
# There's just too much Dynaloader incest here to turn on strict vars.
use strict 'refs';
- our $VERSION = '7.30';
- $VERSION = eval $VERSION;
+ our $VERSION = '7.36';
+ $VERSION =~ tr/_//d;
require Exporter;
our @ISA = ('Exporter');
@@ -57149,7 +35390,7 @@ $fatpacked{"ExtUtils/Mkbootstrap.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\
=head1 SYNOPSIS
- C<Mkbootstrap>
+ Mkbootstrap
=head1 DESCRIPTION
@@ -57190,8 +35431,8 @@ $fatpacked{"ExtUtils/Mksymlists.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
our @ISA = qw(Exporter);
our @EXPORT = qw(&Mksymlists);
- our $VERSION = '7.30';
- $VERSION = eval $VERSION;
+ our $VERSION = '7.36';
+ $VERSION =~ tr/_//d;
sub Mksymlists {
my(%spec) = @_;
@@ -57328,7 +35569,7 @@ $fatpacked{"ExtUtils/Mksymlists.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n
# 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) {
+ unless("$]" >= 5.016) {
if ($Config::Config{'cc'} =~ /^bcc/i) {
push @syms, "_$_", "$_ = _$_"
for (@{$data->{DL_VARS}}, @{$data->{FUNCLIST}});
@@ -57860,8 +36101,8 @@ $fatpacked{"ExtUtils/testlib.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
use strict;
use warnings;
- our $VERSION = '7.30';
- $VERSION = eval $VERSION;
+ our $VERSION = '7.36';
+ $VERSION =~ tr/_//d;
use Cwd;
use File::Spec;
@@ -57899,6 +36140,742 @@ $fatpacked{"ExtUtils/testlib.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<
EXTUTILS_TESTLIB
+$fatpacked{"File/Which.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'FILE_WHICH';
+ package File::Which;
+
+ use strict;
+ use warnings;
+ use Exporter ();
+ use File::Spec ();
+
+ # ABSTRACT: Perl implementation of the which utility as an API
+ our $VERSION = '1.23'; # VERSION
+
+
+ our @ISA = 'Exporter';
+ our @EXPORT = 'which';
+ our @EXPORT_OK = 'where';
+
+ use constant IS_VMS => ($^O eq 'VMS');
+ use constant IS_MAC => ($^O eq 'MacOS');
+ use constant IS_WIN => ($^O eq 'MSWin32' or $^O eq 'dos' or $^O eq 'os2');
+ use constant IS_DOS => IS_WIN();
+ use constant IS_CYG => ($^O eq 'cygwin' || $^O eq 'msys');
+
+ our $IMPLICIT_CURRENT_DIR = IS_WIN || IS_VMS || IS_MAC;
+
+ # For Win32 systems, stores the extensions used for
+ # executable files
+ # For others, the empty string is used
+ # because 'perl' . '' eq 'perl' => easier
+ my @PATHEXT = ('');
+ if ( IS_WIN ) {
+ # WinNT. PATHEXT might be set on Cygwin, but not used.
+ if ( $ENV{PATHEXT} ) {
+ push @PATHEXT, split ';', $ENV{PATHEXT};
+ } else {
+ # Win9X or other: doesn't have PATHEXT, so needs hardcoded.
+ push @PATHEXT, qw{.com .exe .bat};
+ }
+ } elsif ( IS_VMS ) {
+ push @PATHEXT, qw{.exe .com};
+ } elsif ( IS_CYG ) {
+ # See this for more info
+ # http://cygwin.com/cygwin-ug-net/using-specialnames.html#pathnames-exe
+ push @PATHEXT, qw{.exe .com};
+ }
+
+
+ sub which {
+ my ($exec) = @_;
+
+ return undef unless defined $exec;
+ return undef if $exec eq '';
+
+ my $all = wantarray;
+ my @results = ();
+
+ # check for aliases first
+ if ( IS_VMS ) {
+ my $symbol = `SHOW SYMBOL $exec`;
+ chomp($symbol);
+ unless ( $? ) {
+ return $symbol unless $all;
+ push @results, $symbol;
+ }
+ }
+ if ( IS_MAC ) {
+ my @aliases = split /\,/, $ENV{Aliases};
+ foreach my $alias ( @aliases ) {
+ # This has not been tested!!
+ # PPT which says MPW-Perl cannot resolve `Alias $alias`,
+ # let's just hope it's fixed
+ if ( lc($alias) eq lc($exec) ) {
+ chomp(my $file = `Alias $alias`);
+ last unless $file; # if it failed, just go on the normal way
+ return $file unless $all;
+ push @results, $file;
+ # we can stop this loop as if it finds more aliases matching,
+ # it'll just be the same result anyway
+ last;
+ }
+ }
+ }
+
+ return $exec
+ if !IS_VMS and !IS_MAC and !IS_WIN and $exec =~ /\// and -f $exec and -x $exec;
+
+ my @path;
+ if($^O eq 'MSWin32') {
+ # File::Spec (at least recent versions)
+ # add the implicit . for you on MSWin32,
+ # but we may or may not want to include
+ # that.
+ @path = split(';', $ENV{PATH});
+ s/"//g for @path;
+ @path = grep length, @path;
+ } else {
+ @path = File::Spec->path;
+ }
+ if ( $IMPLICIT_CURRENT_DIR ) {
+ unshift @path, File::Spec->curdir;
+ }
+
+ foreach my $base ( map { File::Spec->catfile($_, $exec) } @path ) {
+ for my $ext ( @PATHEXT ) {
+ my $file = $base.$ext;
+
+ # We don't want dirs (as they are -x)
+ next if -d $file;
+
+ if (
+ # Executable, normal case
+ -x _
+ or (
+ # MacOS doesn't mark as executable so we check -e
+ IS_MAC
+ ||
+ (
+ ( IS_WIN or IS_CYG )
+ and
+ grep {
+ $file =~ /$_\z/i
+ } @PATHEXT[1..$#PATHEXT]
+ )
+ # DOSish systems don't pass -x on
+ # non-exe/bat/com files. so we check -e.
+ # However, we don't want to pass -e on files
+ # that aren't in PATHEXT, like README.
+ and -e _
+ )
+ ) {
+ return $file unless $all;
+ push @results, $file;
+ }
+ }
+ }
+
+ if ( $all ) {
+ return @results;
+ } else {
+ return undef;
+ }
+ }
+
+
+ sub where {
+ # force wantarray
+ my @res = which($_[0]);
+ return @res;
+ }
+
+ 1;
+
+ __END__
+
+ =pod
+
+ =encoding UTF-8
+
+ =head1 NAME
+
+ File::Which - Perl implementation of the which utility as an API
+
+ =head1 VERSION
+
+ version 1.23
+
+ =head1 SYNOPSIS
+
+ use File::Which; # exports which()
+ use File::Which qw(which where); # exports which() and where()
+
+ my $exe_path = which 'perldoc';
+
+ my @paths = where 'perl';
+ # Or
+ my @paths = which 'perl'; # an array forces search for all of them
+
+ =head1 DESCRIPTION
+
+ L<File::Which> finds the full or relative paths to executable programs on
+ the system. This is normally the function of C<which> utility. C<which> is
+ typically implemented as either a program or a built in shell command. On
+ some platforms, such as Microsoft Windows it is not provided as part of the
+ core operating system. This module provides a consistent API to this
+ functionality regardless of the underlying platform.
+
+ The focus of this module is correctness and portability. As a consequence
+ platforms where the current directory is implicitly part of the search path
+ such as Microsoft Windows will find executables in the current directory,
+ whereas on platforms such as UNIX where this is not the case executables
+ in the current directory will only be found if the current directory is
+ explicitly added to the path.
+
+ If you need a portable C<which> on the command line in an environment that
+ does not provide it, install L<App::pwhich> which provides a command line
+ interface to this API.
+
+ =head2 Implementations
+
+ L<File::Which> searches the directories of the user's C<PATH> (the current
+ implementation uses L<File::Spec#path> to determine the correct C<PATH>),
+ looking for executable files having the name specified as a parameter to
+ L</which>. Under Win32 systems, which do not have a notion of directly
+ executable files, but uses special extensions such as C<.exe> and C<.bat>
+ to identify them, C<File::Which> takes extra steps to assure that
+ you will find the correct file (so for example, you might be searching for
+ C<perl>, it'll try F<perl.exe>, F<perl.bat>, etc.)
+
+ =head3 Linux, *BSD and other UNIXes
+
+ There should not be any surprises here. The current directory will not be
+ searched unless it is explicitly added to the path.
+
+ =head3 Modern Windows (including NT, XP, Vista, 7, 8, 10 etc)
+
+ Windows NT has a special environment variable called C<PATHEXT>, which is used
+ by the shell to look for executable files. Usually, it will contain a list in
+ the form C<.EXE;.BAT;.COM;.JS;.VBS> etc. If C<File::Which> finds such an
+ environment variable, it parses the list and uses it as the different
+ extensions.
+
+ =head3 Cygwin
+
+ Cygwin provides a Unix-like environment for Microsoft Windows users. In most
+ ways it works like other Unix and Unix-like environments, but in a few key
+ aspects it works like Windows. As with other Unix environments, the current
+ directory is not included in the search unless it is explicitly included in
+ the search path. Like on Windows, files with C<.EXE> or <.BAT> extensions will
+ be discovered even if they are not part of the query. C<.COM> or extensions
+ specified using the C<PATHEXT> environment variable will NOT be discovered
+ without the fully qualified name, however.
+
+ =head3 Windows ME, 98, 95, MS-DOS, OS/2
+
+ This set of operating systems don't have the C<PATHEXT> variable, and usually
+ you will find executable files there with the extensions C<.exe>, C<.bat> and
+ (less likely) C<.com>. C<File::Which> uses this hardcoded list if it's running
+ under Win32 but does not find a C<PATHEXT> variable.
+
+ As of 2015 none of these platforms are tested frequently (or perhaps ever),
+ but the current maintainer is determined not to intentionally remove support
+ for older operating systems.
+
+ =head3 VMS
+
+ Same case as Windows 9x: uses C<.exe> and C<.com> (in that order).
+
+ As of 2015 the current maintainer does not test on VMS, and is in fact not
+ certain it has ever been tested on VMS. If this platform is important to you
+ and you can help me verify and or support it on that platform please contact
+ me.
+
+ =head1 FUNCTIONS
+
+ =head2 which
+
+ my $path = which $short_exe_name;
+ my @paths = which $short_exe_name;
+
+ Exported by default.
+
+ C<$short_exe_name> is the name used in the shell to call the program (for
+ example, C<perl>).
+
+ If it finds an executable with the name you specified, C<which()> will return
+ the absolute path leading to this executable (for example, F</usr/bin/perl> or
+ F<C:\Perl\Bin\perl.exe>).
+
+ If it does I<not> find the executable, it returns C<undef>.
+
+ If C<which()> is called in list context, it will return I<all> the
+ matches.
+
+ =head2 where
+
+ my @paths = where $short_exe_name;
+
+ Not exported by default.
+
+ Same as L</which> in array context. Similar to the C<where> csh
+ built-in command or C<which -a> command for platforms that support the
+ C<-a> option. Will return an array containing all the path names
+ matching C<$short_exe_name>.
+
+ =head1 GLOBALS
+
+ =head2 $IMPLICIT_CURRENT_DIR
+
+ True if the current directory is included in the search implicitly on
+ whatever platform you are using. Normally the default is reasonable,
+ but on Windows the current directory is included implicitly for older
+ shells like C<cmd.exe> and C<command.com>, but not for newer shells
+ like PowerShell. If you overrule this default, you should ALWAYS
+ localize the variable to the tightest scope possible, since setting
+ this variable from a module can affect other modules. Thus on Windows
+ you can get the correct result if the user is running either C<cmd.exe>
+ or PowerShell on Windows you can do this:
+
+ use File::Which qw( which );
+ use Shell::Guess;
+
+ my $path = do {
+ my $is_power = Shell::Guess->running_shell->is_power;
+ local $File::Which::IMPLICIT_CURRENT_DIR = !$is_power;
+ which 'foo';
+ };
+
+ For a variety of reasons it is difficult to accurately compute the
+ shell that a user is using, but L<Shell::Guess> makes a reasonable
+ effort.
+
+ =head1 CAVEATS
+
+ This module has no non-core requirements for Perl 5.6.2 and better.
+
+ This module is fully supported back to Perl 5.8.1. It may work on 5.8.0.
+ It should work on Perl 5.6.x and I may even test on 5.6.2. I will accept
+ patches to maintain compatibility for such older Perls, but you may
+ need to fix it on 5.6.x / 5.8.0 and send me a patch.
+
+ Not tested on VMS although there is platform specific code
+ for those. Anyone who haves a second would be very kind to send me a
+ report of how it went.
+
+ =head1 SUPPORT
+
+ Bugs should be reported via the GitHub issue tracker
+
+ L<https://github.com/plicease/File-Which/issues>
+
+ For other issues, contact the maintainer.
+
+ =head1 SEE ALSO
+
+ =over 4
+
+ =item L<pwhich>, L<App::pwhich>
+
+ Command line interface to this module.
+
+ =item L<IPC::Cmd>
+
+ This module provides (among other things) a C<can_run> function, which is
+ similar to C<which>. It is a much heavier module since it does a lot more,
+ and if you use C<can_run> it pulls in L<ExtUtils::MakeMaker>. This combination
+ may be overkill for applications which do not need L<IPC::Cmd>'s complicated
+ interface for running programs, or do not need the memory overhead required
+ for installing Perl modules.
+
+ At least some older versions will find executables in the current directory,
+ even if the current directory is not in the search path (which is the default
+ on modern Unix).
+
+ C<can_run> converts directory path name to the 8.3 version on Windows using
+ C<Win32::GetShortPathName> in some cases. This is frequently useful for tools
+ that just need to run something using C<system> in scalar mode, but may be
+ inconvenient for tools like L<App::pwhich> where user readability is a premium.
+ Relying on C<Win32::GetShortPathName> to produce filenames without spaces
+ is problematic, as 8.3 filenames can be turned off with tweaks to the
+ registry (see L<https://technet.microsoft.com/en-us/library/cc959352.aspx>).
+
+ =item L<Devel::CheckBin>
+
+ This module purports to "check that a command is available", but does not
+ provide any documentation on how you might use it.
+
+ =back
+
+ =head1 AUTHORS
+
+ =over 4
+
+ =item *
+
+ Per Einar Ellefsen <pereinar@cpan.org>
+
+ =item *
+
+ Adam Kennedy <adamk@cpan.org>
+
+ =item *
+
+ Graham Ollis <plicease@cpan.org>
+
+ =back
+
+ =head1 COPYRIGHT AND LICENSE
+
+ This software is copyright (c) 2002 by Per Einar Ellefsen <pereinar@cpan.org>.
+
+ 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
+FILE_WHICH
+
+$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.016';
+
+ 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 {
+ # Called in void context?
+ unless (defined wantarray) {
+ warnings::warnif(void => 'Useless use of File::pushd::pushd in void context');
+ return
+ }
+
+ 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 {
+ # Called in void context?
+ unless (defined wantarray) {
+ warnings::warnif(void => 'Useless use of File::pushd::tempd in void context');
+ return
+ }
+
+ my ($options) = @_;
+ my $dir;
+ eval { $dir = pushd( File::Temp::tempdir( CLEANUP => 0 ), $options ) };
+ croak $@ if $@;
+ $dir->{_tempd} = 1;
+ $dir->{_owner} = $$;
+ 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->{_owner} == $$
+ && !$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.016
+
+ =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<chdir> that is easily and automatically
+ reverted, similar to C<pushd> 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<chdir> 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<File::Temp>.
+
+ For convenience, the object stringifies as the canonical form of the absolute
+ pathname of the directory entered.
+
+ B<Warning>: if you create multiple C<pushd> 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<pushd> and C<tempd> functions.
+
+ =head2 pushd
+
+ {
+ my $dir = pushd( $target_directory );
+ }
+
+ Caches the current working directory, calls C<chdir> 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<pushd> will die with an error message.
+
+ Can be given a hashref as an optional second argument. The only supported
+ option is C<untaint_pattern>, 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<pushd> but automatically creates and calls C<chdir> to
+ a temporary directory created by L<File::Temp>. Unlike normal L<File::Temp>
+ cleanup which happens at the end of the program, this temporary directory is
+ removed when the object is destroyed. (But also see C<preserve>.) A warning
+ will be issued if the directory cannot be removed.
+
+ As with C<pushd>, C<tempd> will die if C<chdir> fails.
+
+ It may be given a single options hash that will be passed internally
+ to C<pushd>.
+
+ =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<preserve> 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<tempd> objects may be
+ marked for cleanup. (Target directories to C<pushd> are always preserved.)
+ C<preserve> returns true if the directory will be preserved, and false
+ otherwise.
+
+ =head1 DIAGNOSTICS
+
+ C<pushd> and C<tempd> warn with message
+ C<"Useless use of File::pushd::I<%s> in void context"> if called in
+ void context and the warnings category C<void> is enabled.
+
+ {
+ use warnings 'void';
+
+ pushd();
+ }
+
+ =head1 SEE ALSO
+
+ =over 4
+
+ =item *
+
+ L<File::chdir>
+
+ =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<https://github.com/dagolden/File-pushd/issues>.
+ 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<https://github.com/dagolden/File-pushd>
+
+ git clone https://github.com/dagolden/File-pushd.git
+
+ =head1 AUTHOR
+
+ David Golden <dagolden@cpan.org>
+
+ =head1 CONTRIBUTORS
+
+ =for stopwords Diab Jerius Graham Ollis Olivier Mengué Shoichi Kaji
+
+ =over 4
+
+ =item *
+
+ Diab Jerius <djerius@cfa.harvard.edu>
+
+ =item *
+
+ Graham Ollis <plicease@cpan.org>
+
+ =item *
+
+ Olivier Mengué <dolmen@cpan.org>
+
+ =item *
+
+ Shoichi Kaji <skaji@cpan.org>
+
+ =back
+
+ =head1 COPYRIGHT AND LICENSE
+
+ This software is Copyright (c) 2018 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{"Getopt/Long.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'GETOPT_LONG';
#! perl
@@ -60669,1667 +39646,4554 @@ $fatpacked{"Getopt/Long.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'GET
GETOPT_LONG
-$fatpacked{"JSON.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON';
- package JSON;
+$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.076';
- use strict;
- use Carp ();
- use Exporter;
- BEGIN { @JSON::ISA = 'Exporter' }
+ sub _croak { require Carp; Carp::croak(@_) }
- @JSON::EXPORT = qw(from_json to_json jsonToObj objToJson encode_json decode_json);
+ #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<agent> — A user-agent string (defaults to 'HTTP-Tiny/$VERSION'). If
+ #pod C<agent> — ends in a space character, the default user-agent string is
+ #pod appended.
+ #pod * C<cookie_jar> — An instance of L<HTTP::CookieJar> — or equivalent class
+ #pod that supports the C<add> and C<cookie_header> methods
+ #pod * C<default_headers> — A hashref of default headers to apply to requests
+ #pod * C<local_address> — The local IP address to bind to
+ #pod * C<keep_alive> — Whether to reuse the last connection (if for the same
+ #pod scheme, host and port) (defaults to 1)
+ #pod * C<max_redirect> — Maximum number of redirects allowed (defaults to 5)
+ #pod * C<max_size> — Maximum response size in bytes (only when not using a data
+ #pod callback). If defined, responses larger than this will return an
+ #pod exception.
+ #pod * C<http_proxy> — URL of a proxy server to use for HTTP connections
+ #pod (default is C<$ENV{http_proxy}> — if set)
+ #pod * C<https_proxy> — URL of a proxy server to use for HTTPS connections
+ #pod (default is C<$ENV{https_proxy}> — if set)
+ #pod * C<proxy> — URL of a generic proxy server for both HTTP and HTTPS
+ #pod connections (default is C<$ENV{all_proxy}> — if set)
+ #pod * C<no_proxy> — List of domain suffixes that should not be proxied. Must
+ #pod be a comma-separated string or an array reference. (default is
+ #pod C<$ENV{no_proxy}> —)
+ #pod * C<timeout> — Request timeout in seconds (default is 60) If a socket open,
+ #pod read or write takes longer than the timeout, an exception is thrown.
+ #pod * C<verify_SSL> — A boolean that indicates whether to validate the SSL
+ #pod certificate of an C<https> — connection (default is false)
+ #pod * C<SSL_options> — A hashref of C<SSL_*> — options to pass through to
+ #pod L<IO::Socket::SSL>
+ #pod
+ #pod Passing an explicit C<undef> for C<proxy>, C<http_proxy> or C<https_proxy> will
+ #pod prevent getting the corresponding proxies from the environment.
+ #pod
+ #pod Exceptions from C<max_size>, C<timeout> 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<keep_alive> 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</SSL SUPPORT> for more on the C<verify_SSL> and C<SSL_options> attributes.
+ #pod
+ #pod =cut
+ my @attributes;
BEGIN {
- $JSON::VERSION = '2.94';
- $JSON::DEBUG = 0 unless (defined $JSON::DEBUG);
- $JSON::DEBUG = $ENV{ PERL_JSON_DEBUG } if exists $ENV{ PERL_JSON_DEBUG };
+ @attributes = qw(
+ cookie_jar default_headers http_proxy https_proxy keep_alive
+ local_address max_redirect max_size proxy no_proxy
+ 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};
+ };
+ }
}
- my %RequiredVersion = (
- 'JSON::PP' => '2.27203',
- 'JSON::XS' => '2.34',
- );
+ sub agent {
+ my($self, $agent) = @_;
+ if( @_ > 1 ){
+ $self->{agent} =
+ (defined $agent && $agent =~ / $/) ? $agent . $self->_agent : $agent;
+ }
+ return $self->{agent};
+ }
+
+ sub timeout {
+ my ($self, $timeout) = @_;
+ if ( @_ > 1 ) {
+ $self->{timeout} = $timeout;
+ if ($self->{handle}) {
+ $self->{handle}->timeout($timeout);
+ }
+ }
+ return $self->{timeout};
+ }
+
+ sub new {
+ my($class, %args) = @_;
+
+ my $self = {
+ max_redirect => 5,
+ timeout => defined $args{timeout} ? $args{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};
- # XS and PP common methods
+ for my $key ( @attributes ) {
+ $self->{$key} = $args{$key} if exists $args{$key}
+ }
- 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
- /;
+ $self->agent( exists $args{agent} ? $args{agent} : $class->_agent );
- 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
- /;
+ $self->_set_proxies;
- my @XSOnlyMethods = qw/allow_tags/; # Currently nothing
+ return $self;
+ }
- my @PPOnlyMethods = qw/
- indent_length sort_by
- allow_singlequote allow_bignum loose allow_barekey escape_slash as_nonblessed
- /; # JSON::PP specific
+ sub _set_proxies {
+ my ($self) = @_;
+ # get proxies from %ENV only if not provided; explicit undef will disable
+ # getting proxies from the environment
- # 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 $_ALLOW_UNSUPPORTED = 0;
- my $_UNIV_CONV_BLESSED = 0;
+ # 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};
+ }
- # Check the environment variable to decide worker module.
+ # 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} ] : [];
+ }
- unless ($JSON::Backend) {
- $JSON::DEBUG and Carp::carp("Check used worker module...");
+ 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<request()> for the given method. The
+ #pod URL must have unsafe characters escaped and international domain names encoded.
+ #pod See C<request()> for valid options and a description of the response.
+ #pod
+ #pod The C<success> 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 _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<POST> request and sends the key/value pairs from a
+ #pod form data hash or array reference to the given URL with a C<content-type> of
+ #pod C<application/x-www-form-urlencoded>. 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<www_form_urlencode> method for details on the encoding.
+ #pod
+ #pod The URL must have unsafe characters escaped and international domain names
+ #pod encoded. See C<request()> for valid options and a description of the response.
+ #pod Any C<content-type> header or content in the options hashref will be ignored.
+ #pod
+ #pod The C<success> field of the response will be true if the status code is 2XX.
+ #pod
+ #pod =cut
- my $backend = exists $ENV{PERL_JSON_BACKEND} ? $ENV{PERL_JSON_BACKEND} : 1;
+ sub post_form {
+ my ($self, $url, $data, $args) = @_;
+ (@_ == 3 || @_ == 4 && ref $args eq 'HASH')
+ or _croak(q/Usage: $http->post_form(URL, DATAREF, [HASHREF])/ . "\n");
- if ($backend eq '1') {
- $backend = 'JSON::XS,JSON::PP';
+ my $headers = {};
+ while ( my ($key, $value) = each %{$args->{headers} || {}} ) {
+ $headers->{lc $key} = $value;
}
- elsif ($backend eq '0') {
- $backend = 'JSON::PP';
+ 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<GET> 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<If-Modified-Since> header with the modification timestamp of the file. You
+ #pod may specify a different C<If-Modified-Since> header yourself in the C<<
+ #pod $options->{headers} >> hash.
+ #pod
+ #pod The C<success> 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<Last-Modified> 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 _croak(q/Usage: $http->mirror(URL, FILE, [HASHREF])/ . "\n");
+
+ if ( exists $args->{headers} ) {
+ my $headers = {};
+ while ( my ($key, $value) = each %{$args->{headers} || {}} ) {
+ $headers->{lc $key} = $value;
+ }
+ $args->{headers} = $headers;
}
- elsif ($backend eq '2') {
- $backend = 'JSON::XS';
+
+ if ( -e $file and my $mtime = (stat($file))[9] ) {
+ $args->{headers}{'if-modified-since'} ||= $self->_http_date($mtime);
}
- $backend =~ s/\s+//g;
+ my $tempfile = $file . int(rand(2**31));
- my @backend_modules = split /,/, $backend;
- while(my $module = shift @backend_modules) {
- if ($module =~ /JSON::XS/) {
- _load_xs($module, @backend_modules ? $_INSTALL_DONT_DIE : 0);
+ require Fcntl;
+ sysopen my $fh, $tempfile, Fcntl::O_CREAT()|Fcntl::O_EXCL()|Fcntl::O_WRONLY()
+ or _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 _croak(qq/Error: Caught error closing temporary file $tempfile: $!\n/);
+
+ if ( $response->{success} ) {
+ rename $tempfile, $file
+ or _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;
}
- elsif ($module =~ /JSON::PP/) {
- _load_pp($module);
+ }
+ $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 B<NOTE>: Method names are B<case-sensitive> per the HTTP/1.1 specification.
+ #pod Don't use C<get> when you really want C<GET>. See L<LIMITATIONS> for
+ #pod how this applies to redirection.
+ #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<headers> —
+ #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<content> —
+ #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<trailer_callback> —
+ #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<data_callback> —
+ #pod A code reference that will be called for each chunks of the response
+ #pod body received.
+ #pod * C<peer> —
+ #pod Override host resolution and force all connections to go only to a
+ #pod specific peer address, regardless of the URL of the request. This will
+ #pod include any redirections! This options should be used with extreme
+ #pod caution (e.g. debugging or very special circumstances). It can be given as
+ #pod either a scalar or a code reference that will receive the hostname and
+ #pod whose response will be taken as the address.
+ #pod
+ #pod The C<Host> header is generated from the URL in accordance with RFC 2616. It
+ #pod is a fatal error to specify C<Host> in the C<headers> option. Other headers
+ #pod may be ignored or overwritten if necessary for transport compliance.
+ #pod
+ #pod If the C<content> 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<content> option is the empty string, no C<content-type> or
+ #pod C<content-length> headers will be generated.
+ #pod
+ #pod If the C<data_callback> 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<status> or C<headers>
+ #pod received prior to the content body.)
+ #pod
+ #pod The C<request> method returns a hashref containing the response. The hashref
+ #pod will have the following keys:
+ #pod
+ #pod =for :list
+ #pod * C<success> —
+ #pod Boolean indicating whether the operation returned a 2XX status code
+ #pod * C<url> —
+ #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<status> —
+ #pod The HTTP status code of the response
+ #pod * C<reason> —
+ #pod The response phrase returned by the server
+ #pod * C<content> —
+ #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<headers> —
+ #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 * C<protocol> -
+ #pod If this field exists, it is the protocol of the response
+ #pod such as HTTP/1.0 or HTTP/1.1
+ #pod * C<redirects>
+ #pod If this field exists, it is an arrayref of response hash references from
+ #pod redirects in the same order that redirections occurred. If it does
+ #pod not exist, then no redirections occurred.
+ #pod
+ #pod On an exception during the execution of the request, the C<status> field will
+ #pod contain 599, and the C<content> 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 _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} ) {
+ $e->{redirects} = delete $args->{_redirects} if @{ $args->{_redirects} || []};
+ return $e;
}
- elsif ($module =~ /JSON::backportPP/) {
- _load_pp($module);
+
+ # 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,
+ },
+ ( @{$args->{_redirects} || []} ? (redirects => delete $args->{_redirects}) : () ),
+ };
+ }
+ 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<x-www-form-urlencoded> 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 _croak(q/Usage: $http->www_form_urlencode(DATAREF)/ . "\n");
+ (ref $data eq 'HASH' || ref $data eq 'ARRAY')
+ or _croak("form data must be a hash or array reference\n");
+
+ my @params = ref $data eq 'HASH' ? %$data : @$data;
+ @params % 2 == 0
+ or _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 {
- Carp::croak "The value of environmental variable 'PERL_JSON_BACKEND' is invalid.";
+ push @terms, join("=", map { $self->_uri_escape($_) } $key, $value);
}
- last if $JSON::Backend;
}
+
+ 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<Net::SSLeay> and L<IO::Socket::SSL>.
+ #pod When called as an object methods, if C<SSL_verify> is true or if C<SSL_verify_mode>
+ #pod is set in C<SSL_options>, 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 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->is_xs);
- }
- next;
+ sub can_ssl {
+ my ($self) = @_;
+
+ my($ok, $reason) = (1, '');
+
+ # Need IO::Socket::SSL 1.42 for SSL_create_ctx_callback
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
+ 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 .= "$@";
}
- elsif ($tag eq '-no_export') {
- $no_export++, next;
+ }
+
+ wantarray ? ($ok, $reason) : $ok;
+ }
+
+ #pod =method connected
+ #pod
+ #pod $host = $http->connected;
+ #pod ($host, $port) = $http->connected;
+ #pod
+ #pod Indicates if a connection to a peer is being kept alive, per the C<keep_alive>
+ #pod option.
+ #pod
+ #pod In scalar context, returns the peer host and port, joined with a colon, or
+ #pod C<undef> (if no peer is connected).
+ #pod In list context, returns the peer host and port or an empty list (if no peer
+ #pod is connected).
+ #pod
+ #pod B<Note>: This method cannot reliably be used to discover whether the remote
+ #pod host has closed its end of the socket.
+ #pod
+ #pod =cut
+
+ sub connected {
+ my ($self) = @_;
+
+ # If a socket exists...
+ if ($self->{handle} && $self->{handle}{fh}) {
+ my $socket = $self->{handle}{fh};
+
+ # ...and is connected, return the peer host and port.
+ if ($socket->connected) {
+ return wantarray
+ ? ($socket->peerhost, $socket->peerport)
+ : join(':', $socket->peerhost, $socket->peerport);
}
- elsif ( $tag eq '-convert_blessed_universally' ) {
- my $org_encode = $JSON::Backend->can('encode');
- eval q|
- require B;
- local $^W;
- no strict 'refs';
- *{"${JSON::Backend}\::encode"} = sub {
- # only works with Perl 5.18+
- local *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
- ;
- };
- $org_encode->(@_);
- };
- | if ( !$_UNIV_CONV_BLESSED++ );
- next;
+ }
+ return;
+ }
+
+ #--------------------------------------------------------------------------#
+ # 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 => {},
+ };
+
+ my $peer = $args->{peer} || $host;
+
+ # Allow 'peer' to be a coderef.
+ if ('CODE' eq ref $peer) {
+ $peer = $peer->($host);
+ }
+
+ # 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, $peer ) ) {
+ $handle->close;
+ undef $handle;
}
- push @what_to_export, $tag;
+ }
+ $handle ||= $self->_open_handle( $request, $scheme, $host, $port, $peer );
+
+ $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};
+ my @redir_args = $self->_maybe_redirect($request, $response, $args);
+
+ my $known_message_length;
+ if ($method eq 'HEAD' || $response->{status} =~ /^[23]04/) {
+ # response has no message body
+ $known_message_length = 1;
+ }
+ else {
+ # Ignore any data callbacks during redirection.
+ my $cb_args = @redir_args ? +{} : $args;
+ my $data_cb = $self->_prepare_data_cb($response, $cb_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;
+
+ # Push the current response onto the stack of redirects if redirecting.
+ if (@redir_args) {
+ push @{$args->{_redirects}}, $response;
+ return $self->_request(@redir_args, $args);
}
- return if ($no_export);
+ # Copy the stack of redirects into the response before returning.
+ $response->{redirects} = delete $args->{_redirects}
+ if @{$args->{_redirects}};
+ return $response;
+ }
+
+ sub _open_handle {
+ my ($self, $request, $scheme, $host, $port, $peer) = @_;
+
+ 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}
+ );
- __PACKAGE__->export_to_level(1, $pkg, @what_to_export);
+ 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, $peer);
+ }
}
+ sub _proxy_connect {
+ my ($self, $request, $handle) = @_;
- # OBSOLETED
+ my @proxy_vars;
+ if ( $request->{scheme} eq 'https' ) {
+ _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' ) {
+ _croak(qq{Can't proxy https over https: $request->{uri} via $self->{https_proxy}});
+ }
+ }
+ else {
+ _croak(qq{No http_proxy defined}) unless $self->{http_proxy};
+ @proxy_vars = $self->_split_proxy( http_proxy => $self->{http_proxy} );
+ }
- sub jsonToObj {
- my $alternative = 'from_json';
- if (defined $_[0] and UNIVERSAL::isa($_[0], 'JSON')) {
- shift @_; $alternative = 'decode';
+ 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 );
}
- 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';
+ $handle->connect($p_scheme, $p_host, $p_port, $p_host);
+
+ 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}";
}
- Carp::carp "'objToJson' will be obsoleted. Please use '$alternative' instead.";
- JSON::to_json(@_);
- };
+ return $handle;
+ }
- # INTERFACES
+ sub _split_proxy {
+ my ($self, $type, $proxy) = @_;
- sub to_json ($@) {
- if (
- ref($_[0]) eq 'JSON'
- or (@_ > 2 and $_[0] eq 'JSON')
+ 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 "to_json should not be called as a method.";
+ _croak(qq{$type URL must be in format http[s]://[auth@]<host>:<port>/\n});
}
- my $json = JSON->new;
- if (@_ == 2 and ref $_[1] eq 'HASH') {
- my $opt = $_[1];
- for my $method (keys %$opt) {
- $json->$method( $opt->{$method} );
+ 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'};
}
- $json->encode($_[0]);
+ $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) = @_;
- sub from_json ($@) {
- if ( ref($_[0]) eq 'JSON' or $_[0] eq 'JSON' ) {
- Carp::croak "from_json should not be called as a method.";
+ for ($self->{default_headers}, $args->{headers}) {
+ next unless defined;
+ while (my ($k, $v) = each %$_) {
+ $request->{headers}{lc $k} = $v;
+ $request->{header_case}{lc $k} = $k;
+ }
}
- my $json = JSON->new;
- if (@_ == 2 and ref $_[1] eq 'HASH') {
- my $opt = $_[1];
- for my $method (keys %$opt) {
- $json->$method( $opt->{$method} );
+ 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 $json->decode( $_[0] );
+ 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} = '';
- sub true { $JSON::true }
+ 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 false { $JSON::false }
+ sub _update_cookie_jar {
+ my ($self, $url, $response) = @_;
- sub null { undef; }
+ my $cookies = $response->{headers}->{'set-cookie'};
+ return unless defined $cookies;
+ my @cookies = ref $cookies ? @$cookies : $cookies;
- sub require_xs_version { $RequiredVersion{'JSON::XS'}; }
+ $self->cookie_jar->add( $url, $_ ) for @cookies;
- sub backend {
- my $proto = shift;
- $JSON::Backend;
+ return;
}
- #*module = *backend;
+ sub _validate_cookie_jar {
+ my ($class, $jar) = @_;
+ # duck typing
+ for my $method ( qw/add cookie_header/ ) {
+ _croak(qq/Cookie jar must provide the '$method' method\n/)
+ unless ref($jar) && ref($jar)->can($method);
+ }
- sub is_xs {
- return $_[0]->backend->is_xs;
+ return;
}
+ sub _maybe_redirect {
+ my ($self, $request, $response, $args) = @_;
+ my $headers = $response->{headers};
+ my ($status, $method) = ($response->{status}, $request->{method});
+ $args->{_redirects} ||= [];
- sub is_pp {
- return $_[0]->backend->is_pp;
+ 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;
- sub pureperl_only_methods { @PPOnlyMethods; }
+ # 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/>;
- sub property {
- my ($self, $name, $value) = @_;
+ 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
- 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;
+ # 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}/g;
+ 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];
+ use Socket qw[SOL_SOCKET SO_KEEPALIVE];
+
+ # 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]/;
+ my $Field_Content = qr/[[:print:]]+ (?: [\x20\x09]+ [[:print:]]+ )*/x;
+
+ 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 timeout {
+ my ($self, $timeout) = @_;
+ if ( @_ > 1 ) {
+ $self->{timeout} = $timeout;
+ if ( $self->{fh} && $self->{fh}->can('timeout') ) {
+ $self->{fh}->timeout($timeout);
+ }
+ }
+ return $self->{timeout};
+ }
+
+ sub connect {
+ @_ == 5 || die(q/Usage: $handle->connect(scheme, host, port, peer)/ . "\n");
+ my ($self, $scheme, $host, $port, $peer) = @_;
+
+ if ( $scheme eq 'https' ) {
+ $self->_assert_ssl;
+ }
+ elsif ( $scheme ne 'http' ) {
+ die(qq/Unsupported URL scheme '$scheme'\n/);
+ }
+ $self->{fh} = $SOCKET_CLASS->new(
+ PeerHost => $peer,
+ PeerPort => $port,
+ $self->{local_address} ?
+ ( LocalAddr => $self->{local_address} ) : (),
+ Proto => 'tcp',
+ Type => SOCK_STREAM,
+ Timeout => $self->{timeout},
+ ) or die(qq/Could not connect to '$host:$port': $@\n/);
+
+ binmode($self->{fh})
+ or die(qq/Could not binmode() socket: '$!'\n/);
+
+ if ( $self->{keep_alive} ) {
+ unless ( defined( $self->{fh}->setsockopt( SOL_SOCKET, SO_KEEPALIVE, 1 ) ) ) {
+ CORE::close($self->{fh});
+ die(qq/Could not set SO_KEEPALIVE on socket: '$!'\n/);
+ }
+ }
+
+ $self->start_ssl($host) if $scheme eq 'https';
+
+ $self->{scheme} = $scheme;
+ $self->{host} = $host;
+ $self->{peer} = $peer;
+ $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 /);
}
- $props{$name} = $self->$method();
+ else {
+ die(qq/Could not write to socket: '$!'\n/);
+ }
+
}
- return \%props;
}
- elsif (@_ > 3) {
- Carp::croak('property() can take only the option within 2 arguments.');
+ 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;
}
- elsif (@_ == 2) {
- if ( my $method = $self->can('get_' . $name) ) {
- if ($name eq 'max_size') {
- my $value = $self->$method();
- return $value == 1 ? 0 : $value;
+
+ 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/);
}
- $self->$method();
}
}
- else {
- $self->$name($value);
+ 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;
- # INTERNAL
+ 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 __load_xs {
- my ($module, $opt) = @_;
+ sub write_request {
+ @_ == 2 || die(q/Usage: $handle->write_request(request)/ . "\n");
+ my($self, $request) = @_;
+ $self->write_request_header(@{$request}{qw/method uri headers header_case/});
+ $self->write_body($request) if $request->{cb};
+ return;
+ }
- $JSON::DEBUG and Carp::carp "Load $module.";
- my $required_version = $RequiredVersion{$module} || '';
+ # Standard request header names/case from HTTP/1.1 RFCs
+ my @rfc_request_headers = qw(
+ Accept Accept-Charset Accept-Encoding Accept-Language Authorization
+ Cache-Control Connection Content-Length Expect From Host
+ If-Match If-Modified-Since If-None-Match If-Range If-Unmodified-Since
+ Max-Forwards Pragma Proxy-Authorization Range Referer TE Trailer
+ Transfer-Encoding Upgrade User-Agent Via
+ );
- eval qq|
- use $module $required_version ();
- |;
+ my @other_request_headers = qw(
+ Content-Encoding Content-MD5 Content-Type Cookie DNT Date Origin
+ X-XSS-Protection
+ );
- if ($@) {
- if (defined $opt and $opt & $_INSTALL_DONT_DIE) {
- $JSON::DEBUG and Carp::carp "Can't load $module...($@)";
- return 0;
+ my %HeaderCase = map { lc($_) => $_ } @rfc_request_headers, @other_request_headers;
+
+ # 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 && @_ <= 4 && ref $_[1] eq 'HASH') || die(q/Usage: $handle->write_header_lines(headers, [header_case, prefix])/ . "\n");
+ my($self, $headers, $header_case, $prefix_data) = @_;
+ $header_case ||= {};
+
+ my $buf = (defined $prefix_data ? $prefix_data : '');
+
+ # Per RFC, control fields should be listed first
+ my %seen;
+ for my $k ( qw/host cache-control expect max-forwards pragma range te/ ) {
+ next unless exists $headers->{$k};
+ $seen{$k}++;
+ my $field_name = $HeaderCase{$k};
+ my $v = $headers->{$k};
+ for (ref $v eq 'ARRAY' ? @$v : $v) {
+ $_ = '' unless defined $_;
+ $buf .= "$field_name: $_\x0D\x0A";
}
- Carp::croak $@;
}
- $JSON::BackendModuleXS = $module;
- return 1;
+
+ # Other headers sent in arbitrary order
+ while (my ($k, $v) = each %$headers) {
+ my $field_name = lc $k;
+ next if $seen{$field_name};
+ if (exists $HeaderCase{$field_name}) {
+ $field_name = $HeaderCase{$field_name};
+ }
+ else {
+ if (exists $header_case->{$field_name}) {
+ $field_name = $header_case->{$field_name};
+ }
+ else {
+ $field_name =~ s/\b(\w)/\u$1/g;
+ }
+ $field_name =~ /\A $Token+ \z/xo
+ or die(q/Invalid HTTP header field name: / . $Printable->($field_name) . "\n");
+ $HeaderCase{lc $field_name} = $field_name;
+ }
+ for (ref $v eq 'ARRAY' ? @$v : $v) {
+ # unwrap a field value if pre-wrapped by user
+ s/\x0D?\x0A\s+/ /g;
+ die(qq/Invalid HTTP header field value ($field_name): / . $Printable->($_). "\n")
+ unless $_ eq '' || /\A $Field_Content \z/xo;
+ $_ = '' unless defined $_;
+ $buf .= "$field_name: $_\x0D\x0A";
+ }
+ }
+ $buf .= "\x0D\x0A";
+ return $self->write($buf);
}
- sub _load_xs {
- my ($module, $opt) = @_;
- __load_xs($module, $opt) or return;
+ # 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);
+ }
- my $data = join("", <DATA>); # this code is from Jcode 2.xx.
- close(DATA);
- eval $data;
- JSON::Backend::XS->init($module);
+ 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);
+ }
+ }
- return 1;
- };
+ 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) );
- sub __load_pp {
- my ($module, $opt) = @_;
+ return;
+ }
- $JSON::DEBUG and Carp::carp "Load $module.";
- my $required_version = $RequiredVersion{$module} || '';
+ sub write_content_body {
+ @_ == 2 || die(q/Usage: $handle->write_content_body(request)/ . "\n");
+ my ($self, $request) = @_;
- eval qq| use $module $required_version () |;
+ my ($len, $content_length) = (0, $request->{headers}{'content-length'});
+ while () {
+ my $data = $request->{cb}->();
- if ($@) {
- if ( $module eq 'JSON::PP' ) {
- $JSON::DEBUG and Carp::carp "Can't load $module ($@), so try to load JSON::backportPP";
- $module = 'JSON::backportPP';
- local $^W; # if PP installed but invalid version, backportPP redefines methods.
- eval qq| require $module |;
+ defined $data && length $data
+ or last;
+
+ if ( $] ge '5.008' ) {
+ utf8::downgrade($data, 1)
+ or die(qq/Wide character in write_content()\n/);
}
- Carp::croak $@ if $@;
+
+ $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/);
}
- $JSON::BackendModulePP = $module;
+ $self->read_header_lines($response->{headers});
return 1;
}
- sub _load_pp {
- my ($module, $opt) = @_;
- __load_pp($module, $opt);
+ sub write_chunked_body {
+ @_ == 2 || die(q/Usage: $handle->write_chunked_body(request)/ . "\n");
+ my ($self, $request) = @_;
- JSON::Backend::PP->init($module);
- };
+ my $len = 0;
+ while () {
+ my $data = $request->{cb}->();
- #
- # Helper classes for Backend Module (PP)
- #
+ defined $data && length $data
+ or last;
- package JSON::Backend::PP;
+ if ( $] ge '5.008' ) {
+ utf8::downgrade($data, 1)
+ or die(qq/Wide character in write_chunked_body()\n/);
+ }
- sub init {
- my ($class, $module) = @_;
+ $len += length $data;
- # name may vary, but the module should (always) be a JSON::PP
+ my $chunk = sprintf '%X', length $data;
+ $chunk .= "\x0D\x0A";
+ $chunk .= $data;
+ $chunk .= "\x0D\x0A";
- 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::is_bool"} = \&{"JSON::PP::is_bool"};
+ $self->write($chunk);
+ }
+ $self->write("0\x0D\x0A");
+ if ( ref $request->{trailer_cb} eq 'CODE' ) {
+ $self->write_header_lines($request->{trailer_cb}->())
+ }
+ else {
+ $self->write("\x0D\x0A");
+ }
+ return $len;
+ }
- $JSON::true = ${"JSON::PP::true"};
- $JSON::false = ${"JSON::PP::false"};
+ sub read_response_header {
+ @_ == 1 || die(q/Usage: $handle->read_response_header()/ . "\n");
+ my ($self) = @_;
- push @JSON::Backend::PP::ISA, 'JSON::PP';
- push @JSON::ISA, $class;
- $JSON::Backend = $class;
- $JSON::BackendModule = $module;
- ${"$class\::VERSION"} = $module->VERSION;
+ my $line = $self->readline;
- for my $method (@XSOnlyMethods) {
- *{"JSON::$method"} = sub {
- Carp::carp("$method is not supported in $module.");
- $_[0];
- };
+ $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 {
+ @_ == 5 || die(q/Usage: $handle->write_request_header(method, request_uri, headers, header_case)/ . "\n");
+ my ($self, $method, $request_uri, $headers, $header_case) = @_;
+
+ return $self->write_header_lines($headers, $header_case, "$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;
+ }
- return 1;
+ 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,$peer) = @_;
+ return 0 if
+ $self->{pid} != $$
+ || $self->{tid} != _get_tid()
+ || length($self->{rbuf})
+ || $scheme ne $self->{scheme}
+ || $host ne $self->{host}
+ || $port ne $self->{port}
+ || $peer ne $self->{peer}
+ || eval { $self->can_read(0) }
+ || $@ ;
+ return 1;
}
- sub is_xs { 0 };
- sub is_pp { 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();
- #
- # To save memory, the below lines are read only when XS backend is used.
- #
+ my $ca_file =
+ defined( $self->{SSL_options}->{SSL_ca_file} )
+ ? $self->{SSL_options}->{SSL_ca_file}
+ : $ENV{SSL_CERT_FILE};
- package JSON;
+ if ( defined $ca_file ) {
+ unless ( -r $ca_file ) {
+ die qq/SSL_ca_file '$ca_file' not found or not readable\n/;
+ }
+ return $ca_file;
+ }
+
+ local @INC = @INC;
+ pop @INC if $INC[-1] eq '.';
+ 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;
- __DATA__
+ __END__
- #
- # Helper classes for Backend Module (XS)
- #
+ =pod
+
+ =encoding UTF-8
+
+ =head1 NAME
+
+ HTTP::Tiny - A small, simple, correct HTTP/1.1 client
+
+ =head1 VERSION
- package JSON::Backend::XS;
+ version 0.076
- sub init {
- my ($class, $module) = @_;
+ =head1 SYNOPSIS
+
+ use HTTP::Tiny;
- local $^W;
- no strict qw(refs);
- *{"JSON::decode_json"} = \&{"$module\::decode_json"};
- *{"JSON::encode_json"} = \&{"$module\::encode_json"};
- *{"JSON::is_bool"} = \&{"$module\::is_bool"};
+ my $response = HTTP::Tiny->new->get('http://example.com/');
- $JSON::true = ${"$module\::true"};
- $JSON::false = ${"$module\::false"};
+ die "Failed!\n" unless $response->{success};
- push @JSON::Backend::XS::ISA, $module;
- push @JSON::ISA, $class;
- $JSON::Backend = $class;
- $JSON::BackendModule = $module;
- ${"$class\::VERSION"} = $module->VERSION;
+ print "$response->{status} $response->{reason}\n";
- if ( $module->VERSION < 3 ) {
- eval 'package JSON::PP::Boolean';
- push @{"$module\::Boolean::ISA"}, qw(JSON::PP::Boolean);
+ while (my ($k, $v) = each %{$response->{headers}}) {
+ for (ref $v eq 'ARRAY' ? @$v : $v) {
+ print "$k: $_\n";
+ }
}
- for my $method (@PPOnlyMethods) {
- *{"JSON::$method"} = sub {
- Carp::carp("$method is not supported in $module.");
- $_[0];
- };
+ 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<LWP::UserAgent>.
+
+ It is more correct and more complete than L<HTTP::Lite>. It supports
+ proxies and redirection. It also correctly resumes after EINTR.
+
+ If L<IO::Socket::IP> 0.25 or later is installed, HTTP::Tiny will use it instead
+ of L<IO::Socket::INET> for transparent support for both IPv4 and IPv6.
+
+ Cookie support requires L<HTTP::CookieJar> 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<agent> — A user-agent string (defaults to 'HTTP-Tiny/$VERSION'). If C<agent> — ends in a space character, the default user-agent string is appended.
+
+ =item *
+
+ C<cookie_jar> — An instance of L<HTTP::CookieJar> — or equivalent class that supports the C<add> and C<cookie_header> methods
+
+ =item *
+
+ C<default_headers> — A hashref of default headers to apply to requests
+
+ =item *
+
+ C<local_address> — The local IP address to bind to
+
+ =item *
+
+ C<keep_alive> — Whether to reuse the last connection (if for the same scheme, host and port) (defaults to 1)
+
+ =item *
+
+ C<max_redirect> — Maximum number of redirects allowed (defaults to 5)
+
+ =item *
+
+ C<max_size> — Maximum response size in bytes (only when not using a data callback). If defined, responses larger than this will return an exception.
+
+ =item *
+
+ C<http_proxy> — URL of a proxy server to use for HTTP connections (default is C<$ENV{http_proxy}> — if set)
+
+ =item *
+
+ C<https_proxy> — URL of a proxy server to use for HTTPS connections (default is C<$ENV{https_proxy}> — if set)
+
+ =item *
+
+ C<proxy> — URL of a generic proxy server for both HTTP and HTTPS connections (default is C<$ENV{all_proxy}> — if set)
+
+ =item *
+
+ C<no_proxy> — 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<timeout> — Request timeout in seconds (default is 60) If a socket open, read or write takes longer than the timeout, an exception is thrown.
+
+ =item *
+
+ C<verify_SSL> — A boolean that indicates whether to validate the SSL certificate of an C<https> — connection (default is false)
+
+ =item *
+
+ C<SSL_options> — A hashref of C<SSL_*> — options to pass through to L<IO::Socket::SSL>
+
+ =back
+
+ Passing an explicit C<undef> for C<proxy>, C<http_proxy> or C<https_proxy> will
+ prevent getting the corresponding proxies from the environment.
+
+ Exceptions from C<max_size>, C<timeout> 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<keep_alive> 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</SSL SUPPORT> for more on the C<verify_SSL> and C<SSL_options> 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<request()> for the given method. The
+ URL must have unsafe characters escaped and international domain names encoded.
+ See C<request()> for valid options and a description of the response.
+
+ The C<success> 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<POST> request and sends the key/value pairs from a
+ form data hash or array reference to the given URL with a C<content-type> of
+ C<application/x-www-form-urlencoded>. 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<www_form_urlencode> method for details on the encoding.
+
+ The URL must have unsafe characters escaped and international domain names
+ encoded. See C<request()> for valid options and a description of the response.
+ Any C<content-type> header or content in the options hashref will be ignored.
+
+ The C<success> 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";
}
- return 1;
+ Executes a C<GET> 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<If-Modified-Since> header with the modification timestamp of the file. You
+ may specify a different C<If-Modified-Since> header yourself in the C<<
+ $options->{headers} >> hash.
+
+ The C<success> 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<Last-Modified> 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.
+
+ B<NOTE>: Method names are B<case-sensitive> per the HTTP/1.1 specification.
+ Don't use C<get> when you really want C<GET>. See L<LIMITATIONS> for
+ how this applies to redirection.
+
+ 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<headers> — 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<content> — 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<trailer_callback> — 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<data_callback> — A code reference that will be called for each chunks of the response body received.
+
+ =item *
+
+ C<peer> — Override host resolution and force all connections to go only to a specific peer address, regardless of the URL of the request. This will include any redirections! This options should be used with extreme caution (e.g. debugging or very special circumstances). It can be given as either a scalar or a code reference that will receive the hostname and whose response will be taken as the address.
+
+ =back
+
+ The C<Host> header is generated from the URL in accordance with RFC 2616. It
+ is a fatal error to specify C<Host> in the C<headers> option. Other headers
+ may be ignored or overwritten if necessary for transport compliance.
+
+ If the C<content> 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<content> option is the empty string, no C<content-type> or
+ C<content-length> headers will be generated.
+
+ If the C<data_callback> 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<status> or C<headers>
+ received prior to the content body.)
+
+ The C<request> method returns a hashref containing the response. The hashref
+ will have the following keys:
+
+ =over 4
+
+ =item *
+
+ C<success> — Boolean indicating whether the operation returned a 2XX status code
+
+ =item *
+
+ C<url> — 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<status> — The HTTP status code of the response
+
+ =item *
+
+ C<reason> — The response phrase returned by the server
+
+ =item *
+
+ C<content> — 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<headers> — 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
+
+ =item *
+
+ C<protocol> - If this field exists, it is the protocol of the response such as HTTP/1.0 or HTTP/1.1
+
+ =item *
+
+ C<redirects> If this field exists, it is an arrayref of response hash references from redirects in the same order that redirections occurred. If it does not exist, then no redirections occurred.
+
+ =back
+
+ On an exception during the execution of the request, the C<status> field will
+ contain 599, and the C<content> 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<x-www-form-urlencoded> 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<Net::SSLeay> and L<IO::Socket::SSL>.
+ When called as an object methods, if C<SSL_verify> is true or if C<SSL_verify_mode>
+ is set in C<SSL_options>, 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.
+
+ =head2 connected
+
+ $host = $http->connected;
+ ($host, $port) = $http->connected;
+
+ Indicates if a connection to a peer is being kept alive, per the C<keep_alive>
+ option.
+
+ In scalar context, returns the peer host and port, joined with a colon, or
+ C<undef> (if no peer is connected).
+ In list context, returns the peer host and port or an empty list (if no peer
+ is connected).
+
+ B<Note>: This method cannot reliably be used to discover whether the remote
+ host has closed its end of the socket.
+
+ =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<https> connections are supported only if L<IO::Socket::SSL> 1.56 or
+ greater and L<Net::SSLeay> 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<HTTP::Tiny::can_ssl()> utility function
+ that returns boolean to see if the required modules are installed.
+
+ An C<https> connection may be made via an C<http> proxy that supports the CONNECT
+ command (i.e. RFC 2817). You may not proxy C<https> via a proxy that itself
+ requires C<https> to communicate.
+
+ SSL provides two distinct capabilities:
+
+ =over 4
+
+ =item *
+
+ Encrypted communication channel
+
+ =item *
+
+ Verification of server identity
+
+ =back
+
+ B<By default, HTTP::Tiny does not verify server identity>.
+
+ 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<CAcert.org|http://cacert.org>.
+
+ 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<verify_SSL> 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<man-in-the-middle
+ attack|http://en.wikipedia.org/wiki/Man-in-the-middle_attack>. If you are
+ concerned about security, you should enable this option.
+
+ Certificate verification requires a file containing trusted CA certificates.
+
+ If the environment variable C<SSL_CERT_FILE> is present, HTTP::Tiny
+ will try to find a CA certificate file in that location.
+
+ If the L<Mozilla::CA> 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<verify_SSL> is true and no CA certificate file
+ is available.
+
+ If you desire complete control over SSL connections, the C<SSL_options> attribute
+ lets you provide a hash reference that will be passed through to
+ C<IO::Socket::SSL::start_SSL()>, 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<SSL_options> 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<IO::Socket::SSL> documentation for
+ details.
+
+ =head1 PROXY SUPPORT
+
+ HTTP::Tiny can proxy both C<http> and C<https> requests. Only Basic proxy
+ authorization is supported and it must be provided as part of the proxy URL:
+ C<http://user:pass@proxy.example.com/>.
+
+ 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<REQUEST_METHOD> environment variable is set, then this might be a CGI
+ process and C<HTTP_PROXY> would be set from the C<Proxy:> header, which is a
+ security risk. If C<REQUEST_METHOD> is set, C<HTTP_PROXY> (the upper case
+ variant only) is ignored.
+
+ Tunnelling C<https> over an C<http> proxy using the CONNECT method is
+ supported. If your proxy uses C<https> itself, you can not tunnel C<https>
+ over it.
+
+ Be warned that proxying an C<https> connection opens you to the risk of a
+ man-in-the-middle attack by the proxy server.
+
+ The C<no_proxy> 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<new> will override their corresponding
+ environment variables.
+
+ =head1 LIMITATIONS
+
+ HTTP::Tiny is I<conditionally compliant> with the
+ L<HTTP/1.1 specifications|http://www.w3.org/Protocols/>:
+
+ =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<URI::Escape>,
+ L<URI::_punycode> and L<Net::IDN::Encode>.
+
+ =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<Expect> header.
+ Unexpected C<1XX> responses are silently ignored as per the specification.
+
+ =item *
+
+ Only 'chunked' C<Transfer-Encoding> is supported.
+
+ =item *
+
+ There is no support for a Request-URI of '*' for the 'OPTIONS' request.
+
+ =item *
+
+ Headers mentioned in the RFCs and some other, well-known headers are
+ generated with their canonical case. Other headers are sent in the
+ case provided by the user. Except for control headers (which are sent first),
+ headers are sent in arbitrary order.
+
+ =back
+
+ Despite the limitations listed above, HTTP::Tiny is considered
+ feature-complete. New feature requests should be directed to
+ L<HTTP::Tiny::UA>.
+
+ =head1 SEE ALSO
+
+ =over 4
+
+ =item *
+
+ L<HTTP::Tiny::UA> - Higher level UA features for HTTP::Tiny
+
+ =item *
+
+ L<HTTP::Thin> - HTTP::Tiny wrapper with L<HTTP::Request>/L<HTTP::Response> compatibility
+
+ =item *
+
+ L<HTTP::Tiny::Mech> - Wrap L<WWW::Mechanize> instance in HTTP::Tiny compatible interface
+
+ =item *
+
+ L<IO::Socket::IP> - Required for IPv6 support
+
+ =item *
+
+ L<IO::Socket::SSL> - Required for SSL support
+
+ =item *
+
+ L<LWP::UserAgent> - If HTTP::Tiny isn't enough for you, this is the "standard" way to do things
+
+ =item *
+
+ L<Mozilla::CA> - Required if you want to validate SSL certificates
+
+ =item *
+
+ L<Net::SSLeay> - 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<https://github.com/chansen/p5-http-tiny/issues>.
+ 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<https://github.com/chansen/p5-http-tiny>
+
+ git clone https://github.com/chansen/p5-http-tiny.git
+
+ =head1 AUTHORS
+
+ =over 4
+
+ =item *
+
+ Christian Hansen <chansen@cpan.org>
+
+ =item *
+
+ David Golden <dagolden@cpan.org>
+
+ =back
+
+ =head1 CONTRIBUTORS
+
+ =for stopwords Alan Gardner Alessandro Ghedini A. Sinan Unur Brad Gilbert brian m. carlson Chris Nehren Weyl Claes Jakobsson Clinton Gormley Craig Berry David Golden Mitchell Dean Pearce Edward Zborowski Felipe Gasper James Raspass Jeremy Mates Jess Robinson Karen Etheridge Lukas Eklund Martin J. Evans Martin-Louis Bright Mike Doherty Nicolas Rochelemagne Olaf Alders Olivier Mengué Petr Písař Serguei Trouchelle Shoichi Kaji SkyMarshal Sören Kornetzki Steve Grazzini Syohei YOSHIDA Tatsuhiko Miyagawa Tom Hukins Tony Cook
+
+ =over 4
+
+ =item *
+
+ Alan Gardner <gardner@pythian.com>
+
+ =item *
+
+ Alessandro Ghedini <al3xbio@gmail.com>
+
+ =item *
+
+ A. Sinan Unur <nanis@cpan.org>
+
+ =item *
+
+ Brad Gilbert <bgills@cpan.org>
+
+ =item *
+
+ brian m. carlson <sandals@crustytoothpaste.net>
+
+ =item *
+
+ Chris Nehren <apeiron@cpan.org>
+
+ =item *
+
+ Chris Weyl <cweyl@alumni.drew.edu>
+
+ =item *
+
+ Claes Jakobsson <claes@surfar.nu>
+
+ =item *
+
+ Clinton Gormley <clint@traveljury.com>
+
+ =item *
+
+ Craig A. Berry <craigberry@mac.com>
+
+ =item *
+
+ Craig Berry <cberry@cpan.org>
+
+ =item *
+
+ David Golden <xdg@xdg.me>
+
+ =item *
+
+ David Mitchell <davem@iabyn.com>
+
+ =item *
+
+ Dean Pearce <pearce@pythian.com>
+
+ =item *
+
+ Edward Zborowski <ed@rubensteintech.com>
+
+ =item *
+
+ Felipe Gasper <felipe@felipegasper.com>
+
+ =item *
+
+ James Raspass <jraspass@gmail.com>
+
+ =item *
+
+ Jeremy Mates <jmates@cpan.org>
+
+ =item *
+
+ Jess Robinson <castaway@desert-island.me.uk>
+
+ =item *
+
+ Karen Etheridge <ether@cpan.org>
+
+ =item *
+
+ Lukas Eklund <leklund@gmail.com>
+
+ =item *
+
+ Martin J. Evans <mjegh@ntlworld.com>
+
+ =item *
+
+ Martin-Louis Bright <mlbright@gmail.com>
+
+ =item *
+
+ Mike Doherty <doherty@cpan.org>
+
+ =item *
+
+ Nicolas Rochelemagne <rochelemagne@cpanel.net>
+
+ =item *
+
+ Olaf Alders <olaf@wundersolutions.com>
+
+ =item *
+
+ Olivier Mengué <dolmen@cpan.org>
+
+ =item *
+
+ Petr Písař <ppisar@redhat.com>
+
+ =item *
+
+ Serguei Trouchelle <stro@cpan.org>
+
+ =item *
+
+ Shoichi Kaji <skaji@cpan.org>
+
+ =item *
+
+ SkyMarshal <skymarshal1729@gmail.com>
+
+ =item *
+
+ Sören Kornetzki <soeren.kornetzki@delti.com>
+
+ =item *
+
+ Steve Grazzini <steve.grazzini@grantstreet.com>
+
+ =item *
+
+ Syohei YOSHIDA <syohex@gmail.com>
+
+ =item *
+
+ Tatsuhiko Miyagawa <miyagawa@bulknews.net>
+
+ =item *
+
+ Tom Hukins <tom@eborcom.com>
+
+ =item *
+
+ Tony Cook <tony@develop-help.com>
+
+ =back
+
+ =head1 COPYRIGHT AND LICENSE
+
+ This software is copyright (c) 2018 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{"HTTP/Tinyish.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_TINYISH';
+ package HTTP::Tinyish;
+ use strict;
+ use warnings;
+ use Carp ();
+
+ our $VERSION = '0.15';
+
+ our $PreferredBackend; # for tests
+ our @Backends = map "HTTP::Tinyish::$_", qw( LWP HTTPTiny Curl Wget );
+ my %configured;
+
+ sub new {
+ my($class, %attr) = @_;
+ bless \%attr, $class;
}
- sub is_xs { 1 };
- sub is_pp { 0 };
+ for my $method (qw/get head put post delete mirror/) {
+ no strict 'refs';
+ eval <<"HERE";
+ sub $method {
+ my \$self = shift;
+ \$self->_backend_for(\$_[0])->$method(\@_);
+ }
+ HERE
+ }
- sub support_by_pp {
- my ($class, @methods) = @_;
+ sub request {
+ my $self = shift;
+ $self->_backend_for($_[1])->request(@_);
+ }
- JSON::__load_pp('JSON::PP');
+ sub _backend_for {
+ my($self, $url) = @_;
- local $^W;
- no strict qw(refs);
+ my($scheme) = $url =~ m!^(https?):!;
+ Carp::croak "URL Scheme '$url' not supported." unless $scheme;
- for my $method (@methods) {
- my $pp_method = JSON::PP->can($method) or next;
- *{"JSON::$method"} = sub {
- if (!$_[0]->isa('JSON::PP')) {
- my $xs_self = $_[0];
- my $pp_self = JSON::PP->new;
- for (@Properties) {
- my $getter = "get_$_";
- $pp_self->$_($xs_self->$getter);
- }
- $_[0] = $pp_self;
- }
- $pp_method->(@_);
- };
+ for my $backend ($self->backends) {
+ $self->configure_backend($backend) or next;
+ if ($backend->supports($scheme)) {
+ return $backend->new(%$self);
+ }
+ }
+
+ Carp::croak "No backend configured for scheme $scheme";
+ }
+
+ sub backends {
+ $PreferredBackend ? ($PreferredBackend) : @Backends;
+ }
+
+ sub configure_backend {
+ my($self, $backend) = @_;
+ unless (exists $configured{$backend}) {
+ $configured{$backend} =
+ eval { require_module($backend); $backend->configure };
}
+ $configured{$backend};
+ }
- $JSON::DEBUG and Carp::carp("set -support_by_pp mode.");
+ sub require_module {
+ local $_ = shift;
+ s!::!/!g;
+ require "$_.pm";
}
1;
+
__END__
=head1 NAME
- JSON - JSON (JavaScript Object Notation) encoder/decoder
+ HTTP::Tinyish - HTTP::Tiny compatible HTTP client wrappers
=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
+ my $http = HTTP::Tinyish->new(agent => "Mozilla/4.0");
- =head1 VERSION
+ my $res = $http->get("http://www.cpan.org/");
+ warn $res->{status};
+
+ $http->post("http://example.com/post", {
+ headers => { "Content-Type" => "application/x-www-form-urlencoded" },
+ content => "foo=bar&baz=quux",
+ });
- 2.93
+ $http->mirror("http://www.cpan.org/modules/02packages.details.txt.gz", "./02packages.details.txt.gz");
=head1 DESCRIPTION
- This module is a thin wrapper for L<JSON::XS>-compatible modules with a few
- additional features. All the backend modules convert a Perl data structure
- to a JSON text as of RFC4627 (which we know is obsolete but we still stick
- to; see below for an option to support part of RFC7159) and vice versa.
- This module uses L<JSON::XS> by default, and when JSON::XS is not available,
- this module falls back on L<JSON::PP>, which is in the Perl core since 5.14.
- If JSON::PP is not available either, this module then falls back on
- JSON::backportPP (which is actually JSON::PP in a different .pm file)
- bundled in the same distribution as this module. You can also explicitly
- specify to use L<Cpanel::JSON::XS>, a fork of JSON::XS by Reini Urban.
+ HTTP::Tinyish is a wrapper module for HTTP client modules
+ L<LWP>, L<HTTP::Tiny> and HTTP client software C<curl> and C<wget>.
- All these backend modules have slight incompatibilities between them,
- including extra features that other modules don't support, but as long as you
- use only common features (most important ones are described below), migration
- from backend to backend should be reasonably easy. For details, see each
- backend module you use.
+ It provides an API compatible to HTTP::Tiny, and the implementation
+ has been extracted out of L<App::cpanminus>. This module can be useful
+ in a restrictive environment where you need to be able to download
+ CPAN modules without an HTTPS support in built-in HTTP library.
- =head1 CHOOSING BACKEND
+ =head1 BACKEND SELECTION
- This module respects an environmental variable called C<PERL_JSON_BACKEND>
- when it decides a backend module to use. If this environmental variable is
- not set, it tries to load JSON::XS, and if JSON::XS is not available, it
- falls back on JSON::PP, and then JSON::backportPP if JSON::PP is not available
- either.
+ Backends are searched in the order of: C<LWP>, L<HTTP::Tiny>, L<Curl>
+ and L<Wget>. HTTP::Tinyish will auto-detect if the backend also
+ supports HTTPS, and use the appropriate backend based on the given
+ URL to the request methods.
- If you always don't want it to fall back on pure perl modules, set the
- variable like this (C<export> may be C<setenv>, C<set> and the likes,
- depending on your environment):
+ For example, if you only have HTTP::Tiny but without SSL related
+ modules, it is possible that:
- > export PERL_JSON_BACKEND=JSON::XS
+ my $http = HTTP::Tinyish->new;
- If you prefer Cpanel::JSON::XS to JSON::XS, then:
+ $http->get("http://example.com"); # uses HTTP::Tiny
+ $http->get("https://example.com"); # uses curl
- > export PERL_JSON_BACKEND=Cpanel::JSON::XS,JSON::XS,JSON::PP
+ =head1 COMPATIBILITIES
- You may also want to set this variable at the top of your test files, in order
- not to be bothered with incompatibilities between backends (you need to wrap
- this in C<BEGIN>, and set before actually C<use>-ing JSON module, as it decides
- its backend as soon as it's loaded):
+ All request related methods such as C<get>, C<post>, C<put>,
+ C<delete>, C<request> and C<mirror> are supported.
- BEGIN { $ENV{PERL_JSON_BACKEND}='JSON::backportPP'; }
- use JSON;
+ =head2 LWP
- =head1 USING OPTIONAL FEATURES
+ =over 4
- There are a few options you can set when you C<use> this module:
+ =item *
+
+ L<LWP> backend requires L<LWP> 5.802 or over to be functional, and L<LWP::Protocol::https> to send HTTPS requests.
+
+ =item *
+
+ C<mirror> method doesn't consider third options hash into account (i.e. you can't override the HTTP headers).
+
+ =item *
+
+ proxy is automatically detected from environment variables.
+
+ =item *
+
+ C<timeout>, C<max_redirect>, C<agent>, C<default_headers> and C<verify_SSL> are translated.
+
+ =back
+
+ =head2 HTTP::Tiny
+
+ Because the actual HTTP::Tiny backend is used, all APIs are supported.
+
+ =head2 Curl
=over
- =item -support_by_pp
+ =item *
- BEGIN { $ENV{PERL_JSON_BACKEND} = 'JSON::XS' }
-
- use JSON -support_by_pp;
-
- my $json = JSON->new;
- # escape_slash is for JSON::PP only.
- $json->allow_nonref->escape_slash->encode("/");
-
- With this option, this module loads its pure perl backend along with
- its XS backend (if available), and lets the XS backend to watch if you set
- a flag only JSON::PP supports. When you do, the internal JSON::XS object
- is replaced with a newly created JSON::PP object with the setting copied
- from the XS object, so that you can use JSON::PP flags (and its slower
- C<decode>/C<encode> methods) from then on. In other words, this is not
- something that allows you to hook JSON::XS to change its behavior while
- keeping its speed. JSON::XS and JSON::PP objects are quite different
- (JSON::XS object is a blessed scalar reference, while JSON::PP object is
- a blessed hash reference), and can't share their internals.
-
- To avoid needless overhead (by copying settings), you are advised not
- to use this option and just to use JSON::PP explicitly when you need
- JSON::PP features.
-
- =item -convert_blessed_universally
-
- use JSON -convert_blessed_universally;
-
- my $json = JSON->new->allow_nonref->convert_blessed;
- my $object = bless {foo => 'bar'}, 'Foo';
- $json->encode($object); # => {"foo":"bar"}
-
- JSON::XS-compatible backend modules don't encode blessed objects by
- default (except for their boolean values, which are typically blessed
- JSON::PP::Boolean objects). If you need to encode a data structure
- that may contain objects, you usually need to look into the structure
- and replace objects with alternative non-blessed values, or enable
- C<convert_blessed> and provide a C<TO_JSON> method for each object's
- (base) class that may be found in the structure, in order to let the
- methods replace the objects with whatever scalar values the methods
- return.
+ This module has been tested with curl 7.22 and later.
- If you need to serialise data structures that may contain arbitrary
- objects, it's probably better to use other serialisers (such as
- L<Sereal> or L<Storable> for example), but if you do want to use
- this module for that purpose, C<-convert_blessed_universally> option
- may help, which tweaks C<encode> method of the backend to install
- C<UNIVERSAL::TO_JSON> method (locally) before encoding, so that
- all the objects that don't have their own C<TO_JSON> method can
- fall back on the method in the C<UNIVERSAL> namespace. Note that you
- still need to enable C<convert_blessed> flag to actually encode
- objects in a data structure, and C<UNIVERSAL::TO_JSON> method
- installed by this option only converts blessed hash/array references
- into their unblessed clone (including private keys/values that are
- not supposed to be exposed). Other blessed references will be
- converted into null.
+ =item *
- This feature is experimental and may be removed in the future.
+ HTTPS support is automatically detected by running C<curl --version> and see its protocol output.
- =item -no_export
+ =item *
- When you don't want to import functional interfaces from a module, you
- usually supply C<()> to its C<use> statement.
+ C<timeout>, C<max_redirect>, C<agent>, C<default_headers> and C<verify_SSL> are supported.
- use JSON (); # no functional interfaces
+ =back
- If you don't want to import functional interfaces, but you also want to
- use any of the above options, add C<-no_export> to the option list.
+ =head2 Wget
- # no functional interfaces, while JSON::PP support is enabled.
- use JSON -support_by_pp, -no_export;
+ =over 4
+
+ =item *
+
+ This module requires Wget 1.12 and later.
+
+ =item *
+
+ Wget prior to 1.15 doesn't support sending custom HTTP methods, so if you use C<< $http->put >> for example, you'll get an internal error response (599).
+
+ =item *
+
+ HTTPS support is automatically detected.
+
+ =item *
+
+ C<mirror()> method doesn't send C<If-Modified-Since> header to the server, which will result in full-download every time because C<wget> doesn't support C<--timestamping> combined with C<-O> option.
+
+ =item *
+
+ C<timeout>, C<max_redirect>, C<agent>, C<default_headers> and C<verify_SSL> are supported.
=back
- =head1 FUNCTIONAL INTERFACE
+ =head1 SIMILAR MODULES
- This section is taken from JSON::XS. C<encode_json> and C<decode_json>
- are exported by default.
+ =over 4
- This module also exports C<to_json> and C<from_json> for backward
- compatibility. These are slower, and may expect/generate different stuff
- from what C<encode_json> and C<decode_json> do, depending on their
- options. It's better just to use Object-Oriented interfaces than using
- these two functions.
+ =item *
- =head2 encode_json
+ L<File::Fetch> - is core since 5.10. Has support for non-HTTP protocols such as ftp and git. Does not support HTTPS or basic authentication as of this writing.
- $json_text = encode_json $perl_scalar
+ =item *
- Converts the given Perl data structure to a UTF-8 encoded, binary string
- (that is, the string contains octets only). Croaks on error.
+ L<Plient> - provides more complete runtime API, but seems only compatible on Unix environments. Does not support mirror() method.
- This function call is functionally identical to:
+ =back
- $json_text = JSON->new->utf8->encode($perl_scalar)
+ =head1 AUTHOR
- Except being faster.
+ Tatsuhiko Miyagawa
- =head2 decode_json
+ =head1 COPYRIGHT
- $perl_scalar = decode_json $json_text
+ Tatsuhiko Miyagawa, 2015-
- The opposite of C<encode_json>: expects an UTF-8 (binary) string and tries
- to parse that as an UTF-8 encoded JSON text, returning the resulting
- reference. Croaks on error.
+ =head1 LICENSE
- This function call is functionally identical to:
+ This module is licensed under the same terms as Perl itself.
- $perl_scalar = JSON->new->utf8->decode($json_text)
+ =cut
- Except being faster.
+HTTP_TINYISH
+
+$fatpacked{"HTTP/Tinyish/Base.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_TINYISH_BASE';
+ package HTTP::Tinyish::Base;
+ use strict;
+ use warnings;
- =head2 to_json
+ for my $sub_name ( qw/get head put post delete/ ) {
+ my $req_method = uc $sub_name;
+ eval <<"HERE";
+ 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 || {});
+ }
- $json_text = to_json($perl_scalar[, $optional_hashref])
+ HERE
+ }
- Converts the given Perl data structure to a Unicode string by default.
- Croaks on error.
+ sub parse_http_header {
+ my($self, $header, $res) = @_;
- Basically, this function call is functionally identical to:
+ # it might have multiple headers in it because of redirects
+ $header =~ s/.*^(HTTP\/\d(?:\.\d)?)/$1/ms;
- $json_text = JSON->new->encode($perl_scalar)
+ # grab the first chunk until the line break
+ if ($header =~ /^(.*?\x0d?\x0a\x0d?\x0a)/) {
+ $header = $1;
+ }
- Except being slower.
+ # parse into lines
+ my @header = split /\x0d?\x0a/,$header;
+ my $status_line = shift @header;
- You can pass an optional hash reference to modify its behavior, but
- that may change what C<to_json> expects/generates (see
- C<ENCODING/CODESET FLAG NOTES> for details).
+ # join folded lines
+ my @out;
+ for (@header) {
+ if(/^[ \t]+/) {
+ return -1 unless @out;
+ $out[-1] .= $_;
+ } else {
+ push @out, $_;
+ }
+ }
- $json_text = to_json($perl_scalar, {utf8 => 1, pretty => 1})
- # => JSON->new->utf8(1)->pretty(1)->encode($perl_scalar)
+ my($proto, $status, $reason) = split / /, $status_line, 3;
+ return unless $proto and $proto =~ /^HTTP\/(\d+)(\.(\d+))?$/i;
- =head2 from_json
+ $res->{status} = $status;
+ $res->{reason} = $reason;
+ $res->{success} = $status =~ /^(?:2|304)/;
+ $res->{protocol} = $proto;
- $perl_scalar = from_json($json_text[, $optional_hashref])
+ # import headers
+ my $token = qr/[^][\x00-\x1f\x7f()<>@,;:\\"\/?={} \t]+/;
+ my $k;
+ for my $header (@out) {
+ if ( $header =~ s/^($token): ?// ) {
+ $k = lc $1;
+ } elsif ( $header =~ /^\s+/) {
+ # multiline header
+ } else {
+ return -1;
+ }
- The opposite of C<to_json>: expects a Unicode string and tries
- to parse it, returning the resulting reference. Croaks on error.
+ if (exists $res->{headers}{$k}) {
+ $res->{headers}{$k} = [$res->{headers}{$k}]
+ unless ref $res->{headers}{$k};
+ push @{$res->{headers}{$k}}, $header;
+ } else {
+ $res->{headers}{$k} = $header;
+ }
+ }
+ }
- Basically, this function call is functionally identical to:
+ sub internal_error {
+ my($self, $url, $message) = @_;
- $perl_scalar = JSON->new->decode($json_text)
+ return {
+ content => $message,
+ headers => { "content-length" => length($message), "content-type" => "text/plain" },
+ reason => "Internal Exception",
+ status => 599,
+ success => "",
+ url => $url,
+ };
+ }
- You can pass an optional hash reference to modify its behavior, but
- that may change what C<from_json> expects/generates (see
- C<ENCODING/CODESET FLAG NOTES> for details).
+ 1;
+HTTP_TINYISH_BASE
+
+$fatpacked{"HTTP/Tinyish/Curl.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_TINYISH_CURL';
+ package HTTP::Tinyish::Curl;
+ use strict;
+ use warnings;
+ use parent qw(HTTP::Tinyish::Base);
- $perl_scalar = from_json($json_text, {utf8 => 1})
- # => JSON->new->utf8(1)->decode($json_text)
+ use IPC::Run3 qw(run3);
+ use File::Which qw(which);
+ use File::Temp ();
- =head2 JSON::is_bool
+ my %supports;
+ my $curl;
- $is_boolean = JSON::is_bool($scalar)
+ sub _slurp {
+ open my $fh, "<", shift or die $!;
+ local $/;
+ <$fh>;
+ }
- 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<true> and C<false> in Perl strings.
+ sub configure {
+ my $class = shift;
- See L<MAPPING>, below, for more information on how JSON values are mapped to
- Perl.
+ my %meta;
+ $curl = which('curl');
- =head1 COMMON OBJECT-ORIENTED INTERFACE
+ eval {
+ run3([$curl, '--version'], \undef, \my $version, \my $error);
+ if ($version =~ /^Protocols: (.*)/m) {
+ my %protocols = map { $_ => 1 } split /\s/, $1;
+ $supports{http} = 1 if $protocols{http};
+ $supports{https} = 1 if $protocols{https};
+ }
- This section is also taken from JSON::XS.
+ $meta{$curl} = $version;
+ };
- The object oriented interface lets you configure your own encoding or
- decoding style, within the limits of supported formats.
+ \%meta;
+ }
- =head2 new
+ sub supports { $supports{$_[1]} }
- $json = JSON->new
+ sub new {
+ my($class, %attr) = @_;
+ bless \%attr, $class;
+ }
- Creates a new JSON::XS-compatible backend object that can be used to de/encode JSON
- strings. All boolean flags described below are by default I<disabled>.
+ sub request {
+ my($self, $method, $url, $opts) = @_;
+ $opts ||= {};
- The mutators for flags all return the backend object again and thus calls can
- be chained:
+ my(undef, $temp) = File::Temp::tempfile(UNLINK => 1);
- my $json = JSON->new->utf8->space_after->encode({a => [1,2]})
- => {"a": [1, 2]}
+ my($output, $error);
+ eval {
+ run3 [
+ $curl,
+ '-X', $method,
+ ($method eq 'HEAD' ? ('--head') : ()),
+ $self->build_options($url, $opts),
+ '--dump-header', $temp,
+ $url,
+ ], \undef, \$output, \$error;
+ };
- =head2 ascii
+ if ($@ or $?) {
+ return $self->internal_error($url, $@ || $error);
+ }
- $json = $json->ascii([$enable])
-
- $enabled = $json->get_ascii
+ my $res = { url => $url, content => $output };
+ $self->parse_http_header( _slurp($temp), $res );
+ $res;
+ }
- If C<$enable> is true (or missing), then the C<encode> method will not
- generate characters outside the code range C<0..127> (which is ASCII). Any
- Unicode characters outside that range will be escaped using either a
- single \uXXXX (BMP characters) or a double \uHHHH\uLLLLL escape sequence,
- as per RFC4627. The resulting encoded JSON text can be treated as a native
- Unicode string, an ascii-encoded, latin1-encoded or UTF-8 encoded string,
- or any other superset of ASCII.
+ sub mirror {
+ my($self, $url, $file, $opts) = @_;
+ $opts ||= {};
- If C<$enable> is false, then the C<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.
+ my(undef, $temp) = File::Temp::tempfile(UNLINK => 1);
- See also the section I<ENCODING/CODESET FLAG NOTES> later in this document.
+ my($output, $error);
+ eval {
+ run3 [
+ $curl,
+ $self->build_options($url, $opts),
+ '-z', $file,
+ '-o', $file,
+ '--dump-header', $temp,
+ '--remote-time',
+ $url,
+ ], \undef, \$output, \$error;
+ };
- The main use for this flag is to produce JSON texts that can be
- transmitted over a 7-bit channel, as the encoded JSON texts will not
- contain any 8 bit characters.
+ if ($@ or $?) {
+ return $self->internal_error($url, $@ || $error);
+ }
- JSON->new->ascii(1)->encode([chr 0x10401])
- => ["\ud801\udc01"]
+ my $res = { url => $url, content => $output };
+ $self->parse_http_header( _slurp($temp), $res );
+ $res;
+ }
- =head2 latin1
+ sub build_options {
+ my($self, $url, $opts) = @_;
- $json = $json->latin1([$enable])
-
- $enabled = $json->get_latin1
+ my @options = (
+ '--location',
+ '--silent',
+ '--max-time', ($self->{timeout} || 60),
+ '--max-redirs', ($self->{max_redirect} || 5),
+ '--user-agent', ($self->{agent} || "HTTP-Tinyish/$HTTP::Tinyish::VERSION"),
+ );
- If C<$enable> is true (or missing), then the C<encode> method will encode
- the resulting JSON text as latin1 (or iso-8859-1), escaping any characters
- outside the code range C<0..255>. The resulting string can be treated as a
- latin1-encoded JSON text or a native Unicode string. The C<decode> method
- will not be affected in any way by this flag, as C<decode> by default
- expects Unicode, which is a strict superset of latin1.
+ my %headers;
+ if ($self->{default_headers}) {
+ %headers = %{$self->{default_headers}};
+ }
+ if ($opts->{headers}) {
+ %headers = (%headers, %{$opts->{headers}});
+ }
+ $self->_translate_headers(\%headers, \@options);
- If C<$enable> is false, then the C<encode> method will not escape Unicode
- characters unless required by the JSON syntax or other flags.
+ unless ($self->{verify_SSL}) {
+ push @options, '--insecure';
+ }
- See also the section I<ENCODING/CODESET FLAG NOTES> later in this document.
+ if ($opts->{content}) {
+ my $content;
+ if (ref $opts->{content} eq 'CODE') {
+ while (my $chunk = $opts->{content}->()) {
+ $content .= $chunk;
+ }
+ } else {
+ $content = $opts->{content};
+ }
+ push @options, '--data', $content;
+ }
- The main use for this flag is efficiently encoding binary data as JSON
- text, as most octets will not be escaped, resulting in a smaller encoded
- size. The disadvantage is that the resulting JSON text is encoded
- in latin1 (and must correctly be treated as such when storing and
- transferring), a rare encoding for JSON. It is therefore most useful when
- you want to store data structures known to contain binary data efficiently
- in files or databases, not when talking to other JSON encoders/decoders.
+ @options;
+ }
- JSON->new->latin1->encode (["\x{89}\x{abc}"]
- => ["\x{89}\\u0abc"] # (perl syntax, U+abc escaped, U+89 not)
+ sub _translate_headers {
+ my($self, $headers, $options) = @_;
- =head2 utf8
+ for my $field (keys %$headers) {
+ my $value = $headers->{$field};
+ if (ref $value eq 'ARRAY') {
+ push @$options, map { ('-H', "$field:$_") } @$value;
+ } else {
+ push @$options, '-H', "$field:$value";
+ }
+ }
+ }
- $json = $json->utf8([$enable])
-
- $enabled = $json->get_utf8
+ 1;
+HTTP_TINYISH_CURL
+
+$fatpacked{"HTTP/Tinyish/HTTPTiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_TINYISH_HTTPTINY';
+ package HTTP::Tinyish::HTTPTiny;
+ use strict;
+ use parent qw(HTTP::Tinyish::Base);
+ use HTTP::Tiny;
- If C<$enable> is true (or missing), then the C<encode> method will encode
- the JSON result into UTF-8, as required by many protocols, while the
- C<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 C<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.
+ my %supports = (http => 1);
- If C<$enable> is false, then the C<encode> method will return the JSON
- string as a (non-encoded) Unicode string, while C<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.
+ sub configure {
+ my %meta = ("HTTP::Tiny" => $HTTP::Tiny::VERSION);
- See also the section I<ENCODING/CODESET FLAG NOTES> later in this document.
+ $supports{https} = HTTP::Tiny->can_ssl;
- Example, output UTF-16BE-encoded JSON:
+ \%meta;
+ }
- use Encode;
- $jsontext = encode "UTF-16BE", JSON->new->encode ($object);
+ sub supports { $supports{$_[1]} }
- Example, decode UTF-32LE-encoded JSON:
+ sub new {
+ my($class, %attrs) = @_;
+ bless {
+ tiny => HTTP::Tiny->new(%attrs),
+ }, $class;
+ }
- use Encode;
- $object = JSON->new->decode (decode "UTF-32LE", $jsontext);
+ sub request {
+ my $self = shift;
+ $self->{tiny}->request(@_);
+ }
- =head2 pretty
+ sub mirror {
+ my $self = shift;
+ $self->{tiny}->mirror(@_);
+ }
- $json = $json->pretty([$enable])
+ 1;
- This enables (or disables) all of the C<indent>, C<space_before> and
- C<space_after> (and in the future possibly more) flags in one call to
- generate the most readable (or most compact) form possible.
+HTTP_TINYISH_HTTPTINY
+
+$fatpacked{"HTTP/Tinyish/LWP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_TINYISH_LWP';
+ package HTTP::Tinyish::LWP;
+ use strict;
+ use parent qw(HTTP::Tinyish::Base);
- =head2 indent
+ use LWP 5.802;
+ use LWP::UserAgent;
- $json = $json->indent([$enable])
-
- $enabled = $json->get_indent
+ my %supports = (http => 1);
- If C<$enable> is true (or missing), then the C<encode> method will use a multiline
- format as output, putting every array member or object/hash key-value pair
- into its own line, indenting them properly.
+ sub configure {
+ my %meta = (
+ LWP => $LWP::VERSION,
+ );
- If C<$enable> is false, no newlines or indenting will be produced, and the
- resulting JSON text is guaranteed not to contain any C<newlines>.
+ if (eval { require LWP::Protocol::https; require Mozilla::CA; 1 }) {
+ $supports{https} = 1;
+ $meta{"LWP::Protocol::https"} = $LWP::Protocol::https::VERSION;
+ }
- This setting has no effect when decoding JSON texts.
+ \%meta;
+ }
- =head2 space_before
+ sub supports {
+ $supports{$_[1]};
+ }
- $json = $json->space_before([$enable])
+ sub new {
+ my($class, %attr) = @_;
+
+ my $ua = LWP::UserAgent->new;
- $enabled = $json->get_space_before
+ bless {
+ ua => $class->translate_lwp($ua, %attr),
+ }, $class;
+ }
- If C<$enable> is true (or missing), then the C<encode> method will add an extra
- optional space before the C<:> separating keys from values in JSON objects.
+ sub _headers_to_hashref {
+ my($self, $hdrs) = @_;
- If C<$enable> is false, then the C<encode> method will not add any extra
- space at those places.
+ my %headers;
+ for my $field ($hdrs->header_field_names) {
+ $headers{lc $field} = $hdrs->header($field); # could be an array ref
+ }
- This setting has no effect when decoding JSON texts. You will also
- most likely combine this setting with C<space_after>.
+ \%headers;
+ }
- Example, space_before enabled, space_after and indent disabled:
+ sub request {
+ my($self, $method, $url, $opts) = @_;
+ $opts ||= {};
- {"key" :"value"}
+ my $req = HTTP::Request->new($method => $url);
- =head2 space_after
+ if ($opts->{headers}) {
+ $req->header(%{$opts->{headers}});
+ }
- $json = $json->space_after([$enable])
-
- $enabled = $json->get_space_after
+ if ($opts->{content}) {
+ $req->content($opts->{content});
+ }
- If C<$enable> is true (or missing), then the C<encode> 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.
+ my $res = $self->{ua}->request($req);
- If C<$enable> is false, then the C<encode> method will not add any extra
- space at those places.
+ if ($self->is_internal_response($res)) {
+ return $self->internal_error($url, $res->content);
+ }
- This setting has no effect when decoding JSON texts.
+ return {
+ url => $url,
+ content => $res->decoded_content(charset => 'none'),
+ success => $res->is_success,
+ status => $res->code,
+ reason => $res->message,
+ headers => $self->_headers_to_hashref($res->headers),
+ protocol => $res->protocol,
+ };
+ }
- Example, space_before and indent disabled, space_after enabled:
+ sub mirror {
+ my($self, $url, $file) = @_;
- {"key": "value"}
+ # TODO support optional headers
+ my $res = $self->{ua}->mirror($url, $file);
- =head2 relaxed
+ if ($self->is_internal_response($res)) {
+ return $self->internal_error($url, $res->content);
+ }
- $json = $json->relaxed([$enable])
-
- $enabled = $json->get_relaxed
+ return {
+ url => $url,
+ content => $res->decoded_content,
+ success => $res->is_success || $res->code == 304,
+ status => $res->code,
+ reason => $res->message,
+ headers => $self->_headers_to_hashref($res->headers),
+ protocol => $res->protocol,
+ };
+ }
- If C<$enable> is true (or missing), then C<decode> will accept some
- extensions to normal JSON syntax (see below). C<encode> will not be
- affected in anyway. I<Be aware that this option makes you accept invalid
- JSON texts as if they were valid!>. I suggest only to use this option to
- parse application-specific files written by humans (configuration files,
- resource files etc.)
+ sub translate_lwp {
+ my($class, $agent, %attr) = @_;
- If C<$enable> is false (the default), then C<decode> will only accept
- valid JSON texts.
+ $agent->parse_head(0);
+ $agent->env_proxy;
+ $agent->timeout(delete $attr{timeout} || 60);
+ $agent->max_redirect(delete $attr{max_redirect} || 5);
+ $agent->agent(delete $attr{agent} || "HTTP-Tinyish/$HTTP::Tinyish::VERSION");
- Currently accepted extensions are:
+ # LWP default is to verify, HTTP::Tiny isn't
+ unless ($attr{verify_SSL}) {
+ if ($agent->can("ssl_opts")) {
+ $agent->ssl_opts(verify_hostname => 0);
+ }
+ }
- =over 4
+ if ($attr{default_headers}) {
+ $agent->default_headers( HTTP::Headers->new(%{$attr{default_headers}}) );
+ }
- =item * list items can have an end-comma
+ $agent;
+ }
- JSON I<separates> 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:
+ sub is_internal_response {
+ my($self, $res) = @_;
- [
- 1,
- 2, <- this comma not normally allowed
- ]
+ $res->code == 500 &&
+ ( $res->header('Client-Warning') || '' ) eq 'Internal response';
+ }
+
+ 1;
+HTTP_TINYISH_LWP
+
+$fatpacked{"HTTP/Tinyish/Wget.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_TINYISH_WGET';
+ package HTTP::Tinyish::Wget;
+ use strict;
+ use warnings;
+ use parent qw(HTTP::Tinyish::Base);
+
+ use IPC::Run3 qw(run3);
+ use File::Which qw(which);
+
+ my %supports;
+ my $wget;
+ my $method_supported;
+
+ sub _run_wget {
+ run3([$wget, @_], \undef, \my $out, \my $err);
+ wantarray ? ($out, $err) : $out;
+ }
+
+ sub configure {
+ my $class = shift;
+ my %meta;
+
+ $wget = which('wget');
+
+ eval {
+ local $ENV{LC_ALL} = 'en_US';
+
+ $meta{$wget} = _run_wget('--version');
+ unless ($meta{$wget} =~ /GNU Wget 1\.(\d+)/ and $1 >= 12) {
+ die "Wget version is too old. $meta{$wget}";
+ }
+
+ my $config = $class->new(agent => __PACKAGE__);
+ my @options = grep { $_ ne '--quiet' } $config->build_options("GET");
+
+ my(undef, $err) = _run_wget(@options, 'https://');
+ if ($err && $err =~ /HTTPS support not compiled/) {
+ $supports{http} = 1;
+ } elsif ($err && $err =~ /Invalid host/) {
+ $supports{http} = $supports{https} = 1;
+ }
+
+ (undef, $err) = _run_wget('--method', 'GET', 'http://');
+ if ($err && $err =~ /Invalid host/) {
+ $method_supported = $meta{method_supported} = 1;
+ }
+
+ };
+
+ \%meta;
+ }
+
+ sub supports { $supports{$_[1]} }
+
+ sub new {
+ my($class, %attr) = @_;
+ bless \%attr, $class;
+ }
+
+ sub request {
+ my($self, $method, $url, $opts) = @_;
+ $opts ||= {};
+
+ my($stdout, $stderr);
+ eval {
+ run3 [
+ $wget,
+ $self->build_options($method, $url, $opts),
+ $url,
+ '-O', '-',
+ ], \undef, \$stdout, \$stderr;
+ };
+
+ # wget exit codes: (man wget)
+ # 4 Network failure.
+ # 5 SSL verification failure.
+ # 6 Username/password authentication failure.
+ # 7 Protocol errors.
+ # 8 Server issued an error response.
+ if ($@ or $? && ($? >> 8) <= 5) {
+ return $self->internal_error($url, $@ || $stderr);
+ }
+
+ my $header = '';
+ $stderr =~ s{^ (\S.*)$}{ $header .= $1."\n" }gem;
+
+ my $res = { url => $url, content => $stdout };
+ $self->parse_http_header($header, $res);
+ $res;
+ }
+
+ sub mirror {
+ my($self, $url, $file, $opts) = @_;
+ $opts ||= {};
+
+ # This doesn't send If-Modified-Since because -O and -N are mutually exclusive :(
+ my($stdout, $stderr);
+ eval {
+ run3 [$wget, $self->build_options("GET", $url, $opts), $url, '-O', $file], \undef, \$stdout, \$stderr;
+ };
+
+ if ($@ or $?) {
+ return $self->internal_error($url, $@ || $stderr);
+ }
+
+ $stderr =~ s/^ //gm;
+
+ my $res = { url => $url, content => $stdout };
+ $self->parse_http_header($stderr, $res);
+ $res;
+ }
+
+ sub build_options {
+ my($self, $method, $url, $opts) = @_;
+
+ my @options = (
+ '--retry-connrefused',
+ '--server-response',
+ '--timeout', ($self->{timeout} || 60),
+ '--tries', 1,
+ '--max-redirect', ($self->{max_redirect} || 5),
+ '--user-agent', ($self->{agent} || "HTTP-Tinyish/$HTTP::Tinyish::VERSION"),
+ );
+
+ if ($method_supported) {
+ push @options, "--method", $method;
+ } else {
+ if ($method eq 'GET' or $method eq 'POST') {
+ # OK
+ } elsif ($method eq 'HEAD') {
+ push @options, '--spider';
+ } else {
+ die "This version of wget doesn't support specifying HTTP method '$method'";
+ }
+ }
+
+ if ($self->{agent}) {
+ push @options, '--user-agent', $self->{agent};
+ }
+
+ my %headers;
+ if ($self->{default_headers}) {
+ %headers = %{$self->{default_headers}};
+ }
+ if ($opts->{headers}) {
+ %headers = (%headers, %{$opts->{headers}});
+ }
+ $self->_translate_headers(\%headers, \@options);
+
+ if ($supports{https} && !$self->{verify_SSL}) {
+ push @options, '--no-check-certificate';
+ }
+
+ if ($opts->{content}) {
+ my $content;
+ if (ref $opts->{content} eq 'CODE') {
+ while (my $chunk = $opts->{content}->()) {
+ $content .= $chunk;
+ }
+ } else {
+ $content = $opts->{content};
+ }
+
+ if ($method_supported) {
+ push @options, '--body-data', $content;
+ } else {
+ push @options, '--post-data', $content;
+ }
+ }
+
+ @options;
+ }
+
+ sub _translate_headers {
+ my($self, $headers, $options) = @_;
+
+ for my $field (keys %$headers) {
+ my $value = $headers->{$field};
+ if (ref $value eq 'ARRAY') {
+ # wget doesn't honor multiple header fields
+ push @$options, '--header', "$field:" . join(",", @$value);
+ } else {
+ push @$options, '--header', "$field:$value";
+ }
+ }
+ }
+
+ 1;
+HTTP_TINYISH_WGET
+
+$fatpacked{"IO/Socket/IP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'IO_SOCKET_IP';
+ # You may distribute under the terms of either the GNU General Public License
+ # or the Artistic License (the same terms as Perl itself)
+ #
+ # (C) Paul Evans, 2010-2015 -- leonerd@leonerd.org.uk
+
+ package IO::Socket::IP;
+ # $VERSION needs to be set before use base 'IO::Socket'
+ # - https://rt.cpan.org/Ticket/Display.html?id=92107
+ BEGIN {
+ $VERSION = '0.39';
+ }
+
+ use strict;
+ use warnings;
+ use base qw( IO::Socket );
+
+ use Carp;
+
+ use Socket 1.97 qw(
+ getaddrinfo getnameinfo
+ sockaddr_family
+ AF_INET
+ AI_PASSIVE
+ IPPROTO_TCP IPPROTO_UDP
+ IPPROTO_IPV6 IPV6_V6ONLY
+ NI_DGRAM NI_NUMERICHOST NI_NUMERICSERV NIx_NOHOST NIx_NOSERV
+ SO_REUSEADDR SO_REUSEPORT SO_BROADCAST SO_ERROR
+ SOCK_DGRAM SOCK_STREAM
+ SOL_SOCKET
+ );
+ my $AF_INET6 = eval { Socket::AF_INET6() }; # may not be defined
+ my $AI_ADDRCONFIG = eval { Socket::AI_ADDRCONFIG() } || 0;
+ use POSIX qw( dup2 );
+ use Errno qw( EINVAL EINPROGRESS EISCONN ENOTCONN ETIMEDOUT EWOULDBLOCK EOPNOTSUPP );
+
+ use constant HAVE_MSWIN32 => ( $^O eq "MSWin32" );
+
+ # At least one OS (Android) is known not to have getprotobyname()
+ use constant HAVE_GETPROTOBYNAME => defined eval { getprotobyname( "tcp" ) };
+
+ my $IPv6_re = do {
+ # translation of RFC 3986 3.2.2 ABNF to re
+ my $IPv4address = do {
+ my $dec_octet = q<(?:[0-9]|[1-9][0-9]|1[0-9][0-9]|2[0-4][0-9]|25[0-5])>;
+ qq<$dec_octet(?: \\. $dec_octet){3}>;
+ };
+ my $IPv6address = do {
+ my $h16 = qq<[0-9A-Fa-f]{1,4}>;
+ my $ls32 = qq<(?: $h16 : $h16 | $IPv4address)>;
+ qq<(?:
+ (?: $h16 : ){6} $ls32
+ | :: (?: $h16 : ){5} $ls32
+ | (?: $h16 )? :: (?: $h16 : ){4} $ls32
+ | (?: (?: $h16 : ){0,1} $h16 )? :: (?: $h16 : ){3} $ls32
+ | (?: (?: $h16 : ){0,2} $h16 )? :: (?: $h16 : ){2} $ls32
+ | (?: (?: $h16 : ){0,3} $h16 )? :: $h16 : $ls32
+ | (?: (?: $h16 : ){0,4} $h16 )? :: $ls32
+ | (?: (?: $h16 : ){0,5} $h16 )? :: $h16
+ | (?: (?: $h16 : ){0,6} $h16 )? ::
+ )>
+ };
+ qr<$IPv6address>xo;
+ };
+
+ =head1 NAME
+
+ C<IO::Socket::IP> - Family-neutral IP socket supporting both IPv4 and IPv6
+
+ =head1 SYNOPSIS
+
+ use IO::Socket::IP;
+
+ my $sock = IO::Socket::IP->new(
+ PeerHost => "www.google.com",
+ PeerPort => "http",
+ Type => SOCK_STREAM,
+ ) or die "Cannot construct socket - $@";
+
+ my $familyname = ( $sock->sockdomain == PF_INET6 ) ? "IPv6" :
+ ( $sock->sockdomain == PF_INET ) ? "IPv4" :
+ "unknown";
+
+ printf "Connected to google via %s\n", $familyname;
+
+ =head1 DESCRIPTION
+
+ This module provides a protocol-independent way to use IPv4 and IPv6 sockets,
+ intended as a replacement for L<IO::Socket::INET>. Most constructor arguments
+ and methods are provided in a backward-compatible way. For a list of known
+ differences, see the C<IO::Socket::INET> INCOMPATIBILITES section below.
+
+ It uses the C<getaddrinfo(3)> function to convert hostnames and service names
+ or port numbers into sets of possible addresses to connect to or listen on.
+ This allows it to work for IPv6 where the system supports it, while still
+ falling back to IPv4-only on systems which don't.
+
+ =head1 REPLACING C<IO::Socket> DEFAULT BEHAVIOUR
+
+ By placing C<-register> in the import list, L<IO::Socket> uses
+ C<IO::Socket::IP> rather than C<IO::Socket::INET> as the class that handles
+ C<PF_INET>. C<IO::Socket> will also use C<IO::Socket::IP> rather than
+ C<IO::Socket::INET6> to handle C<PF_INET6>, provided that the C<AF_INET6>
+ constant is available.
+
+ Changing C<IO::Socket>'s default behaviour means that calling the
+ C<IO::Socket> constructor with either C<PF_INET> or C<PF_INET6> as the
+ C<Domain> parameter will yield an C<IO::Socket::IP> object.
+
+ use IO::Socket::IP -register;
+
+ my $sock = IO::Socket->new(
+ Domain => PF_INET6,
+ LocalHost => "::1",
+ Listen => 1,
+ ) or die "Cannot create socket - $@\n";
+
+ print "Created a socket of type " . ref($sock) . "\n";
+
+ Note that C<-register> is a global setting that applies to the entire program;
+ it cannot be applied only for certain callers, removed, or limited by lexical
+ scope.
+
+ =cut
+
+ sub import
+ {
+ my $pkg = shift;
+ my @symbols;
+
+ foreach ( @_ ) {
+ if( $_ eq "-register" ) {
+ IO::Socket::IP::_ForINET->register_domain( AF_INET );
+ IO::Socket::IP::_ForINET6->register_domain( $AF_INET6 ) if defined $AF_INET6;
+ }
+ else {
+ push @symbols, $_;
+ }
+ }
+
+ @_ = ( $pkg, @symbols );
+ goto &IO::Socket::import;
+ }
+
+ # Convenient capability test function
+ {
+ my $can_disable_v6only;
+ sub CAN_DISABLE_V6ONLY
{
- "k1": "v1",
- "k2": "v2", <- this comma not normally allowed
+ return $can_disable_v6only if defined $can_disable_v6only;
+
+ socket my $testsock, Socket::PF_INET6(), SOCK_STREAM, 0 or
+ die "Cannot socket(PF_INET6) - $!";
+
+ if( setsockopt $testsock, IPPROTO_IPV6, IPV6_V6ONLY, 0 ) {
+ return $can_disable_v6only = 1;
+ }
+ elsif( $! == EINVAL || $! == EOPNOTSUPP ) {
+ return $can_disable_v6only = 0;
+ }
+ else {
+ die "Cannot setsockopt() - $!";
+ }
}
+ }
- =item * shell-style '#'-comments
+ =head1 CONSTRUCTORS
- 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.
+ =cut
- [
- 1, # this comment not allowed in JSON
- # neither this one...
- ]
+ =head2 $sock = IO::Socket::IP->new( %args )
- =back
+ Creates a new C<IO::Socket::IP> object, containing a newly created socket
+ handle according to the named arguments passed. The recognised arguments are:
- =head2 canonical
+ =over 8
- $json = $json->canonical([$enable])
-
- $enabled = $json->get_canonical
+ =item PeerHost => STRING
- If C<$enable> is true (or missing), then the C<encode> method will output JSON objects
- by sorting their keys. This is adding a comparatively high overhead.
+ =item PeerService => STRING
- If C<$enable> is false, then the C<encode> method will output key-value
- pairs in the order Perl stores them (which will likely change between runs
- of the same script, and can change even within the same run from 5.18
- onwards).
+ Hostname and service name for the peer to C<connect()> to. The service name
+ may be given as a port number, as a decimal string.
- 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.
+ =item PeerAddr => STRING
- This setting has no effect when decoding JSON texts.
+ =item PeerPort => STRING
- This setting has currently no effect on tied hashes.
+ For symmetry with the accessor methods and compatibility with
+ C<IO::Socket::INET>, these are accepted as synonyms for C<PeerHost> and
+ C<PeerService> respectively.
- =head2 allow_nonref
+ =item PeerAddrInfo => ARRAY
- $json = $json->allow_nonref([$enable])
-
- $enabled = $json->get_allow_nonref
+ Alternate form of specifying the peer to C<connect()> to. This should be an
+ array of the form returned by C<Socket::getaddrinfo>.
- If C<$enable> is true (or missing), then the C<encode> method can convert a
- non-reference into its corresponding string, number or null JSON value,
- which is an extension to RFC4627. Likewise, C<decode> will accept those JSON
- values instead of croaking.
+ This parameter takes precedence over the C<Peer*>, C<Family>, C<Type> and
+ C<Proto> arguments.
- If C<$enable> is false, then the C<encode> method will croak if it isn't
- passed an arrayref or hashref, as JSON texts must either be an object
- or array. Likewise, C<decode> will croak if given something that is not a
- JSON object or array.
+ =item LocalHost => STRING
- Example, encode a Perl scalar as JSON value with enabled C<allow_nonref>,
- resulting in an invalid JSON text:
+ =item LocalService => STRING
- JSON->new->allow_nonref->encode ("Hello, World!")
- => "Hello, World!"
+ Hostname and service name for the local address to C<bind()> to.
- =head2 allow_unknown
+ =item LocalAddr => STRING
- $json = $json->allow_unknown ([$enable])
-
- $enabled = $json->get_allow_unknown
+ =item LocalPort => STRING
- If C<$enable> is true (or missing), then C<encode> will I<not> throw an
- exception when it encounters values it cannot represent in JSON (for
- example, filehandles) but instead will encode a JSON C<null> value. Note
- that blessed objects are not included here and are handled separately by
- c<allow_nonref>.
+ For symmetry with the accessor methods and compatibility with
+ C<IO::Socket::INET>, these are accepted as synonyms for C<LocalHost> and
+ C<LocalService> respectively.
- If C<$enable> is false (the default), then C<encode> will throw an
- exception when it encounters anything it cannot encode as JSON.
+ =item LocalAddrInfo => ARRAY
- This option does not affect C<decode> in any way, and it is recommended to
- leave it off unless you know your communications partner.
+ Alternate form of specifying the local address to C<bind()> to. This should be
+ an array of the form returned by C<Socket::getaddrinfo>.
- =head2 allow_blessed
+ This parameter takes precedence over the C<Local*>, C<Family>, C<Type> and
+ C<Proto> arguments.
- $json = $json->allow_blessed([$enable])
-
- $enabled = $json->get_allow_blessed
+ =item Family => INT
- See L<OBJECT SERIALISATION> for details.
+ The address family to pass to C<getaddrinfo> (e.g. C<AF_INET>, C<AF_INET6>).
+ Normally this will be left undefined, and C<getaddrinfo> will search using any
+ address family supported by the system.
- If C<$enable> is true (or missing), then the C<encode> method will not
- barf when it encounters a blessed reference that it cannot convert
- otherwise. Instead, a JSON C<null> value is encoded instead of the object.
+ =item Type => INT
- If C<$enable> is false (the default), then C<encode> will throw an
- exception when it encounters a blessed object that it cannot convert
- otherwise.
+ The socket type to pass to C<getaddrinfo> (e.g. C<SOCK_STREAM>,
+ C<SOCK_DGRAM>). Normally defined by the caller; if left undefined
+ C<getaddrinfo> may attempt to infer the type from the service name.
- This setting has no effect on C<decode>.
+ =item Proto => STRING or INT
- =head2 convert_blessed
+ The IP protocol to use for the socket (e.g. C<'tcp'>, C<IPPROTO_TCP>,
+ C<'udp'>,C<IPPROTO_UDP>). Normally this will be left undefined, and either
+ C<getaddrinfo> or the kernel will choose an appropriate value. May be given
+ either in string name or numeric form.
- $json = $json->convert_blessed([$enable])
-
- $enabled = $json->get_convert_blessed
+ =item GetAddrInfoFlags => INT
- See L<OBJECT SERIALISATION> for details.
+ More flags to pass to the C<getaddrinfo()> function. If not supplied, a
+ default of C<AI_ADDRCONFIG> will be used.
- If C<$enable> is true (or missing), then C<encode>, upon encountering a
- blessed object, will check for the availability of the C<TO_JSON> 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.
+ These flags will be combined with C<AI_PASSIVE> if the C<Listen> argument is
+ given. For more information see the documentation about C<getaddrinfo()> in
+ the L<Socket> module.
- The C<TO_JSON> method may safely call die if it wants. If C<TO_JSON>
- returns other blessed objects, those will be handled in the same
- way. C<TO_JSON> must take care of not causing an endless recursion cycle
- (== crash) in this case. The name of C<TO_JSON> 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 any C<to_json>
- function or method.
+ =item Listen => INT
- If C<$enable> is false (the default), then C<encode> will not consider
- this type of conversion.
+ If defined, puts the socket into listening mode where new connections can be
+ accepted using the C<accept> method. The value given is used as the
+ C<listen(2)> queue size.
- This setting has no effect on C<decode>.
+ =item ReuseAddr => BOOL
- =head2 filter_json_object
+ If true, set the C<SO_REUSEADDR> sockopt
- $json = $json->filter_json_object([$coderef])
+ =item ReusePort => BOOL
- When C<$coderef> is specified, it will be called from C<decode> each
- time it decodes a JSON object. The only argument 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<not> C<undef>, which is a valid scalar), the
- original deserialised hash will be inserted. This setting can slow down
- decoding considerably.
+ If true, set the C<SO_REUSEPORT> sockopt (not all OSes implement this sockopt)
- When C<$coderef> is omitted or undefined, any existing callback will
- be removed and C<decode> will not change the deserialised hash in any
- way.
+ =item Broadcast => BOOL
- Example, convert all JSON objects into the integer 5:
+ If true, set the C<SO_BROADCAST> sockopt
- 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}');
+ =item Sockopts => ARRAY
- =head2 filter_json_single_key_object
+ An optional array of other socket options to apply after the three listed
+ above. The value is an ARRAY containing 2- or 3-element ARRAYrefs. Each inner
+ array relates to a single option, giving the level and option name, and an
+ optional value. If the value element is missing, it will be given the value of
+ a platform-sized integer 1 constant (i.e. suitable to enable most of the
+ common boolean options).
- $json = $json->filter_json_single_key_object($key [=> $coderef])
+ For example, both options given below are equivalent to setting C<ReuseAddr>.
- Works remotely similar to C<filter_json_object>, but is only called for
- JSON objects having a single key named C<$key>.
+ Sockopts => [
+ [ SOL_SOCKET, SO_REUSEADDR ],
+ [ SOL_SOCKET, SO_REUSEADDR, pack( "i", 1 ) ],
+ ]
- This C<$coderef> is called before the one specified via
- C<filter_json_object>, 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<undef> but the empty list),
- the callback from C<filter_json_object> will be called next, as if no
- single-key callback were specified.
+ =item V6Only => BOOL
- If C<$coderef> is omitted or undefined, the corresponding callback will be
- disabled. There can only ever be one callback for a given key.
+ If defined, set the C<IPV6_V6ONLY> sockopt when creating C<PF_INET6> sockets
+ to the given value. If true, a listening-mode socket will only listen on the
+ C<AF_INET6> addresses; if false it will also accept connections from
+ C<AF_INET> addresses.
- As this callback gets called less often then the C<filter_json_object>
- 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.
+ If not defined, the socket option will not be changed, and default value set
+ by the operating system will apply. For repeatable behaviour across platforms
+ it is recommended this value always be defined for listening-mode sockets.
- 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.
+ Note that not all platforms support disabling this option. Some, at least
+ OpenBSD and MirBSD, will fail with C<EINVAL> if you attempt to disable it.
+ To determine whether it is possible to disable, you may use the class method
- Example, decode JSON objects of the form C<< { "__widget__" => <id> } >>
- into the corresponding C<< $WIDGET{<id>} >> object:
+ if( IO::Socket::IP->CAN_DISABLE_V6ONLY ) {
+ ...
+ }
+ else {
+ ...
+ }
- # return whatever is in $WIDGET{5}:
- JSON
- ->new
- ->filter_json_single_key_object (__widget__ => sub {
- $WIDGET{ $_[0] }
- })
- ->decode ('{"__widget__": 5')
+ If your platform does not support disabling this option but you still want to
+ listen for both C<AF_INET> and C<AF_INET6> connections you will have to create
+ two listening sockets, one bound to each protocol.
- # this can be used with a TO_JSON method in some "widget" class
- # for serialisation to json:
- sub WidgetBase::TO_JSON {
- my ($self) = @_;
+ =item MultiHomed
- unless ($self->{id}) {
- $self->{id} = ..get..some..id..;
- $WIDGET{$self->{id}} = $self;
+ This C<IO::Socket::INET>-style argument is ignored, except if it is defined
+ but false. See the C<IO::Socket::INET> INCOMPATIBILITES section below.
+
+ However, the behaviour it enables is always performed by C<IO::Socket::IP>.
+
+ =item Blocking => BOOL
+
+ If defined but false, the socket will be set to non-blocking mode. Otherwise
+ it will default to blocking mode. See the NON-BLOCKING section below for more
+ detail.
+
+ =item Timeout => NUM
+
+ If defined, gives a maximum time in seconds to block per C<connect()> call
+ when in blocking mode. If missing, no timeout is applied other than that
+ provided by the underlying operating system. When in non-blocking mode this
+ parameter is ignored.
+
+ Note that if the hostname resolves to multiple address candidates, the same
+ timeout will apply to each connection attempt individually, rather than to the
+ operation as a whole. Further note that the timeout does not apply to the
+ initial hostname resolve operation, if connecting by hostname.
+
+ This behviour is copied inspired by C<IO::Socket::INET>; for more fine grained
+ control over connection timeouts, consider performing a nonblocking connect
+ directly.
+
+ =back
+
+ If neither C<Type> nor C<Proto> hints are provided, a default of
+ C<SOCK_STREAM> and C<IPPROTO_TCP> respectively will be set, to maintain
+ compatibility with C<IO::Socket::INET>. Other named arguments that are not
+ recognised are ignored.
+
+ If neither C<Family> nor any hosts or addresses are passed, nor any
+ C<*AddrInfo>, then the constructor has no information on which to decide a
+ socket family to create. In this case, it performs a C<getaddinfo> call with
+ the C<AI_ADDRCONFIG> flag, no host name, and a service name of C<"0">, and
+ uses the family of the first returned result.
+
+ If the constructor fails, it will set C<$@> to an appropriate error message;
+ this may be from C<$!> or it may be some other string; not every failure
+ necessarily has an associated C<errno> value.
+
+ =head2 $sock = IO::Socket::IP->new( $peeraddr )
+
+ As a special case, if the constructor is passed a single argument (as
+ opposed to an even-sized list of key/value pairs), it is taken to be the value
+ of the C<PeerAddr> parameter. This is parsed in the same way, according to the
+ behaviour given in the C<PeerHost> AND C<LocalHost> PARSING section below.
+
+ =cut
+
+ sub new
+ {
+ my $class = shift;
+ my %arg = (@_ == 1) ? (PeerHost => $_[0]) : @_;
+ return $class->SUPER::new(%arg);
+ }
+
+ # IO::Socket may call this one; neaten up the arguments from IO::Socket::INET
+ # before calling our real _configure method
+ sub configure
+ {
+ my $self = shift;
+ my ( $arg ) = @_;
+
+ $arg->{PeerHost} = delete $arg->{PeerAddr}
+ if exists $arg->{PeerAddr} && !exists $arg->{PeerHost};
+
+ $arg->{PeerService} = delete $arg->{PeerPort}
+ if exists $arg->{PeerPort} && !exists $arg->{PeerService};
+
+ $arg->{LocalHost} = delete $arg->{LocalAddr}
+ if exists $arg->{LocalAddr} && !exists $arg->{LocalHost};
+
+ $arg->{LocalService} = delete $arg->{LocalPort}
+ if exists $arg->{LocalPort} && !exists $arg->{LocalService};
+
+ for my $type (qw(Peer Local)) {
+ my $host = $type . 'Host';
+ my $service = $type . 'Service';
+
+ if( defined $arg->{$host} ) {
+ ( $arg->{$host}, my $s ) = $self->split_addr( $arg->{$host} );
+ # IO::Socket::INET compat - *Host parsed port always takes precedence
+ $arg->{$service} = $s if defined $s;
}
+ }
- { __widget__ => $self->{id} }
+ $self->_io_socket_ip__configure( $arg );
+ }
+
+ # Avoid simply calling it _configure, as some subclasses of IO::Socket::INET on CPAN already take that
+ sub _io_socket_ip__configure
+ {
+ my $self = shift;
+ my ( $arg ) = @_;
+
+ my %hints;
+ my @localinfos;
+ my @peerinfos;
+
+ my $listenqueue = $arg->{Listen};
+ if( defined $listenqueue and
+ ( defined $arg->{PeerHost} || defined $arg->{PeerService} || defined $arg->{PeerAddrInfo} ) ) {
+ croak "Cannot Listen with a peer address";
}
- =head2 max_depth
+ if( defined $arg->{GetAddrInfoFlags} ) {
+ $hints{flags} = $arg->{GetAddrInfoFlags};
+ }
+ else {
+ $hints{flags} = $AI_ADDRCONFIG;
+ }
- $json = $json->max_depth([$maximum_nesting_depth])
-
- $max_depth = $json->get_max_depth
+ if( defined( my $family = $arg->{Family} ) ) {
+ $hints{family} = $family;
+ }
- 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.
+ if( defined( my $type = $arg->{Type} ) ) {
+ $hints{socktype} = $type;
+ }
- 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( defined( my $proto = $arg->{Proto} ) ) {
+ unless( $proto =~ m/^\d+$/ ) {
+ my $protonum = HAVE_GETPROTOBYNAME
+ ? getprotobyname( $proto )
+ : eval { Socket->${\"IPPROTO_\U$proto"}() };
+ defined $protonum or croak "Unrecognised protocol $proto";
+ $proto = $protonum;
+ }
- Setting the maximum depth to one disallows any nesting, so that ensures
- that the object is only a single hash/object or array.
+ $hints{protocol} = $proto;
+ }
- If no argument is given, the highest possible setting will be used, which
- is rarely useful.
+ # To maintain compatibility with IO::Socket::INET, imply a default of
+ # SOCK_STREAM + IPPROTO_TCP if neither hint is given
+ if( !defined $hints{socktype} and !defined $hints{protocol} ) {
+ $hints{socktype} = SOCK_STREAM;
+ $hints{protocol} = IPPROTO_TCP;
+ }
- =head2 max_size
+ # Some OSes (NetBSD) don't seem to like just a protocol hint without a
+ # socktype hint as well. We'll set a couple of common ones
+ if( !defined $hints{socktype} and defined $hints{protocol} ) {
+ $hints{socktype} = SOCK_STREAM if $hints{protocol} == IPPROTO_TCP;
+ $hints{socktype} = SOCK_DGRAM if $hints{protocol} == IPPROTO_UDP;
+ }
- $json = $json->max_size([$maximum_string_size])
-
- $max_size = $json->get_max_size
+ if( my $info = $arg->{LocalAddrInfo} ) {
+ ref $info eq "ARRAY" or croak "Expected 'LocalAddrInfo' to be an ARRAY ref";
+ @localinfos = @$info;
+ }
+ elsif( defined $arg->{LocalHost} or
+ defined $arg->{LocalService} or
+ HAVE_MSWIN32 and $arg->{Listen} ) {
+ # Either may be undef
+ my $host = $arg->{LocalHost};
+ my $service = $arg->{LocalService};
- 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<decode>
- 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<encode> (yet).
+ unless ( defined $host or defined $service ) {
+ $service = 0;
+ }
- If no argument is given, the limit check will be deactivated (same as when
- C<0> is specified).
+ local $1; # Placate a taint-related bug; [perl #67962]
+ defined $service and $service =~ s/\((\d+)\)$// and
+ my $fallback_port = $1;
- =head2 encode
+ my %localhints = %hints;
+ $localhints{flags} |= AI_PASSIVE;
+ ( my $err, @localinfos ) = getaddrinfo( $host, $service, \%localhints );
- $json_text = $json->encode($perl_scalar)
+ if( $err and defined $fallback_port ) {
+ ( $err, @localinfos ) = getaddrinfo( $host, $fallback_port, \%localhints );
+ }
- Converts the given Perl value or data structure to its JSON
- representation. Croaks on error.
+ if( $err ) {
+ $@ = "$err";
+ $! = EINVAL;
+ return;
+ }
+ }
- =head2 decode
+ if( my $info = $arg->{PeerAddrInfo} ) {
+ ref $info eq "ARRAY" or croak "Expected 'PeerAddrInfo' to be an ARRAY ref";
+ @peerinfos = @$info;
+ }
+ elsif( defined $arg->{PeerHost} or defined $arg->{PeerService} ) {
+ defined( my $host = $arg->{PeerHost} ) or
+ croak "Expected 'PeerHost'";
+ defined( my $service = $arg->{PeerService} ) or
+ croak "Expected 'PeerService'";
- $perl_scalar = $json->decode($json_text)
+ local $1; # Placate a taint-related bug; [perl #67962]
+ defined $service and $service =~ s/\((\d+)\)$// and
+ my $fallback_port = $1;
- The opposite of C<encode>: expects a JSON text and tries to parse it,
- returning the resulting simple scalar or reference. Croaks on error.
+ ( my $err, @peerinfos ) = getaddrinfo( $host, $service, \%hints );
- =head2 decode_prefix
+ if( $err and defined $fallback_port ) {
+ ( $err, @peerinfos ) = getaddrinfo( $host, $fallback_port, \%hints );
+ }
- ($perl_scalar, $characters) = $json->decode_prefix($json_text)
+ if( $err ) {
+ $@ = "$err";
+ $! = EINVAL;
+ return;
+ }
+ }
- This works like the C<decode> 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.
+ my $INT_1 = pack "i", 1;
- This is useful if your JSON texts are not delimited by an outer protocol
- and you need to know where the JSON text ends.
+ my @sockopts_enabled;
+ push @sockopts_enabled, [ SOL_SOCKET, SO_REUSEADDR, $INT_1 ] if $arg->{ReuseAddr};
+ push @sockopts_enabled, [ SOL_SOCKET, SO_REUSEPORT, $INT_1 ] if $arg->{ReusePort};
+ push @sockopts_enabled, [ SOL_SOCKET, SO_BROADCAST, $INT_1 ] if $arg->{Broadcast};
- JSON->new->decode_prefix ("[1] the tail")
- => ([1], 3)
+ if( my $sockopts = $arg->{Sockopts} ) {
+ ref $sockopts eq "ARRAY" or croak "Expected 'Sockopts' to be an ARRAY ref";
+ foreach ( @$sockopts ) {
+ ref $_ eq "ARRAY" or croak "Bad Sockopts item - expected ARRAYref";
+ @$_ >= 2 and @$_ <= 3 or
+ croak "Bad Sockopts item - expected 2 or 3 elements";
- =head1 ADDITIONAL METHODS
+ my ( $level, $optname, $value ) = @$_;
+ # TODO: consider more sanity checking on argument values
- The following methods are for this module only.
+ defined $value or $value = $INT_1;
+ push @sockopts_enabled, [ $level, $optname, $value ];
+ }
+ }
- =head2 backend
+ my $blocking = $arg->{Blocking};
+ defined $blocking or $blocking = 1;
- $backend = $json->backend
+ my $v6only = $arg->{V6Only};
- Since 2.92, C<backend> method returns an abstract backend module used currently,
- which should be JSON::Backend::XS (which inherits JSON::XS or Cpanel::JSON::XS),
- or JSON::Backend::PP (which inherits JSON::PP), not to monkey-patch the actual
- backend module globally.
+ # IO::Socket::INET defines this key. IO::Socket::IP always implements the
+ # behaviour it requests, so we can ignore it, unless the caller is for some
+ # reason asking to disable it.
+ if( defined $arg->{MultiHomed} and !$arg->{MultiHomed} ) {
+ croak "Cannot disable the MultiHomed parameter";
+ }
- If you need to know what is used actually, use C<isa>, instead of string comparison.
+ my @infos;
+ foreach my $local ( @localinfos ? @localinfos : {} ) {
+ foreach my $peer ( @peerinfos ? @peerinfos : {} ) {
+ next if defined $local->{family} and defined $peer->{family} and
+ $local->{family} != $peer->{family};
+ next if defined $local->{socktype} and defined $peer->{socktype} and
+ $local->{socktype} != $peer->{socktype};
+ next if defined $local->{protocol} and defined $peer->{protocol} and
+ $local->{protocol} != $peer->{protocol};
+
+ my $family = $local->{family} || $peer->{family} or next;
+ my $socktype = $local->{socktype} || $peer->{socktype} or next;
+ my $protocol = $local->{protocol} || $peer->{protocol} || 0;
+
+ push @infos, {
+ family => $family,
+ socktype => $socktype,
+ protocol => $protocol,
+ localaddr => $local->{addr},
+ peeraddr => $peer->{addr},
+ };
+ }
+ }
- =head2 is_xs
+ if( !@infos ) {
+ # If there was a Family hint then create a plain unbound, unconnected socket
+ if( defined $hints{family} ) {
+ @infos = ( {
+ family => $hints{family},
+ socktype => $hints{socktype},
+ protocol => $hints{protocol},
+ } );
+ }
+ # If there wasn't, use getaddrinfo()'s AI_ADDRCONFIG side-effect to guess a
+ # suitable family first.
+ else {
+ ( my $err, @infos ) = getaddrinfo( "", "0", \%hints );
+ if( $err ) {
+ $@ = "$err";
+ $! = EINVAL;
+ return;
+ }
- $boolean = $json->is_xs
+ # We'll take all the @infos anyway, because some OSes (HPUX) are known to
+ # ignore the AI_ADDRCONFIG hint and return AF_INET6 even if they don't
+ # support them
+ }
+ }
- Returns true if the backend inherits JSON::XS or Cpanel::JSON::XS.
+ # In the nonblocking case, caller will be calling ->setup multiple times.
+ # Store configuration in the object for the ->setup method
+ # Yes, these are messy. Sorry, I can't help that...
- =head2 is_pp
+ ${*$self}{io_socket_ip_infos} = \@infos;
- $boolean = $json->is_pp
+ ${*$self}{io_socket_ip_idx} = -1;
- Returns true if the backend inherits JSON::PP.
+ ${*$self}{io_socket_ip_sockopts} = \@sockopts_enabled;
+ ${*$self}{io_socket_ip_v6only} = $v6only;
+ ${*$self}{io_socket_ip_listenqueue} = $listenqueue;
+ ${*$self}{io_socket_ip_blocking} = $blocking;
- =head2 property
+ ${*$self}{io_socket_ip_errors} = [ undef, undef, undef ];
- $settings = $json->property()
+ # ->setup is allowed to return false in nonblocking mode
+ $self->setup or !$blocking or return undef;
- Returns a reference to a hash that holds all the common flag settings.
+ return $self;
+ }
- $json = $json->property('utf8' => 1)
- $value = $json->property('utf8') # 1
+ sub setup
+ {
+ my $self = shift;
- You can use this to get/set a value of a particular flag.
+ while(1) {
+ ${*$self}{io_socket_ip_idx}++;
+ last if ${*$self}{io_socket_ip_idx} >= @{ ${*$self}{io_socket_ip_infos} };
- =head1 INCREMENTAL PARSING
+ my $info = ${*$self}{io_socket_ip_infos}->[${*$self}{io_socket_ip_idx}];
- This section is also taken from JSON::XS.
+ $self->socket( @{$info}{qw( family socktype protocol )} ) or
+ ( ${*$self}{io_socket_ip_errors}[2] = $!, next );
- In some cases, there is the need for incremental parsing of JSON
- texts. While this module always has to keep both JSON text and resulting
- Perl data structure in memory at one time, it 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<decode_prefix> to see if a full JSON object is available, but
- is much more efficient (and can be implemented with a minimum of method
- calls).
+ $self->blocking( 0 ) unless ${*$self}{io_socket_ip_blocking};
- 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 mismatched
- parentheses. 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<max_size>) to ensure the parser will stop
- parsing in the presence if syntax errors.
+ foreach my $sockopt ( @{ ${*$self}{io_socket_ip_sockopts} } ) {
+ my ( $level, $optname, $value ) = @$sockopt;
+ $self->setsockopt( $level, $optname, $value ) or ( $@ = "$!", return undef );
+ }
- The following methods implement this incremental parser.
+ if( defined ${*$self}{io_socket_ip_v6only} and defined $AF_INET6 and $info->{family} == $AF_INET6 ) {
+ my $v6only = ${*$self}{io_socket_ip_v6only};
+ $self->setsockopt( IPPROTO_IPV6, IPV6_V6ONLY, pack "i", $v6only ) or ( $@ = "$!", return undef );
+ }
- =head2 incr_parse
+ if( defined( my $addr = $info->{localaddr} ) ) {
+ $self->bind( $addr ) or
+ ( ${*$self}{io_socket_ip_errors}[1] = $!, next );
+ }
- $json->incr_parse( [$string] ) # void context
-
- $obj_or_undef = $json->incr_parse( [$string] ) # scalar context
-
- @obj_or_empty = $json->incr_parse( [$string] ) # list context
+ if( defined( my $listenqueue = ${*$self}{io_socket_ip_listenqueue} ) ) {
+ $self->listen( $listenqueue ) or ( $@ = "$!", return undef );
+ }
- 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( defined( my $addr = $info->{peeraddr} ) ) {
+ if( $self->connect( $addr ) ) {
+ $! = 0;
+ return 1;
+ }
- If C<$string> is given, then this string is appended to the already
- existing JSON fragment stored in the C<$json> object.
+ if( $! == EINPROGRESS or $! == EWOULDBLOCK ) {
+ ${*$self}{io_socket_ip_connect_in_progress} = 1;
+ return 0;
+ }
- 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 connect failed but we have no system error there must be an error
+ # at the application layer, like a bad certificate with
+ # IO::Socket::SSL.
+ # In this case don't continue IP based multi-homing because the problem
+ # cannot be solved at the IP layer.
+ return 0 if ! $!;
- If the method is called in scalar context, then it will try to extract
- exactly I<one> JSON object. If that is successful, it will return this
- object, otherwise it will return C<undef>. If there is a parse error,
- this method will croak just as C<decode> would do (one can then use
- C<incr_skip> to skip the erroneous part). This is the most common way of
- using the method.
+ ${*$self}{io_socket_ip_errors}[0] = $!;
+ next;
+ }
- 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 (other than
- whitespace) 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.
+ return 1;
+ }
- Example: Parse some JSON arrays/objects in a given string and return
- them.
+ # Pick the most appropriate error, stringified
+ $! = ( grep defined, @{ ${*$self}{io_socket_ip_errors}} )[0];
+ $@ = "$!";
+ return undef;
+ }
- my @objs = JSON->new->incr_parse ("[5][7][1,2]");
+ sub connect :method
+ {
+ my $self = shift;
- =head2 incr_text
+ # It seems that IO::Socket hides EINPROGRESS errors, making them look like
+ # a success. This is annoying here.
+ # Instead of putting up with its frankly-irritating intentional breakage of
+ # useful APIs I'm just going to end-run around it and call core's connect()
+ # directly
- $lvalue_string = $json->incr_text
+ if( @_ ) {
+ my ( $addr ) = @_;
- This method returns the currently stored JSON fragment as an lvalue, that
- is, you can manipulate it. This I<only> works when a preceding call to
- C<incr_parse> in I<scalar context> 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<will> fail under
- real world conditions). As a special exception, you can also call this
- method before having parsed anything.
+ # Annoyingly IO::Socket's connect() is where the timeout logic is
+ # implemented, so we'll have to reinvent it here
+ my $timeout = ${*$self}{'io_socket_timeout'};
- That means you can only use this function to look at or manipulate text
- before or after complete JSON objects, not while the parser is in the
- middle of parsing a JSON object.
+ return connect( $self, $addr ) unless defined $timeout;
- 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).
+ my $was_blocking = $self->blocking( 0 );
- =head2 incr_skip
+ my $err = defined connect( $self, $addr ) ? 0 : $!+0;
- $json->incr_skip
+ if( !$err ) {
+ # All happy
+ $self->blocking( $was_blocking );
+ return 1;
+ }
+ elsif( not( $err == EINPROGRESS or $err == EWOULDBLOCK ) ) {
+ # Failed for some other reason
+ $self->blocking( $was_blocking );
+ return undef;
+ }
+ elsif( !$was_blocking ) {
+ # We shouldn't block anyway
+ return undef;
+ }
- This will reset the state of the incremental parser and will remove
- the parsed text from the input buffer so far. This is useful after
- C<incr_parse> 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.
+ my $vec = ''; vec( $vec, $self->fileno, 1 ) = 1;
+ if( !select( undef, $vec, $vec, $timeout ) ) {
+ $self->blocking( $was_blocking );
+ $! = ETIMEDOUT;
+ return undef;
+ }
- The difference to C<incr_reset> is that only text until the parse error
- occurred is removed.
+ # Hoist the error by connect()ing a second time
+ $err = $self->getsockopt( SOL_SOCKET, SO_ERROR );
+ $err = 0 if $err == EISCONN; # Some OSes give EISCONN
- =head2 incr_reset
+ $self->blocking( $was_blocking );
- $json->incr_reset
+ $! = $err, return undef if $err;
+ return 1;
+ }
- This completely resets the incremental parser, that is, after this call,
- it will be as if the parser had never parsed anything.
+ return 1 if !${*$self}{io_socket_ip_connect_in_progress};
- 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 if a connect attempt has just failed with an error
+ if( my $errno = $self->getsockopt( SOL_SOCKET, SO_ERROR ) ) {
+ delete ${*$self}{io_socket_ip_connect_in_progress};
+ ${*$self}{io_socket_ip_errors}[0] = $! = $errno;
+ return $self->setup;
+ }
- =head1 MAPPING
+ # No error, so either connect is still in progress, or has completed
+ # successfully. We can tell by trying to connect() again; either it will
+ # succeed or we'll get EISCONN (connected successfully), or EALREADY
+ # (still in progress). This even works on MSWin32.
+ my $addr = ${*$self}{io_socket_ip_infos}[${*$self}{io_socket_ip_idx}]{peeraddr};
- Most of this section is also taken from JSON::XS.
+ if( connect( $self, $addr ) or $! == EISCONN ) {
+ delete ${*$self}{io_socket_ip_connect_in_progress};
+ $! = 0;
+ return 1;
+ }
+ else {
+ $! = EINPROGRESS;
+ return 0;
+ }
+ }
- This section describes how the backend modules map Perl values to JSON values and
- vice versa. These mappings are designed to "do the right thing" in most
- circumstances automatically, preserving round-tripping characteristics
- (what you put in comes out as something equivalent).
+ sub connected
+ {
+ my $self = shift;
+ return defined $self->fileno &&
+ !${*$self}{io_socket_ip_connect_in_progress} &&
+ defined getpeername( $self ); # ->peername caches, we need to detect disconnection
+ }
- For the more enlightened: note that in the following descriptions,
- lowercase I<perl> refers to the Perl interpreter, while uppercase I<Perl>
- refers to the abstract Perl language itself.
+ =head1 METHODS
- =head2 JSON -> PERL
+ As well as the following methods, this class inherits all the methods in
+ L<IO::Socket> and L<IO::Handle>.
- =over 4
+ =cut
- =item object
+ sub _get_host_service
+ {
+ my $self = shift;
+ my ( $addr, $flags, $xflags ) = @_;
- 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).
+ defined $addr or
+ $! = ENOTCONN, return;
- =item array
+ $flags |= NI_DGRAM if $self->socktype == SOCK_DGRAM;
- A JSON array becomes a reference to an array in Perl.
+ my ( $err, $host, $service ) = getnameinfo( $addr, $flags, $xflags || 0 );
+ croak "getnameinfo - $err" if $err;
- =item string
+ return ( $host, $service );
+ }
- 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.
+ sub _unpack_sockaddr
+ {
+ my ( $addr ) = @_;
+ my $family = sockaddr_family $addr;
- =item number
+ if( $family == AF_INET ) {
+ return ( Socket::unpack_sockaddr_in( $addr ) )[1];
+ }
+ elsif( defined $AF_INET6 and $family == $AF_INET6 ) {
+ return ( Socket::unpack_sockaddr_in6( $addr ) )[1];
+ }
+ else {
+ croak "Unrecognised address family $family";
+ }
+ }
- 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.
+ =head2 ( $host, $service ) = $sock->sockhost_service( $numeric )
- If the number consists of digits only, this module 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).
+ Returns the hostname and service name of the local address (that is, the
+ socket address given by the C<sockname> method).
- 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).
+ If C<$numeric> is true, these will be given in numeric form rather than being
+ resolved into names.
- Note that precision is not accuracy - binary floating point values cannot
- represent most decimal fractions exactly, and when converting from and to
- floating point, this module only guarantees precision up to but not including
- the least significant bit.
+ The following four convenience wrappers may be used to obtain one of the two
+ values returned here. If both host and service names are required, this method
+ is preferable to the following wrappers, because it will call
+ C<getnameinfo(3)> only once.
- =item true, false
+ =cut
- These JSON atoms become C<JSON::true> and C<JSON::false>,
- 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<JSON::is_bool> function.
+ sub sockhost_service
+ {
+ my $self = shift;
+ my ( $numeric ) = @_;
- =item null
+ $self->_get_host_service( $self->sockname, $numeric ? NI_NUMERICHOST|NI_NUMERICSERV : 0 );
+ }
- A JSON null atom becomes C<undef> in Perl.
+ =head2 $addr = $sock->sockhost
- =item shell-style comments (C<< # I<text> >>)
+ Return the numeric form of the local address as a textual representation
- As a nonstandard extension to the JSON syntax that is enabled by the
- C<relaxed> setting, shell-style comments are allowed. They can start
- anywhere outside strings and go till the end of the line.
+ =head2 $port = $sock->sockport
- =back
+ Return the numeric form of the local port number
+ =head2 $host = $sock->sockhostname
- =head2 PERL -> JSON
+ Return the resolved name of the local address
- 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.
+ =head2 $service = $sock->sockservice
- =over 4
+ Return the resolved name of the local port number
- =item hash references
+ =cut
- 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. This module can optionally sort the hash keys
- (determined by the I<canonical> flag), so the same data structure will
- serialise to the same JSON text (given same settings and version of
- the same backend), 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.
+ sub sockhost { my $self = shift; scalar +( $self->_get_host_service( $self->sockname, NI_NUMERICHOST, NIx_NOSERV ) )[0] }
+ sub sockport { my $self = shift; scalar +( $self->_get_host_service( $self->sockname, NI_NUMERICSERV, NIx_NOHOST ) )[1] }
- =item array references
+ sub sockhostname { my $self = shift; scalar +( $self->_get_host_service( $self->sockname, 0, NIx_NOSERV ) )[0] }
+ sub sockservice { my $self = shift; scalar +( $self->_get_host_service( $self->sockname, 0, NIx_NOHOST ) )[1] }
- Perl array references become JSON arrays.
+ =head2 $addr = $sock->sockaddr
- =item other references
+ Return the local address as a binary octet string
- 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<false> and C<true> atoms in JSON. You can
- also use C<JSON::false> and C<JSON::true> to improve readability.
+ =cut
- encode_json [\0,JSON::true] # yields [false,true]
+ sub sockaddr { my $self = shift; _unpack_sockaddr $self->sockname }
- =item JSON::true, JSON::false, JSON::null
+ =head2 ( $host, $service ) = $sock->peerhost_service( $numeric )
- These special values become JSON true and JSON false values,
- respectively. You can also use C<\1> and C<\0> directly if you want.
+ Returns the hostname and service name of the peer address (that is, the
+ socket address given by the C<peername> method), similar to the
+ C<sockhost_service> method.
- =item blessed objects
+ The following four convenience wrappers may be used to obtain one of the two
+ values returned here. If both host and service names are required, this method
+ is preferable to the following wrappers, because it will call
+ C<getnameinfo(3)> only once.
- Blessed objects are not directly representable in JSON, but C<JSON::XS>
- allows various ways of handling objects. See L<OBJECT SERIALISATION>,
- below, for details.
+ =cut
- =item simple scalars
+ sub peerhost_service
+ {
+ my $self = shift;
+ my ( $numeric ) = @_;
- Simple Perl scalars (any scalar that is not a reference) are the most
- difficult objects to encode: this module will encode undefined scalars as
- JSON C<null> values, scalars that have last been used in a string context
- before encoding as JSON strings, and anything else as number value:
+ $self->_get_host_service( $self->peername, $numeric ? NI_NUMERICHOST|NI_NUMERICSERV : 0 );
+ }
- # dump as number
- encode_json [2] # yields [2]
- encode_json [-3.0e17] # yields [-3e+17]
- my $value = 5; encode_json [$value] # yields [5]
+ =head2 $addr = $sock->peerhost
- # used as string, so dump as string
- print $value;
- encode_json [$value] # yields ["5"]
+ Return the numeric form of the peer address as a textual representation
- # undef becomes null
- encode_json [undef] # yields [null]
+ =head2 $port = $sock->peerport
- You can force the type to be a string by stringifying it:
+ Return the numeric form of the peer port number
- 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
+ =head2 $host = $sock->peerhostname
- You can force the type to be a number by numifying it:
+ Return the resolved name of the peer address
- 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.
+ =head2 $service = $sock->peerservice
- You can not currently force the type in other, less obscure, ways. Tell me
- if you need this capability (but don't forget to explain why it's needed
- :).
+ Return the resolved name of the peer port number
- 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.
+ =cut
- =back
+ sub peerhost { my $self = shift; scalar +( $self->_get_host_service( $self->peername, NI_NUMERICHOST, NIx_NOSERV ) )[0] }
+ sub peerport { my $self = shift; scalar +( $self->_get_host_service( $self->peername, NI_NUMERICSERV, NIx_NOHOST ) )[1] }
- =head2 OBJECT SERIALISATION
+ sub peerhostname { my $self = shift; scalar +( $self->_get_host_service( $self->peername, 0, NIx_NOSERV ) )[0] }
+ sub peerservice { my $self = shift; scalar +( $self->_get_host_service( $self->peername, 0, NIx_NOHOST ) )[1] }
- As for Perl objects, this module only supports a pure JSON representation
- (without the ability to deserialise the object automatically again).
+ =head2 $addr = $peer->peeraddr
- =head3 SERIALISATION
+ Return the peer address as a binary octet string
- What happens when this module encounters a Perl object depends on the
- C<allow_blessed> and C<convert_blessed> settings, which are used in
- this order:
+ =cut
- =over 4
+ sub peeraddr { my $self = shift; _unpack_sockaddr $self->peername }
- =item 1. C<convert_blessed> is enabled and the object has a C<TO_JSON> method.
+ # This unbelievably dodgy hack works around the bug that IO::Socket doesn't do
+ # it
+ # https://rt.cpan.org/Ticket/Display.html?id=61577
+ sub accept
+ {
+ my $self = shift;
+ my ( $new, $peer ) = $self->SUPER::accept( @_ ) or return;
- In this case, the C<TO_JSON> method of the object is invoked in scalar
- context. It must return a single scalar that can be directly encoded into
- JSON. This scalar replaces the object in the JSON text.
+ ${*$new}{$_} = ${*$self}{$_} for qw( io_socket_domain io_socket_type io_socket_proto );
- For example, the following C<TO_JSON> method will convert all L<URI>
- objects to JSON strings when serialised. The fact that these values
- originally were L<URI> objects is lost.
+ return wantarray ? ( $new, $peer )
+ : $new;
+ }
- sub URI::TO_JSON {
- my ($uri) = @_;
- $uri->as_string
+ # This second unbelievably dodgy hack guarantees that $self->fileno doesn't
+ # change, which is useful during nonblocking connect
+ sub socket :method
+ {
+ my $self = shift;
+ return $self->SUPER::socket(@_) if not defined $self->fileno;
+
+ # I hate core prototypes sometimes...
+ socket( my $tmph, $_[0], $_[1], $_[2] ) or return undef;
+
+ dup2( $tmph->fileno, $self->fileno ) or die "Unable to dup2 $tmph onto $self - $!";
+ }
+
+ # Versions of IO::Socket before 1.35 may leave socktype undef if from, say, an
+ # ->fdopen call. In this case we'll apply a fix
+ BEGIN {
+ if( eval($IO::Socket::VERSION) < 1.35 ) {
+ *socktype = sub {
+ my $self = shift;
+ my $type = $self->SUPER::socktype;
+ if( !defined $type ) {
+ $type = $self->sockopt( Socket::SO_TYPE() );
+ }
+ return $type;
+ };
}
+ }
- =item 2. C<allow_blessed> is enabled.
+ =head2 $inet = $sock->as_inet
- The object will be serialised as a JSON null value.
+ Returns a new L<IO::Socket::INET> instance wrapping the same filehandle. This
+ may be useful in cases where it is required, for backward-compatibility, to
+ have a real object of C<IO::Socket::INET> type instead of C<IO::Socket::IP>.
+ The new object will wrap the same underlying socket filehandle as the
+ original, so care should be taken not to continue to use both objects
+ concurrently. Ideally the original C<$sock> should be discarded after this
+ method is called.
- =item 3. none of the above
+ This method checks that the socket domain is C<PF_INET> and will throw an
+ exception if it isn't.
- If none of the settings are enabled or the respective methods are missing,
- this module throws an exception.
+ =cut
- =back
+ sub as_inet
+ {
+ my $self = shift;
+ croak "Cannot downgrade a non-PF_INET socket to IO::Socket::INET" unless $self->sockdomain == AF_INET;
+ return IO::Socket::INET->new_from_fd( $self->fileno, "r+" );
+ }
- =head1 ENCODING/CODESET FLAG NOTES
+ =head1 NON-BLOCKING
- This section is taken from JSON::XS.
+ If the constructor is passed a defined but false value for the C<Blocking>
+ argument then the socket is put into non-blocking mode. When in non-blocking
+ mode, the socket will not be set up by the time the constructor returns,
+ because the underlying C<connect(2)> syscall would otherwise have to block.
- The interested reader might have seen a number of flags that signify
- encodings or codesets - C<utf8>, C<latin1> and C<ascii>. There seems to be
- some confusion on what these do, so here is a short comparison:
+ The non-blocking behaviour is an extension of the C<IO::Socket::INET> API,
+ unique to C<IO::Socket::IP>, because the former does not support multi-homed
+ non-blocking connect.
- C<utf8> controls whether the JSON text created by C<encode> (and expected
- by C<decode>) is UTF-8 encoded or not, while C<latin1> and C<ascii> only
- control whether C<encode> escapes character values outside their respective
- codeset range. Neither of these flags conflict with each other, although
- some combinations make less sense than others.
+ When using non-blocking mode, the caller must repeatedly check for
+ writeability on the filehandle (for instance using C<select> or C<IO::Poll>).
+ Each time the filehandle is ready to write, the C<connect> method must be
+ called, with no arguments. Note that some operating systems, most notably
+ C<MSWin32> do not report a C<connect()> failure using write-ready; so you must
+ also C<select()> for exceptional status.
- Care has been taken to make all flags symmetrical with respect to
- C<encode> and C<decode>, that is, texts encoded with any combination of
- these flag values will be correctly decoded when the same flags are used
- - in general, if you use different flag settings while encoding vs. when
- decoding you likely have a bug somewhere.
+ While C<connect> returns false, the value of C<$!> indicates whether it should
+ be tried again (by being set to the value C<EINPROGRESS>, or C<EWOULDBLOCK> on
+ MSWin32), or whether a permanent error has occurred (e.g. C<ECONNREFUSED>).
- Below comes a verbose discussion of these flags. Note that a "codeset" is
- simply an abstract set of character-codepoint pairs, while an encoding
- takes those codepoint numbers and I<encodes> them, in our case into
- octets. Unicode is (among other things) a codeset, UTF-8 is an encoding,
- and ISO-8859-1 (= latin 1) and ASCII are both codesets I<and> encodings at
- the same time, which can be confusing.
+ Once the socket has been connected to the peer, C<connect> will return true
+ and the socket will now be ready to use.
- =over 4
+ Note that calls to the platform's underlying C<getaddrinfo(3)> function may
+ block. If C<IO::Socket::IP> has to perform this lookup, the constructor will
+ block even when in non-blocking mode.
- =item C<utf8> flag disabled
+ To avoid this blocking behaviour, the caller should pass in the result of such
+ a lookup using the C<PeerAddrInfo> or C<LocalAddrInfo> arguments. This can be
+ achieved by using L<Net::LibAsyncNS>, or the C<getaddrinfo(3)> function can be
+ called in a child process.
- When C<utf8> is disabled (the default), then C<encode>/C<decode> generate
- and expect Unicode strings, that is, characters with high ordinal Unicode
- values (> 255) will be encoded as such characters, and likewise such
- characters are decoded as-is, no changes to them will be done, except
- "(re-)interpreting" them as Unicode codepoints or Unicode characters,
- respectively (to Perl, these are the same thing in strings unless you do
- funny/weird/dumb stuff).
+ use IO::Socket::IP;
+ use Errno qw( EINPROGRESS EWOULDBLOCK );
- This is useful when you want to do the encoding yourself (e.g. when you
- want to have UTF-16 encoded JSON texts) or when some other layer does
- the encoding for you (for example, when printing to a terminal using a
- filehandle that transparently encodes to UTF-8 you certainly do NOT want
- to UTF-8 encode your data first and have Perl encode it another time).
+ my @peeraddrinfo = ... # Caller must obtain the getaddinfo result here
- =item C<utf8> flag enabled
+ my $socket = IO::Socket::IP->new(
+ PeerAddrInfo => \@peeraddrinfo,
+ Blocking => 0,
+ ) or die "Cannot construct socket - $@";
- If the C<utf8>-flag is enabled, C<encode>/C<decode> will encode all
- characters using the corresponding UTF-8 multi-byte sequence, and will
- expect your input strings to be encoded as UTF-8, that is, no "character"
- of the input string must have any value > 255, as UTF-8 does not allow
- that.
+ while( !$socket->connect and ( $! == EINPROGRESS || $! == EWOULDBLOCK ) ) {
+ my $wvec = '';
+ vec( $wvec, fileno $socket, 1 ) = 1;
+ my $evec = '';
+ vec( $evec, fileno $socket, 1 ) = 1;
- The C<utf8> flag therefore switches between two modes: disabled means you
- will get a Unicode string in Perl, enabled means you get an UTF-8 encoded
- octet/binary string in Perl.
+ select( undef, $wvec, $evec, undef ) or die "Cannot select - $!";
+ }
- =item C<latin1> or C<ascii> flags enabled
+ die "Cannot connect - $!" if $!;
- With C<latin1> (or C<ascii>) enabled, C<encode> will escape characters
- with ordinal values > 255 (> 127 with C<ascii>) and encode the remaining
- characters as specified by the C<utf8> flag.
+ ...
- If C<utf8> is disabled, then the result is also correctly encoded in those
- character sets (as both are proper subsets of Unicode, meaning that a
- Unicode string with all character values < 256 is the same thing as a
- ISO-8859-1 string, and a Unicode string with all character values < 128 is
- the same thing as an ASCII string in Perl).
+ The example above uses C<select()>, but any similar mechanism should work
+ analogously. C<IO::Socket::IP> takes care when creating new socket filehandles
+ to preserve the actual file descriptor number, so such techniques as C<poll>
+ or C<epoll> should be transparent to its reallocation of a different socket
+ underneath, perhaps in order to switch protocol family between C<PF_INET> and
+ C<PF_INET6>.
- If C<utf8> is enabled, you still get a correct UTF-8-encoded string,
- regardless of these flags, just some more characters will be escaped using
- C<\uXXXX> then before.
+ For another example using C<IO::Poll> and C<Net::LibAsyncNS>, see the
+ F<examples/nonblocking_libasyncns.pl> file in the module distribution.
- Note that ISO-8859-1-I<encoded> strings are not compatible with UTF-8
- encoding, while ASCII-encoded strings are. That is because the ISO-8859-1
- encoding is NOT a subset of UTF-8 (despite the ISO-8859-1 I<codeset> being
- a subset of Unicode), while ASCII is.
+ =cut
- Surprisingly, C<decode> will ignore these flags and so treat all input
- values as governed by the C<utf8> flag. If it is disabled, this allows you
- to decode ISO-8859-1- and ASCII-encoded strings, as both strict subsets of
- Unicode. If it is enabled, you can correctly decode UTF-8 encoded strings.
+ =head1 C<PeerHost> AND C<LocalHost> PARSING
- So neither C<latin1> nor C<ascii> are incompatible with the C<utf8> flag -
- they only govern when the JSON output engine escapes a character or not.
+ To support the C<IO::Socket::INET> API, the host and port information may be
+ passed in a single string rather than as two separate arguments.
- The main use for C<latin1> is to relatively efficiently store binary data
- as JSON, at the expense of breaking compatibility with most JSON decoders.
+ If either C<LocalHost> or C<PeerHost> (or their C<...Addr> synonyms) have any
+ of the following special forms then special parsing is applied.
- The main use for C<ascii> is to force the output to not contain characters
- with values > 127, which means you can interpret the resulting string
- as UTF-8, ISO-8859-1, ASCII, KOI8-R or most about any character set and
- 8-bit-encoding, and still get the same data structure back. This is useful
- when your channel for JSON transfer is not 8-bit clean or the encoding
- might be mangled in between (e.g. in mail), and works because ASCII is a
- proper subset of most 8-bit and multibyte encodings in use in the world.
+ The value of the C<...Host> argument will be split to give both the hostname
+ and port (or service name):
- =back
+ hostname.example.org:http # Host name
+ 192.0.2.1:80 # IPv4 address
+ [2001:db8::1]:80 # IPv6 address
- =head1 BACKWARD INCOMPATIBILITY
+ In each case, the port or service name (e.g. C<80>) is passed as the
+ C<LocalService> or C<PeerService> argument.
- Since version 2.90, stringification (and string comparison) for
- C<JSON::true> and C<JSON::false> has not been overloaded. It shouldn't
- matter as long as you treat them as boolean values, but a code that
- expects they are stringified as "true" or "false" doesn't work as
- you have expected any more.
+ Either of C<LocalService> or C<PeerService> (or their C<...Port> synonyms) can
+ be either a service name, a decimal number, or a string containing both a
+ service name and number, in a form such as
- if (JSON::true eq 'true') { # now fails
+ http(80)
- print "The result is $JSON::true now."; # => The result is 1 now.
+ In this case, the name (C<http>) will be tried first, but if the resolver does
+ not understand it then the port number (C<80>) will be used instead.
- And now these boolean values don't inherit JSON::Boolean, either.
- When you need to test a value is a JSON boolean value or not, use
- C<JSON::is_bool> function, instead of testing the value inherits
- a particular boolean class or not.
+ If the C<...Host> argument is in this special form and the corresponding
+ C<...Service> or C<...Port> argument is also defined, the one parsed from
+ the C<...Host> argument will take precedence and the other will be ignored.
- =head1 BUGS
+ =head2 ( $host, $port ) = IO::Socket::IP->split_addr( $addr )
+
+ Utility method that provides the parsing functionality described above.
+ Returns a 2-element list, containing either the split hostname and port
+ description if it could be parsed, or the given address and C<undef> if it was
+ not recognised.
+
+ IO::Socket::IP->split_addr( "hostname:http" )
+ # ( "hostname", "http" )
+
+ IO::Socket::IP->split_addr( "192.0.2.1:80" )
+ # ( "192.0.2.1", "80" )
- Please report bugs on backend selection and additional features
- this module provides to RT or GitHub issues for this module:
+ IO::Socket::IP->split_addr( "[2001:db8::1]:80" )
+ # ( "2001:db8::1", "80" )
+
+ IO::Socket::IP->split_addr( "something.else" )
+ # ( "something.else", undef )
+
+ =cut
+
+ sub split_addr
+ {
+ shift;
+ my ( $addr ) = @_;
+
+ local ( $1, $2 ); # Placate a taint-related bug; [perl #67962]
+ if( $addr =~ m/\A\[($IPv6_re)\](?::([^\s:]*))?\z/ or
+ $addr =~ m/\A([^\s:]*):([^\s:]*)\z/ ) {
+ return ( $1, $2 ) if defined $2 and length $2;
+ return ( $1, undef );
+ }
+
+ return ( $addr, undef );
+ }
+
+ =head2 $addr = IO::Socket::IP->join_addr( $host, $port )
+
+ Utility method that performs the reverse of C<split_addr>, returning a string
+ formed by joining the specified host address and port number. The host address
+ will be wrapped in C<[]> brackets if required (because it is a raw IPv6
+ numeric address).
+
+ This can be especially useful when combined with the C<sockhost_service> or
+ C<peerhost_service> methods.
+
+ say "Connected to ", IO::Socket::IP->join_addr( $sock->peerhost_service );
+
+ =cut
+
+ sub join_addr
+ {
+ shift;
+ my ( $host, $port ) = @_;
+
+ $host = "[$host]" if $host =~ m/:/;
+
+ return join ":", $host, $port if defined $port;
+ return $host;
+ }
+
+ # Since IO::Socket->new( Domain => ... ) will delete the Domain parameter
+ # before calling ->configure, we need to keep track of which it was
+
+ package # hide from indexer
+ IO::Socket::IP::_ForINET;
+ use base qw( IO::Socket::IP );
+
+ sub configure
+ {
+ # This is evil
+ my $self = shift;
+ my ( $arg ) = @_;
+
+ bless $self, "IO::Socket::IP";
+ $self->configure( { %$arg, Family => Socket::AF_INET() } );
+ }
+
+ package # hide from indexer
+ IO::Socket::IP::_ForINET6;
+ use base qw( IO::Socket::IP );
+
+ sub configure
+ {
+ # This is evil
+ my $self = shift;
+ my ( $arg ) = @_;
+
+ bless $self, "IO::Socket::IP";
+ $self->configure( { %$arg, Family => Socket::AF_INET6() } );
+ }
+
+ =head1 C<IO::Socket::INET> INCOMPATIBILITES
=over 4
- =item https://rt.cpan.org/Public/Dist/Display.html?Queue=JSON
+ =item *
- =item https://github.com/makamaka/JSON/issues
+ The behaviour enabled by C<MultiHomed> is in fact implemented by
+ C<IO::Socket::IP> as it is required to correctly support searching for a
+ useable address from the results of the C<getaddrinfo(3)> call. The
+ constructor will ignore the value of this argument, except if it is defined
+ but false. An exception is thrown in this case, because that would request it
+ disable the C<getaddrinfo(3)> search behaviour in the first place.
- =back
+ =item *
- Please report bugs and feature requests on decoding/encoding
- and boolean behaviors to the author of the backend module you
- are using.
+ C<IO::Socket::IP> implements both the C<Blocking> and C<Timeout> parameters,
+ but it implements the interaction of both in a different way.
- =head1 SEE ALSO
+ In C<::INET>, supplying a timeout overrides the non-blocking behaviour,
+ meaning that the C<connect()> operation will still block despite that the
+ caller asked for a non-blocking socket. This is not explicitly specified in
+ its documentation, nor does this author believe that is a useful behaviour -
+ it appears to come from a quirk of implementation.
- L<JSON::XS>, L<Cpanel::JSON::XS>, L<JSON::PP> for backends.
+ In C<::IP> therefore, the C<Blocking> parameter takes precedence - if a
+ non-blocking socket is requested, no operation will block. The C<Timeout>
+ parameter here simply defines the maximum time that a blocking C<connect()>
+ call will wait, if it blocks at all.
- L<JSON::MaybeXS>, an alternative that prefers Cpanel::JSON::XS.
+ In order to specifically obtain the "blocking connect then non-blocking send
+ and receive" behaviour of specifying this combination of options to C<::INET>
+ when using C<::IP>, perform first a blocking connect, then afterwards turn the
+ socket into nonblocking mode.
- C<RFC4627>(L<http://www.ietf.org/rfc/rfc4627.txt>)
+ my $sock = IO::Socket::IP->new(
+ PeerHost => $peer,
+ Timeout => 20,
+ ) or die "Cannot connect - $@";
- =head1 AUTHOR
+ $sock->blocking( 0 );
- Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
+ This code will behave identically under both C<IO::Socket::INET> and
+ C<IO::Socket::IP>.
- JSON::XS was written by Marc Lehmann <schmorp[at]schmorp.de>
+ =back
- The release of this new version owes to the courtesy of Marc Lehmann.
+ =cut
+ =head1 TODO
- =head1 COPYRIGHT AND LICENSE
+ =over 4
- Copyright 2005-2013 by Makamaka Hannyaharamitu
+ =item *
- This library is free software; you can redistribute it and/or modify
- it under the same terms as Perl itself.
+ Investigate whether C<POSIX::dup2> upsets BSD's C<kqueue> watchers, and if so,
+ consider what possible workarounds might be applied.
+
+ =back
+
+ =head1 AUTHOR
+
+ Paul Evans <leonerd@leonerd.org.uk>
=cut
-JSON
+ 0x55AA;
+IO_SOCKET_IP
$fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP';
package JSON::PP;
@@ -62348,7 +44212,7 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
use Carp ();
#use Devel::Peek;
- $JSON::PP::VERSION = '2.94';
+ $JSON::PP::VERSION = '4.02';
@JSON::PP::EXPORT = qw(encode_json decode_json from_json to_json);
@@ -62376,20 +44240,22 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
use constant P_AS_NONBLESSED => 17;
use constant P_ALLOW_UNKNOWN => 18;
+ use constant P_ALLOW_TAGS => 19;
use constant OLD_PERL => $] < 5.008 ? 1 : 0;
- use constant USE_B => 0;
+ use constant USE_B => $ENV{PERL_JSON_PP_USE_B} || 0;
BEGIN {
- if (USE_B) {
- require B;
- }
+ if (USE_B) {
+ require B;
+ }
}
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
+ allow_tags
);
my @pp_bit_properties = qw(
allow_singlequote allow_bignum loose
@@ -62466,6 +44332,8 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
indent_length => 3,
};
+ $self->{PROPS}[P_ALLOW_NONREF] = 1;
+
bless $self, $class;
}
@@ -62525,6 +44393,27 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
sub get_max_size { $_[0]->{max_size}; }
+ sub boolean_values {
+ my $self = shift;
+ if (@_) {
+ my ($false, $true) = @_;
+ $self->{false} = $false;
+ $self->{true} = $true;
+ return ($false, $true);
+ } else {
+ delete $self->{false};
+ delete $self->{true};
+ return;
+ }
+ }
+
+ sub get_boolean_values {
+ my $self = shift;
+ if (exists $self->{true} and exists $self->{false}) {
+ return @$self{qw/false true/};
+ }
+ return;
+ }
sub filter_json_object {
if (defined $_[1] and ref $_[1] eq 'CODE') {
@@ -62598,6 +44487,7 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
my $escape_slash;
my $bignum;
my $as_nonblessed;
+ my $allow_tags;
my $depth;
my $indent_count;
@@ -62614,9 +44504,9 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
my $props = $self->{PROPS};
($ascii, $latin1, $utf8, $indent, $canonical, $space_before, $space_after, $allow_blessed,
- $convert_blessed, $escape_slash, $bignum, $as_nonblessed)
+ $convert_blessed, $escape_slash, $bignum, $as_nonblessed, $allow_tags)
= @{$props}[P_ASCII .. P_SPACE_AFTER, P_ALLOW_BLESSED, P_CONVERT_BLESSED,
- P_ESCAPE_SLASH, P_ALLOW_BIGNUM, P_AS_NONBLESSED];
+ P_ESCAPE_SLASH, P_ALLOW_BIGNUM, P_AS_NONBLESSED, P_ALLOW_TAGS];
($max_depth, $indent_length) = @{$self}{qw/max_depth indent_length/};
@@ -62662,6 +44552,21 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
return $self->value_to_json($obj) if ( $obj->isa('JSON::PP::Boolean') );
+ if ( $allow_tags and $obj->can('FREEZE') ) {
+ my $obj_class = ref $obj || $obj;
+ $obj = bless $obj, $obj_class;
+ my @results = $obj->FREEZE('JSON');
+ if ( @results and ref $results[0] ) {
+ if ( refaddr( $obj ) eq refaddr( $results[0] ) ) {
+ encode_error( sprintf(
+ "%s::FREEZE method returned same object as was passed instead of a new one",
+ ref $obj
+ ) );
+ }
+ }
+ return '("'.$obj_class.'")['.join(',', @results).']';
+ }
+
if ( $convert_blessed and $obj->can('TO_JSON') ) {
my $result = $obj->TO_JSON();
if ( defined $result and ref( $result ) ) {
@@ -62682,8 +44587,7 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
return $self->blessed_to_json($obj) if ($as_nonblessed); # will be removed.
return 'null';
}
- encode_error( sprintf("encountered object '%s', but neither allow_blessed "
- . "nor convert_blessed settings are enabled", $obj)
+ encode_error( sprintf("encountered object '%s', but neither allow_blessed, convert_blessed nor allow_tags settings are enabled (or TO_JSON/FREEZE method missing)", $obj)
);
}
else {
@@ -62750,6 +44654,8 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
return;
} else {
no warnings 'numeric';
+ # if the utf8 flag is on, it almost certainly started as a string
+ return if utf8::is_utf8($value);
# detect numbers
# string & "" -> ""
# number & "" -> 0 (with warning)
@@ -62984,6 +44890,10 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
my $singlequote; # loosely quoting
my $loose; #
my $allow_barekey; # bareKey
+ my $allow_tags;
+
+ my $alt_true;
+ my $alt_false;
sub _detect_utf_encoding {
my $text = shift;
@@ -63010,8 +44920,10 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
my $props = $self->{PROPS};
- ($utf8, $relaxed, $loose, $allow_bignum, $allow_barekey, $singlequote)
- = @{$props}[P_UTF8, P_RELAXED, P_LOOSE .. P_ALLOW_SINGLEQUOTE];
+ ($utf8, $relaxed, $loose, $allow_bignum, $allow_barekey, $singlequote, $allow_tags)
+ = @{$props}[P_UTF8, P_RELAXED, P_LOOSE .. P_ALLOW_SINGLEQUOTE, P_ALLOW_TAGS];
+
+ ($alt_true, $alt_false) = @$self{qw/true false/};
if ( $utf8 ) {
$encoding = _detect_utf_encoding($text);
@@ -63078,6 +44990,7 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
return if(!defined $ch);
return object() if($ch eq '{');
return array() if($ch eq '[');
+ return tag() if($ch eq '(');
return string() if($ch eq '"' or ($singlequote and $ch eq "'"));
return number() if($ch =~ /[0-9]/ or $ch eq '-');
return word();
@@ -63173,8 +45086,10 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
if (!$loose) {
if ($ch =~ /[\x00-\x1f\x22\x5c]/) { # '/' ok
- $at--;
- decode_error('invalid character encountered while parsing JSON string');
+ if (!$relaxed or $ch ne "\t") {
+ $at--;
+ decode_error('invalid character encountered while parsing JSON string');
+ }
}
}
@@ -63287,6 +45202,35 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
decode_error(", or ] expected while parsing array");
}
+ sub tag {
+ decode_error('malformed JSON string, neither array, object, number, string or atom') unless $allow_tags;
+
+ next_chr();
+ white();
+
+ my $tag = value();
+ return unless defined $tag;
+ decode_error('malformed JSON string, (tag) must be a string') if ref $tag;
+
+ white();
+
+ if (!defined $ch or $ch ne ')') {
+ decode_error(') expected after tag');
+ }
+
+ next_chr();
+ white();
+
+ my $val = value();
+ return unless defined $val;
+ decode_error('malformed JSON string, tag value must be an array') unless ref $val eq 'ARRAY';
+
+ if (!eval { $tag->can('THAW') }) {
+ decode_error('cannot decode perl-object (package does not exist)') if $@;
+ decode_error('cannot decode perl-object (package does not have a THAW method)');
+ }
+ $tag->THAW('JSON', @$val);
+ }
sub object {
my $o = $_[0] || {}; # you can use this code to use another hash ref object.
@@ -63371,7 +45315,7 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
if($word eq 'true'){
$at += 3;
next_chr;
- return $JSON::PP::true;
+ return defined $alt_true ? $alt_true : $JSON::PP::true;
}
elsif($word eq 'null'){
$at += 3;
@@ -63383,7 +45327,7 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
if(substr($text,$at,1) eq 'e'){
$at++;
next_chr;
- return $JSON::PP::false;
+ return defined $alt_false ? $alt_false : $JSON::PP::false;
}
}
@@ -63566,18 +45510,27 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
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) {
+ if (@val == 0) {
+ return $o;
+ }
+ elsif (@val == 1) {
return $val[0];
}
+ else {
+ Carp::croak("filter_json_single_key_object callbacks must not return more than one scalar");
+ }
}
my @val = $cb_object->($o) if ($cb_object);
- if (@val == 0 or @val > 1) {
+ if (@val == 0) {
return $o;
}
- else {
+ elsif (@val == 1) {
return $val[0];
}
+ else {
+ Carp::croak("filter_json_object callbacks must not return more than one scalar");
+ }
}
@@ -63739,7 +45692,7 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
$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 is_bool { blessed $_[0] and ( $_[0]->isa("JSON::PP::Boolean") or $_[0]->isa("Types::Serialiser::BooleanBase") or $_[0]->isa("JSON::XS::Boolean") ); }
sub true { $JSON::PP::true }
sub false { $JSON::PP::false }
@@ -63757,6 +45710,8 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
use constant INCR_M_JSON => 3; # outside anything, count nesting
use constant INCR_M_C0 => 4;
use constant INCR_M_C1 => 5;
+ use constant INCR_M_TFN => 6;
+ use constant INCR_M_NUM => 7;
$JSON::PP::IncrParser::VERSION = '1.01';
@@ -63822,7 +45777,7 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
return @ret;
}
else { # in scalar context
- return $ret[0] ? $ret[0] : undef;
+ return defined $ret[0] ? $ret[0] : undef;
}
}
}
@@ -63870,6 +45825,28 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
$p++;
}
next;
+ } elsif ( $mode == INCR_M_TFN ) {
+ while ( $len > $p ) {
+ $s = substr( $text, $p++, 1 );
+ next if defined $s and $s =~ /[rueals]/;
+ last;
+ }
+ $p--;
+ $self->{incr_mode} = INCR_M_JSON;
+
+ last INCR_PARSE unless $self->{incr_nest};
+ redo INCR_PARSE;
+ } elsif ( $mode == INCR_M_NUM ) {
+ while ( $len > $p ) {
+ $s = substr( $text, $p++, 1 );
+ next if defined $s and $s =~ /[0-9eE.+\-]/;
+ last;
+ }
+ $p--;
+ $self->{incr_mode} = INCR_M_JSON;
+
+ last INCR_PARSE unless $self->{incr_nest};
+ redo INCR_PARSE;
} elsif ( $mode == INCR_M_STR ) {
while ( $len > $p ) {
$s = substr( $text, $p, 1 );
@@ -63902,6 +45879,12 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
last INCR_PARSE;
}
next;
+ } elsif ( $s eq 't' or $s eq 'f' or $s eq 'n' ) {
+ $self->{incr_mode} = INCR_M_TFN;
+ redo INCR_PARSE;
+ } elsif ( $s =~ /^[0-9\-]$/ ) {
+ $self->{incr_mode} = INCR_M_NUM;
+ redo INCR_PARSE;
} elsif ( $s eq '"' ) {
$self->{incr_mode} = INCR_M_STR;
redo INCR_PARSE;
@@ -63988,20 +45971,18 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
=head1 VERSION
- 2.91_04
+ 4.02
=head1 DESCRIPTION
- JSON::PP is a pure perl JSON decoder/encoder (as of RFC4627, which
- we know is obsolete but we still stick to; see below for an option
- to support part of RFC7159), and (almost) compatible to much
+ JSON::PP is a pure perl JSON decoder/encoder, and (almost) compatible to much
faster L<JSON::XS> written by Marc Lehmann in C. JSON::PP works as
a fallback module when you use L<JSON> module without having
installed JSON::XS.
Because of this fallback feature of JSON.pm, JSON::PP tries not to
be more JavaScript-friendly than JSON::XS (i.e. not to escape extra
- characters such as U+2028 and U+2029 nor support RFC7159/ECMA-404),
+ characters such as U+2028 and U+2029, etc),
in order for you not to lose such JavaScript-friendliness silently
when you use JSON.pm and install JSON::XS for speed or by accident.
If you need JavaScript-friendly RFC7159-compliant pure perl module,
@@ -64066,7 +46047,9 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
$json = JSON::PP->new
Creates a new JSON::PP object that can be used to de/encode JSON
- strings. All boolean flags described below are by default I<disabled>.
+ strings. All boolean flags described below are by default I<disabled>
+ (with the exception of C<allow_nonref>, which defaults to I<enabled> since
+ version C<4.0>).
The mutators for flags all return the JSON::PP object again and thus calls can
be chained:
@@ -64295,6 +46278,16 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
// neither this one...
]
+ =item * literal ASCII TAB characters in strings
+
+ Literal ASCII TAB characters are now allowed in strings (and treated as
+ C<\t>).
+
+ [
+ "Hello\tWorld",
+ "Hello<TAB>World", # literal <TAB> would not normally be allowed
+ ]
+
=back
=head2 canonical
@@ -64326,6 +46319,9 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
$enabled = $json->get_allow_nonref
+ Unlike other boolean options, this opotion is enabled by default beginning
+ with version C<4.0>.
+
If C<$enable> is true (or missing), then the C<encode> method can convert a
non-reference into its corresponding string, number or null JSON value,
which is an extension to RFC4627. Likewise, C<decode> will accept those JSON
@@ -64336,15 +46332,15 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
or array. Likewise, C<decode> will croak if given something that is not a
JSON object or array.
- Example, encode a Perl scalar as JSON value with enabled C<allow_nonref>,
- resulting in an invalid JSON text:
+ Example, encode a Perl scalar as JSON value without enabled C<allow_nonref>,
+ resulting in an error:
- JSON::PP->new->allow_nonref->encode ("Hello, World!")
- => "Hello, World!"
+ JSON::PP->new->allow_nonref(0)->encode ("Hello, World!")
+ => hash- or arrayref expected...
=head2 allow_unknown
- $json = $json->allow_unknown ([$enable])
+ $json = $json->allow_unknown([$enable])
$enabled = $json->get_allow_unknown
@@ -64404,18 +46400,66 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
This setting has no effect on C<decode>.
+ =head2 allow_tags
+
+ $json = $json->allow_tags([$enable])
+
+ $enabled = $json->get_allow_tags
+
+ See L<OBJECT SERIALISATION> for details.
+
+ If C<$enable> is true (or missing), then C<encode>, upon encountering a
+ blessed object, will check for the availability of the C<FREEZE> method on
+ the object's class. If found, it will be used to serialise the object into
+ a nonstandard tagged JSON value (that JSON decoders cannot decode).
+
+ It also causes C<decode> to parse such tagged JSON values and deserialise
+ them via a call to the C<THAW> method.
+
+ If C<$enable> is false (the default), then C<encode> will not consider
+ this type of conversion, and tagged JSON values will cause a parse error
+ in C<decode>, as if tags were not part of the grammar.
+
+ =head2 boolean_values
+
+ $json->boolean_values([$false, $true])
+
+ ($false, $true) = $json->get_boolean_values
+
+ By default, JSON booleans will be decoded as overloaded
+ C<$JSON::PP::false> and C<$JSON::PP::true> objects.
+
+ With this method you can specify your own boolean values for decoding -
+ on decode, JSON C<false> will be decoded as a copy of C<$false>, and JSON
+ C<true> will be decoded as C<$true> ("copy" here is the same thing as
+ assigning a value to another variable, i.e. C<$copy = $false>).
+
+ This is useful when you want to pass a decoded data structure directly
+ to other serialisers like YAML, Data::MessagePack and so on.
+
+ Note that this works only when you C<decode>. You can set incompatible
+ boolean objects (like L<boolean>), but when you C<encode> a data structure
+ with such boolean objects, you still need to enable C<convert_blessed>
+ (and add a C<TO_JSON> method if necessary).
+
+ Calling this method without any arguments will reset the booleans
+ to their default values.
+
+ C<get_boolean_values> will return both C<$false> and C<$true> values, or
+ the empty list when they are set to the default.
+
=head2 filter_json_object
$json = $json->filter_json_object([$coderef])
When C<$coderef> is specified, it will be called from C<decode> each
- time it decodes a JSON object. The only argument 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<not> C<undef>, which is a valid scalar), the
- original deserialised hash will be inserted. This setting can slow down
- decoding considerably.
+ time it decodes a JSON object. The only argument is a reference to
+ the newly-created hash. If the code references returns a single scalar
+ (which need not be a reference), this value (or rather a copy of it) is
+ inserted into the deserialised data structure. If it returns an empty
+ list (NOTE: I<not> C<undef>, 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<decode> will not change the deserialised hash in any
@@ -64423,12 +46467,11 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
Example, convert all JSON objects into the integer 5:
- my $js = JSON::PP->new->filter_json_object (sub { 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}');
+ $js->decode('[{}]');
+ # returns 5
+ $js->decode('{"a":1, "b":2}');
=head2 filter_json_single_key_object
@@ -64573,8 +46616,10 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
The following flags and properties are for JSON::PP only. If you use
any of these, you can't make your application run faster by replacing
JSON::PP with JSON::XS. If you need these and also speed boost,
- try L<Cpanel::JSON::XS>, a fork of JSON::XS by Reini Urban, which
- supports some of these.
+ you might want to try L<Cpanel::JSON::XS>, a fork of JSON::XS by
+ Reini Urban, which supports some of these (with a different set of
+ incompatibilities). Most of these historical flags are only kept
+ for backward compatibility, and should not be used in a new application.
=head2 allow_singlequote
@@ -64583,7 +46628,7 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
If C<$enable> is true (or missing), then C<decode> will accept
invalid JSON texts that contain strings that begin and end with
- single quotation marks. C<encode> will not be affected in anyway.
+ single quotation marks. C<encode> will not be affected in any way.
I<Be aware that this option makes you accept invalid JSON texts
as if they were valid!>. I suggest only to use this option to
parse application-specific files written by humans (configuration
@@ -64604,7 +46649,7 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
If C<$enable> is true (or missing), then C<decode> will accept
invalid JSON texts that contain JSON objects whose names don't
begin and end with quotation marks. C<encode> will not be affected
- in anyway. I<Be aware that this option makes you accept invalid JSON
+ in any way. I<Be aware that this option makes you accept invalid JSON
texts as if they were valid!>. I suggest only to use this option to
parse application-specific files written by humans (configuration
files, resource files etc.)
@@ -64639,7 +46684,7 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
If C<$enable> is true (or missing), then C<decode> will accept
invalid JSON texts that contain unescaped [\x00-\x1f\x22\x5c]
- characters. C<encode> will not be affected in anyway.
+ characters. C<encode> will not be affected in any way.
I<Be aware that this option makes you accept invalid JSON texts
as if they were valid!>. I suggest only to use this option to
parse application-specific files written by humans (configuration
@@ -64666,7 +46711,7 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
interpolation) is risky in general. You must escape necessary
characters in correct order, depending on the context.
- C<decode> will not be affected in anyway.
+ C<decode> will not be affected in any way.
=head2 indent_length
@@ -64909,6 +46954,15 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
C<relaxed> setting, shell-style comments are allowed. They can start
anywhere outside strings and go till the end of the line.
+ =item tagged values (C<< (I<tag>)I<value> >>).
+
+ Another nonstandard extension to the JSON syntax, enabled with the
+ C<allow_tags> setting, are tagged values. In this implementation, the
+ I<tag> must be a perl package/class name encoded as a JSON string, and the
+ I<value> must be a JSON array encoding optional constructor arguments.
+
+ See L<OBJECT SERIALISATION>, below, for details.
+
=back
@@ -64979,7 +47033,7 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
# undef becomes null
encode_json [undef] # yields [null]
- You can force the type to be a string by stringifying it:
+ You can force the type to be a JSON string by stringifying it:
my $x = 3.1; # some variable containing a number
"$x"; # stringified
@@ -64987,13 +47041,23 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
print $x; # perl does it for you, too, quite often
# (but for older perls)
- You can force the type to be a number by numifying it:
+ You can force the type to be a JSON 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 cannot currently force the type in other, less obscure, ways.
+ You can not currently force the type in other, less obscure, ways.
+
+ Since version 2.91_01, JSON::PP uses a different number detection logic
+ that converts a scalar that is possible to turn into a number safely.
+ The new logic is slightly faster, and tends to help people who use older
+ perl or who want to encode complicated data structure. However, this may
+ results in a different JSON text from the one JSON::XS encodes (and
+ thus may break tests that compare entire JSON texts). If you do
+ need the previous behavior for compatibility or for finer control,
+ set PERL_JSON_PP_USE_B environmental variable to true before you
+ C<use> JSON::PP (or JSON.pm).
Note that numerical precision has the same meaning as under Perl (so
binary to decimal conversion follows the same rules as in Perl, which
@@ -65020,17 +47084,50 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
=head2 OBJECT SERIALISATION
- As for Perl objects, JSON::PP only supports a pure JSON representation (without the ability to deserialise the object automatically again).
+ As JSON cannot directly represent Perl objects, you have to choose between
+ a pure JSON representation (without the ability to deserialise the object
+ automatically again), and a nonstandard extension to the JSON syntax,
+ tagged values.
=head3 SERIALISATION
What happens when C<JSON::PP> encounters a Perl object depends on the
- C<allow_blessed>, C<convert_blessed> and C<allow_bignum> settings, which are
- used in this order:
+ C<allow_blessed>, C<convert_blessed>, C<allow_tags> and C<allow_bignum>
+ settings, which are used in this order:
=over 4
- =item 1. C<convert_blessed> is enabled and the object has a C<TO_JSON> method.
+ =item 1. C<allow_tags> is enabled and the object has a C<FREEZE> method.
+
+ In this case, C<JSON::PP> creates a tagged JSON value, using a nonstandard
+ extension to the JSON syntax.
+
+ This works by invoking the C<FREEZE> method on the object, with the first
+ argument being the object to serialise, and the second argument being the
+ constant string C<JSON> to distinguish it from other serialisers.
+
+ The C<FREEZE> method can return any number of values (i.e. zero or
+ more). These values and the paclkage/classname of the object will then be
+ encoded as a tagged JSON value in the following format:
+
+ ("classname")[FREEZE return values...]
+
+ e.g.:
+
+ ("URI")["http://www.google.com/"]
+ ("MyDate")[2013,10,29]
+ ("ImageData::JPEG")["Z3...VlCg=="]
+
+ For example, the hypothetical C<My::Object> C<FREEZE> method might use the
+ objects C<type> and C<id> members to encode the object:
+
+ sub My::Object::FREEZE {
+ my ($self, $serialiser) = @_;
+
+ ($self->{type}, $self->{id})
+ }
+
+ =item 2. C<convert_blessed> is enabled and the object has a C<TO_JSON> method.
In this case, the C<TO_JSON> method of the object is invoked in scalar
context. It must return a single scalar that can be directly encoded into
@@ -65045,21 +47142,58 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
$uri->as_string
}
- =item 2. C<allow_bignum> is enabled and the object is a C<Math::BigInt> or C<Math::BigFloat>.
+ =item 3. C<allow_bignum> is enabled and the object is a C<Math::BigInt> or C<Math::BigFloat>.
The object will be serialised as a JSON number value.
- =item 3. C<allow_blessed> is enabled.
+ =item 4. C<allow_blessed> is enabled.
The object will be serialised as a JSON null value.
- =item 4. none of the above
+ =item 5. none of the above
If none of the settings are enabled or the respective methods are missing,
C<JSON::PP> throws an exception.
=back
+ =head3 DESERIALISATION
+
+ For deserialisation there are only two cases to consider: either
+ nonstandard tagging was used, in which case C<allow_tags> decides,
+ or objects cannot be automatically be deserialised, in which
+ case you can use postprocessing or the C<filter_json_object> or
+ C<filter_json_single_key_object> callbacks to get some real objects our of
+ your JSON.
+
+ This section only considers the tagged value case: a tagged JSON object
+ is encountered during decoding and C<allow_tags> is disabled, a parse
+ error will result (as if tagged values were not part of the grammar).
+
+ If C<allow_tags> is enabled, C<JSON::PP> will look up the C<THAW> method
+ of the package/classname used during serialisation (it will not attempt
+ to load the package as a Perl module). If there is no such method, the
+ decoding will fail with an error.
+
+ Otherwise, the C<THAW> method is invoked with the classname as first
+ argument, the constant string C<JSON> as second argument, and all the
+ values from the JSON array (the values originally returned by the
+ C<FREEZE> method) as remaining arguments.
+
+ The method must then return the object. While technically you can return
+ any Perl scalar, you might have to enable the C<allow_nonref> setting to
+ make that work in all cases, so better return an actual blessed reference.
+
+ As an example, let's implement a C<THAW> function that regenerates the
+ C<My::Object> from the C<FREEZE> example earlier:
+
+ sub My::Object::THAW {
+ my ($class, $serialiser, $type, $id) = @_;
+
+ $class->new (type => $type, id => $id)
+ }
+
+
=head1 ENCODING/CODESET FLAG NOTES
This section is taken from JSON::XS.
@@ -65159,6 +47293,23 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
=back
+ =head1 BUGS
+
+ Please report bugs on a specific behavior of this module to RT or GitHub
+ issues (preferred):
+
+ L<https://github.com/makamaka/JSON-PP/issues>
+
+ L<https://rt.cpan.org/Public/Dist/Display.html?Queue=JSON-PP>
+
+ As for new features and requests to change common behaviors, please
+ ask the author of JSON::XS (Marc Lehmann, E<lt>schmorp[at]schmorp.deE<gt>)
+ first, by email (important!), to keep compatibility among JSON.pm backends.
+
+ Generally speaking, if you need something special for you, you are advised
+ to create a new module, maybe based on L<JSON::Tiny>, which is smaller and
+ written in a much cleaner way than this module.
+
=head1 SEE ALSO
The F<json_pp> command line utility for quick experiments.
@@ -65170,15 +47321,24 @@ $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP
RFC4627 (L<http://www.ietf.org/rfc/rfc4627.txt>)
+ RFC7159 (L<http://www.ietf.org/rfc/rfc7159.txt>)
+
+ RFC8259 (L<http://www.ietf.org/rfc/rfc8259.txt>)
+
=head1 AUTHOR
Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
+ =head1 CURRENT MAINTAINER
+
+ Kenichi Ishigaki, E<lt>ishigaki[at]cpan.orgE<gt>
=head1 COPYRIGHT AND LICENSE
Copyright 2007-2016 by Makamaka Hannyaharamitu
+ Most of the documentation is taken from JSON::XS by Marc Lehmann
+
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
@@ -65189,14 +47349,16 @@ $fatpacked{"JSON/PP/Boolean.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
package JSON::PP::Boolean;
use strict;
- use overload (
+ require overload;
+ local $^W;
+ overload::import('overload',
"0+" => sub { ${$_[0]} },
"++" => sub { $_[0] = ${$_[0]} + 1 },
"--" => sub { $_[0] = ${$_[0]} - 1 },
fallback => 1,
);
- $JSON::PP::Boolean::VERSION = '2.94';
+ $JSON::PP::Boolean::VERSION = '4.02';
1;
@@ -65219,3215 +47381,3588 @@ $fatpacked{"JSON/PP/Boolean.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
This idea is from L<JSON::XS::Boolean> written by Marc Lehmann <schmorp[at]schmorp.de>
+ =head1 LICENSE
+
+ This library is free software; you can redistribute it and/or modify
+ it under the same terms as Perl itself.
+
=cut
JSON_PP_BOOLEAN
-$fatpacked{"JSON/backportPP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_BACKPORTPP';
- package # This is JSON::backportPP
- JSON::PP;
+$fatpacked{"Menlo.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MENLO';
+ package Menlo;
+ our $VERSION = "1.9019";
- # JSON-2.0
+ 1;
- use 5.005;
- use strict;
+ __END__
- use Exporter ();
- BEGIN { @JSON::backportPP::ISA = ('Exporter') }
+ =encoding utf8
- use overload ();
- use JSON::backportPP::Boolean;
+ =head1 NAME
- use Carp ();
- #use Devel::Peek;
+ Menlo - A CPAN client
- $JSON::backportPP::VERSION = '2.94';
+ =head1 DESCRIPTION
- @JSON::PP::EXPORT = qw(encode_json decode_json from_json to_json);
+ Menlo is a backend for I<cpanm 2.0>, developed with the goal to
+ replace L<cpanm> internals with a set of modules that are more
+ flexible, extensible and easier to use.
- # 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.
+ =head1 COMPATIBILITY
- 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;
+ Menlo is developed within L<cpanminus> git repository at C<Menlo>
+ subdirectory at L<https://github.com/miyagawa/cpanminus>
- 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;
+ Menlo::CLI::Compat started off as a copy of App::cpanminus::script,
+ but will go under a big refactoring to extract all the bits out of
+ it. Hopefully the end result will be just a shim and translation layer
+ to interpret command line options.
- use constant P_ALLOW_UNKNOWN => 18;
+ =head1 MOTIVATION
- use constant OLD_PERL => $] < 5.008 ? 1 : 0;
- use constant USE_B => 0;
+ cpanm has been a popular choice of CPAN package installer for many
+ developers, because it is lightweight, fast, and requires no
+ configuration in most environments.
- BEGIN {
- if (USE_B) {
- require B;
- }
- }
+ Meanwhile, the way cpanm has been implemented (one God class, and all
+ modules are packaged in one script with fatpacker) makes it difficult
+ to extend, or modify the behaviors at a runtime, unless you decide to
+ fork the code or monkeypatch its hidden backend class.
- 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 enabled?
- # Helper module sets @JSON::PP::_properties.
- if ( OLD_PERL ) {
- 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 $property_id = 'P_' . uc($name);
+ cpanm also has no scriptable API or hook points, which means if you
+ want to write a tool that works with cpanm, you basically have to work
+ around its behavior by writing a shell wrapper, or parsing the output
+ of its standard out or a build log file.
- eval qq/
- sub $name {
- my \$enable = defined \$_[1] ? \$_[1] : 1;
+ Menlo will keep the best aspects of cpanm, which is dependencies free,
+ configuration free, lightweight and fast to install CPAN modules. At
+ the same time, it's impelmented as a standard perl module, available
+ on CPAN, and you can extend its behavior by either using its modular
+ interfaces, or writing plugins to hook into its behaviors.
- if (\$enable) {
- \$_[0]->{PROPS}->[$property_id] = 1;
- }
- else {
- \$_[0]->{PROPS}->[$property_id] = 0;
- }
+ =head1 FAQ
- \$_[0];
- }
+ =over 4
- sub get_$name {
- \$_[0]->{PROPS}->[$property_id] ? 1 : '';
- }
- /;
- }
+ =item Dependencies free? I see many prerequisites in Menlo.
- }
+ Menlo is a set of libraries and uses non-core CPAN modules as its
+ dependencies. App-cpanminus distribution embeds Menlo and all of its
+ runtime dependencies into a fatpacked binary, so that you can install
+ App-cpanminus or Menlo without having any CPAN client to begin with.
+ =item Is Menlo a new name for cpanm?
+ Right now it's just a library name, but I'm comfortable calling this a
+ new package name for cpanm 2's backend.
- # Functions
+ =back
- my $JSON; # cache
+ =head1 AUTHOR
- sub encode_json ($) { # encode
- ($JSON ||= __PACKAGE__->new->utf8)->encode(@_);
- }
+ Tatsuhiko Miyagawa E<lt>miyagawa@bulknews.netE<gt>
+ =head1 COPYRIGHT
- sub decode_json { # decode
- ($JSON ||= __PACKAGE__->new->utf8)->decode(@_);
- }
+ 2010- Tatsuhiko Miyagawa
- # Obsoleted
+ =head1 LICENSE
- sub to_json($) {
- Carp::croak ("JSON::PP::to_json has been renamed to encode_json.");
- }
+ This software is licensed under the same terms as Perl.
+ =head1 SEE ALSO
- sub from_json($) {
- Carp::croak ("JSON::PP::from_json has been renamed to decode_json.");
- }
+ L<cpanm>
+ =cut
+MENLO
+
+$fatpacked{"Menlo/Builder/Static.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MENLO_BUILDER_STATIC';
+ package Menlo::Builder::Static;
+ use strict;
+ use warnings;
- # Methods
+ use CPAN::Meta;
+ use ExtUtils::Config 0.003;
+ use ExtUtils::Helpers 0.020 qw/make_executable split_like_shell man1_pagename man3_pagename detildefy/;
+ use ExtUtils::Install qw/pm_to_blib install/;
+ use ExtUtils::InstallPaths 0.002;
+ use File::Basename qw/dirname/;
+ use File::Find ();
+ use File::Path qw/mkpath/;
+ use File::Spec::Functions qw/catfile catdir rel2abs abs2rel splitdir curdir/;
+ use Getopt::Long 2.36 qw/GetOptionsFromArray/;
sub new {
- my $class = shift;
- my $self = {
- max_depth => 512,
- max_size => 0,
- indent_length => 3,
- };
-
- bless $self, $class;
+ my($class, %args) = @_;
+ bless {
+ meta => $args{meta},
+ }, $class;
}
-
- sub encode {
- return $_[0]->PP_encode_json($_[1]);
+ sub meta {
+ my $self = shift;
+ $self->{meta};
}
-
- sub decode {
- return $_[0]->PP_decode_json($_[1], 0x00000000);
+ sub manify {
+ my ($input_file, $output_file, $section, $opts) = @_;
+ return if -e $output_file && -M $input_file <= -M $output_file;
+ my $dirname = dirname($output_file);
+ mkpath($dirname, $opts->{verbose}) if not -d $dirname;
+ require Pod::Man;
+ Pod::Man->new(section => $section)->parse_from_file($input_file, $output_file);
+ print "Manifying $output_file\n" if $opts->{verbose} && $opts->{verbose} > 0;
+ return;
}
+ sub find {
+ my ($pattern, $dir) = @_;
+ my @ret;
+ File::Find::find(sub { push @ret, $File::Find::name if /$pattern/ && -f }, $dir) if -d $dir;
+ return @ret;
+ }
+
+ my %actions = (
+ build => sub {
+ my %opt = @_;
+ my %modules = map { $_ => catfile('blib', $_) } find(qr/\.p(?:m|od)$/, 'lib');
+ my %scripts = map { $_ => catfile('blib', $_) } find(qr//, 'script');
+ my %shared = map { $_ => catfile(qw/blib lib auto share dist/, $opt{meta}->name, abs2rel($_, 'share')) } find(qr//, 'share');
+ pm_to_blib({ %modules, %scripts, %shared }, catdir(qw/blib lib auto/));
+ make_executable($_) for values %scripts;
+ mkpath(catdir(qw/blib arch/), $opt{verbose});
+
+ if ($opt{install_paths}->install_destination('bindoc') && $opt{install_paths}->is_default_installable('bindoc')) {
+ manify($_, catfile('blib', 'bindoc', man1_pagename($_)), $opt{config}->get('man1ext'), \%opt) for keys %scripts;
+ }
+ if ($opt{install_paths}->install_destination('libdoc') && $opt{install_paths}->is_default_installable('libdoc')) {
+ manify($_, catfile('blib', 'libdoc', man3_pagename($_)), $opt{config}->get('man3ext'), \%opt) for keys %modules;
+ }
+ 1;
+ },
+ test => sub {
+ my %opt = @_;
+ die "Must run `./Build build` first\n" if not -d 'blib';
+ require TAP::Harness::Env;
+ my %test_args = (
+ (verbosity => $opt{verbose}) x!! exists $opt{verbose},
+ (jobs => $opt{jobs}) x!! exists $opt{jobs},
+ (color => 1) x !!-t STDOUT,
+ lib => [ map { rel2abs(catdir(qw/blib/, $_)) } qw/arch lib/ ],
+ );
+ my $tester = TAP::Harness::Env->create(\%test_args);
+ $tester->runtests(sort +find(qr/\.t$/, 't'))->has_errors and return;
+ 1;
+ },
+ install => sub {
+ my %opt = @_;
+ die "Must run `./Build build` first\n" if not -d 'blib';
+ install($opt{install_paths}->install_map, @opt{qw/verbose dry_run uninst/});
+ 1;
+ },
+ );
- sub decode_prefix {
- return $_[0]->PP_decode_json($_[1], 0x00000001);
+ sub build {
+ my $self = shift;
+ my $action = @_ && $_[0] =~ /\A\w+\z/ ? shift @_ : 'build';
+ die "No such action '$action'\n" if not $actions{$action};
+ my %opt;
+ GetOptionsFromArray([@$_], \%opt, qw/install_base=s install_path=s% installdirs=s destdir=s prefix=s config=s% uninst:1 verbose:1 dry_run:1 pureperl-only:1 create_packlist=i jobs=i/) for ($self->{env}, $self->{configure_args}, \@_);
+ $_ = detildefy($_) for grep { defined } @opt{qw/install_base destdir prefix/}, values %{ $opt{install_path} };
+ @opt{ 'config', 'meta' } = (ExtUtils::Config->new($opt{config}), $self->meta);
+ $actions{$action}->(%opt, install_paths => ExtUtils::InstallPaths->new(%opt, dist_name => $opt{meta}->name));
}
+ sub configure {
+ my $self = shift;
+ $self->{env} = defined $ENV{PERL_MB_OPT} ? [split_like_shell($ENV{PERL_MB_OPT})] : [];
+ $self->{configure_args} = [@_];
+ $self->meta->save(@$_) for ['MYMETA.json'], [ 'MYMETA.yml' => { version => 1.4 } ];
+ }
- # accessor
+ 1;
+ =head1 COPYRIGHT AND LICENSE
- # pretty printing
+ This software is copyright (c) 2011 by Leon Timmermans, David Golden.
- sub pretty {
- my ($self, $v) = @_;
- my $enable = defined $v ? $v : 1;
+ This is free software; you can redistribute it and/or modify it under
+ the same terms as the Perl 5 programming language system itself.
- if ($enable) { # indent_length(3) for JSON::XS compatibility
- $self->indent(1)->space_before(1)->space_after(1);
- }
- else {
- $self->indent(0)->space_before(0)->space_after(0);
- }
+ =cut
+MENLO_BUILDER_STATIC
+
+$fatpacked{"Menlo/CLI/Compat.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MENLO_CLI_COMPAT';
+ package Menlo::CLI::Compat;
+ use strict;
+ use Config;
+ use Cwd ();
+ use Menlo;
+ use Menlo::Dependency;
+ use Menlo::Util qw(WIN32);
+ use File::Basename ();
+ use File::Find ();
+ use File::Path ();
+ use File::Spec ();
+ use File::Copy ();
+ use File::Temp ();
+ use File::Which qw(which);
+ use Getopt::Long ();
+ use Symbol ();
+ use version ();
- $self;
- }
+ use constant BAD_TAR => ($^O eq 'solaris' || $^O eq 'hpux');
+ use constant CAN_SYMLINK => eval { symlink("", ""); 1 };
- # etc
+ our $VERSION = '1.9022';
- sub max_depth {
- my $max = defined $_[1] ? $_[1] : 0x80000000;
- $_[0]->{max_depth} = $max;
- $_[0];
+ if ($INC{"App/FatPacker/Trace.pm"}) {
+ require version::vpp;
}
-
- sub get_max_depth { $_[0]->{max_depth}; }
-
-
- sub max_size {
- my $max = defined $_[1] ? $_[1] : 0;
- $_[0]->{max_size} = $max;
- $_[0];
+ sub qs($) {
+ Menlo::Util::shell_quote($_[0]);
}
+ sub determine_home {
+ my $class = shift;
- sub get_max_size { $_[0]->{max_size}; }
-
+ my $homedir = $ENV{HOME}
+ || eval { require File::HomeDir; File::HomeDir->my_home }
+ || join('', @ENV{qw(HOMEDRIVE HOMEPATH)}); # Win32
- sub filter_json_object {
- if (defined $_[1] and ref $_[1] eq 'CODE') {
- $_[0]->{cb_object} = $_[1];
- } else {
- delete $_[0]->{cb_object};
+ if (WIN32) {
+ require Win32; # no fatpack
+ $homedir = Win32::GetShortPathName($homedir);
}
- $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
- $_[0];
- }
- sub filter_json_single_key_object {
- if (@_ == 1 or @_ > 3) {
- Carp::croak("Usage: JSON::PP::filter_json_single_key_object(self, key, callback = undef)");
- }
- if (defined $_[2] and ref $_[2] eq 'CODE') {
- $_[0]->{cb_sk_object}->{$_[1]} = $_[2];
- } else {
- delete $_[0]->{cb_sk_object}->{$_[1]};
- delete $_[0]->{cb_sk_object} unless %{$_[0]->{cb_sk_object} || {}};
- }
- $_[0]->{F_HOOK} = ($_[0]->{cb_object} or $_[0]->{cb_sk_object}) ? 1 : 0;
- $_[0];
+ return "$homedir/.cpanm";
}
- 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 new {
+ my $class = shift;
- sub get_indent_length {
- $_[0]->{indent_length};
- }
+ my $self = bless {
+ name => "Menlo",
+ 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,
+ static_install => 1,
+ auto_cleanup => 7, # days
+ pod2man => 1,
+ installed_dists => 0,
+ install_types => ['requires'],
+ with_develop => 0,
+ with_configure => 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 sort_by {
- $_[0]->{sort_by} = defined $_[1] ? $_[1] : 1;
- $_[0];
+ $self;
}
- sub allow_bigint {
- Carp::carp("allow_bigint() is obsoleted. use allow_bignum() instead.");
- $_[0]->allow_bignum;
+ sub env {
+ my($self, $key) = @_;
+ $ENV{"PERL_CPANM_" . $key};
}
- ###############################
-
- ###
- ### 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 $props = $self->{PROPS};
-
- ($ascii, $latin1, $utf8, $indent, $canonical, $space_before, $space_after, $allow_blessed,
- $convert_blessed, $escape_slash, $bignum, $as_nonblessed)
- = @{$props}[P_ASCII .. P_SPACE_AFTER, P_ALLOW_BLESSED, P_CONVERT_BLESSED,
- P_ESCAPE_SLASH, P_ALLOW_BIGNUM, P_AS_NONBLESSED];
+ sub maybe_ci {
+ my $class = shift;
+ grep $ENV{$_}, qw( TRAVIS CI AUTOMATED_TESTING AUTHOR_TESTING );
+ }
- ($max_depth, $indent_length) = @{$self}{qw/max_depth indent_length/};
+ sub install_type_handlers {
+ my $self = shift;
- $keysort = $canonical ? sub { $a cmp $b } : undef;
+ 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}} ];
+ };
+ }
- 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 };
- }
+ @handlers;
+ }
- encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)")
- if(!ref $obj and !$props->[ P_ALLOW_NONREF ]);
+ sub build_args_handlers {
+ my $self = shift;
- my $str = $self->object_to_json($obj);
+ my @handlers;
+ for my $phase (qw( configure build test install )) {
+ push @handlers, "$phase-args=s" => \($self->{build_args}{$phase});
+ }
- $str .= "\n" if ( $indent ); # JSON::XS 2.26 compatible
+ @handlers;
+ }
- unless ($ascii or $latin1 or $utf8) {
- utf8::upgrade($str);
- }
+ sub parse_options {
+ my $self = shift;
- if ($props->[ P_SHRINK ]) {
- utf8::downgrade($str, 1);
- }
+ 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},
+ 'static-install!' => \$self->{static_install},
+ '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-configure' => \$self->{with_configure},
+ 'without-configure' => sub { $self->{with_configure} = 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,
+ );
- return $str;
+ 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 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)) {
+ 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 <<DIE;
+ It appears your cpanm executable was installed via `perlbrew install-cpanm`.
+ cpanm --self-upgrade won't upgrade the version of cpanm you're running.
- return $self->value_to_json($obj) if ( $obj->isa('JSON::PP::Boolean') );
+ Run the following command to get it upgraded.
- 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
- ) );
- }
- }
+ perlbrew install-cpanm
- return $self->object_to_json( $result );
- }
+ DIE
+ } else {
+ die <<DIE;
+ You are running cpanm from the path where your current perl won't install executables to.
+ Because of that, cpanm --self-upgrade won't upgrade the version of cpanm you're running.
- return "$obj" if ( $bignum and _is_bignum($obj) );
+ cpanm path : $0
+ Install path : $Config{installsitebin}
- if ($allow_blessed) {
- return $self->blessed_to_json($obj) if ($as_nonblessed); # will be removed.
- return 'null';
- }
- encode_error( sprintf("encountered object '%s', but neither allow_blessed "
- . "nor convert_blessed settings are enabled", $obj)
- );
- }
- else {
- return $self->value_to_json($obj);
- }
- }
- else{
- return $self->value_to_json($obj);
+ It means you either installed cpanm globally with system perl, or use distro packages such
+ as rpm or apt-get, and you have to use them again to upgrade cpanm.
+ DIE
}
}
+ }
+ sub check_libs {
+ my $self = shift;
+ return if $self->{_checked}++;
+ $self->bootstrap_local_lib;
+ }
- 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, $self->string_to_json( $k )
- . $del
- . ( ref $obj->{$k} ? $self->object_to_json( $obj->{$k} ) : $self->value_to_json( $obj->{$k} ) );
- }
+ sub setup_verify {
+ my $self = shift;
- --$depth;
- $self->_down_indent() if ($indent);
+ my $has_modules = eval { require Module::Signature; require Digest::SHA; 1 };
+ $self->{cpansign} = which('cpansign');
- return '{}' unless @res;
- return '{' . $pre . join( ",$pre", @res ) . $post . '}';
+ 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) = @_;
- 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, ref($v) ? $self->object_to_json($v) : $self->value_to_json($v);
- }
-
- --$depth;
- $self->_down_indent() if ($indent);
-
- return '[]' unless @res;
- return '[' . $pre . join( ",$pre", @res ) . $post . ']';
- }
+ # Plack@1.2 -> Plack~"==1.2"
+ # BUT don't expand @ in git URLs
+ $module =~ s/^([A-Za-z0-9_:]+)@([v\d\._]+)$/$1~== $2/;
- sub _looks_like_number {
- my $value = shift;
- if (USE_B) {
- my $b_obj = B::svref_2object(\$value);
- my $flags = $b_obj->FLAGS;
- return 1 if $flags & ( B::SVp_IOK() | B::SVp_NOK() ) and !( $flags & B::SVp_POK() );
- return;
- } else {
- no warnings 'numeric';
- # detect numbers
- # string & "" -> ""
- # number & "" -> 0 (with warning)
- # nan and inf can detect as numbers, so check with * 0
- return unless length((my $dummy = "") & $value);
- return unless 0 + $value eq $value;
- return 1 if $value * 0 == 0;
- return -1; # inf/nan
- }
+ # Plack~1.20, DBI~"> 1.0, <= 2.0"
+ if ($module =~ /\~[v\d\._,\!<>= ]+$/) {
+ return split '~', $module, 2;
+ } else {
+ return $module, undef;
}
+ }
- sub value_to_json {
- my ($self, $value) = @_;
+ sub run {
+ my $self = shift;
- return 'null' if(!defined $value);
+ my $code;
+ eval {
+ $code = ($self->_doit == 0);
+ }; if (my $e = $@) {
+ warn $e;
+ $code = 1;
+ }
- my $type = ref($value);
+ $self->{status} = $code;
+ }
- if (!$type) {
- if (_looks_like_number($value)) {
- return $value;
- }
- return $self->string_to_json($value);
- }
- elsif( blessed($value) and $value->isa('JSON::PP::Boolean') ){
- return $$value == 1 ? 'true' : 'false';
- }
- else {
- if ((overload::StrVal($value) =~ /=(\w+)/)[0]) {
- return $self->value_to_json("$value");
- }
+ sub status {
+ $_[0]->{status};
+ }
- 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");
- }
+ sub _doit {
+ my $self = shift;
- 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");
- }
- }
+ $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};
- my %esc = (
- "\n" => '\n',
- "\r" => '\r',
- "\t" => '\t',
- "\f" => '\f',
- "\b" => '\b',
- "\"" => '\"',
- "\\" => '\\\\',
- "\'" => '\\\'',
- );
-
-
- sub string_to_json {
- my ($self, $arg) = @_;
+ $self->configure_mirrors;
- $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);
- }
+ my $cwd = Cwd::cwd;
- if ($latin1) {
- $arg = JSON_PP_encode_latin1($arg);
+ 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);
- if ($utf8) {
- utf8::encode($arg);
+ $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;
}
-
- 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';
- }
+ if ($self->{base} && $self->{auto_cleanup}) {
+ $self->cleanup_workdirs;
}
-
- sub encode_error {
- my $error = shift;
- Carp::croak "$error";
+ if ($self->{installed_dists}) {
+ my $dists = $self->{installed_dists} > 1 ? "distributions" : "distribution";
+ $self->diag("$self->{installed_dists} $dists installed\n", 1);
}
-
- sub _sort {
- defined $keysort ? (sort $keysort (keys %{$_[0]})) : keys %{$_[0]};
+ 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 _up_indent {
- my $self = shift;
- my $space = ' ' x $indent_length;
-
- my ($pre,$post) = ('','');
-
- $post = "\n" . $space x $indent_count;
-
- $indent_count++;
+ sub setup_home {
+ my $self = shift;
- $pre = "\n" . $space x $indent_count;
+ $self->{home} = $self->env('HOME') if $self->env('HOME');
- return ($pre,$post);
+ 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);
- sub _down_indent { $indent_count--; }
+ # 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}: $!" }
- 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])
- );
- }
+ 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);
+ }
+ }
- sub _encode_latin1 {
- join('',
- map {
- $_ <= 255 ?
- chr($_) :
- $_ <= 65535 ?
- sprintf('\u%04x', $_) : sprintf('\u%x\u%x', _encode_surrogates($_));
- } unpack('U*', $_[0])
- );
+ $self->chat("cpanm ($self->{name}) $Menlo::VERSION on perl $] built for $Config{archname}\n" .
+ "Work directory is $self->{base}\n");
}
-
- sub _encode_surrogates { # from perlunicode
- my $uni = $_[0] - 0x10000;
- return ($uni / 0x400 + 0xD800, $uni % 0x400 + 0xDC00);
+ sub search_mirror_index_local {
+ my ($self, $local, $module, $version) = @_;
+ require CPAN::Common::Index::LocalPackage;
+ my $index = CPAN::Common::Index::LocalPackage->new({ source => $local });
+ $self->search_common($index, { package => $module }, $version);
}
-
- sub _is_bignum {
- $_[0]->isa('Math::BigInt') or $_[0]->isa('Math::BigFloat');
+ sub search_mirror_index {
+ my ($self, $mirror, $module, $version) = @_;
+ require Menlo::Index::Mirror;
+ my $index = Menlo::Index::Mirror->new({
+ mirror => $mirror,
+ cache => $self->source_for($mirror),
+ fetcher => sub { $self->mirror(@_) },
+ });
+ $self->search_common($index, { package => $module }, $version);
}
+ sub search_common {
+ my($self, $index, $search_args, $want_version) = @_;
+ $index->refresh_index;
- #
- # JSON => Perl
- #
+ my $found = $index->search_packages($search_args);
+ $found = $self->cpan_module_common($found) if $found;
- my $max_intsize;
+ return $found unless $self->{cascade_search};
- BEGIN {
- my $checkint = 1111;
- for my $d (5..64) {
- $checkint .= 1;
- my $int = eval qq| $checkint |;
- if ($int =~ /[eE]/) {
- $max_intsize = $d - 1;
- last;
+ if ($found) {
+ if ($self->satisfy_version($found->{module}, $found->{module_version}, $want_version)) {
+ return $found;
+ } else {
+ $self->chat("Found $found->{module} $found->{module_version} which doesn't satisfy $want_version.\n");
}
}
+
+ return;
}
- { # PARSE
-
- my %escapes = ( # by Jeremy Muhlich <jmuhlich [at] bitflood.org>
- b => "\x8",
- t => "\x9",
- n => "\xA",
- f => "\xC",
- r => "\xD",
- '\\' => '\\',
- '"' => '"',
- '/' => '/',
- );
-
- my $text; # json data
- my $at; # offset
- my $ch; # first character
- 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_bignum; # using Math::BigInt/BigFloat
- my $singlequote; # loosely quoting
- my $loose; #
- my $allow_barekey; # bareKey
+ sub with_version_range {
+ my($self, $version) = @_;
+ defined($version) && $version =~ /(?:<|!=|==)/;
+ }
- sub _detect_utf_encoding {
- my $text = shift;
- my @octets = unpack('C4', $text);
- return 'unknown' unless defined $octets[3];
- return ( $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';
- }
+ sub search_metacpan {
+ my($self, $module, $version, $dev_release) = @_;
- sub PP_decode_json {
- my ($self, $want_offset);
+ require Menlo::Index::MetaCPAN;
+ $self->chat("Searching $module ($version) on metacpan ...\n");
- ($self, $text, $want_offset) = @_;
+ my $index = Menlo::Index::MetaCPAN->new({ include_dev => $self->{dev_release} });
+ my $pkg = $self->search_common($index, { package => $module, version_range => $version }, $version);
+ return $pkg if $pkg;
- ($at, $ch, $depth) = (0, '', 0);
+ $self->diag_fail("Finding $module ($version) on metacpan failed.");
+ return;
+ }
- if ( !defined $text or ref $text ) {
- decode_error("malformed JSON string, neither array, object, number, string or atom");
- }
+ sub search_database {
+ my($self, $module, $version) = @_;
- my $props = $self->{PROPS};
+ my $found;
- ($utf8, $relaxed, $loose, $allow_bignum, $allow_barekey, $singlequote)
- = @{$props}[P_UTF8, P_RELAXED, P_LOOSE .. P_ALLOW_SINGLEQUOTE];
+ if ($self->{dev_release} or $self->{metacpan}) {
+ $found = $self->search_metacpan($module, $version, $self->{dev_release}) and return $found;
+ $found = $self->search_cpanmetadb($module, $version, $self->{dev_release}) and return $found;
+ } else {
+ $found = $self->search_cpanmetadb($module, $version) and return $found;
+ $found = $self->search_metacpan($module, $version) and return $found;
+ }
+ }
- if ( $utf8 ) {
- $encoding = _detect_utf_encoding($text);
- if ($encoding ne 'UTF-8' and $encoding ne 'unknown') {
- require Encode;
- Encode::from_to($text, $encoding, 'utf-8');
- } else {
- utf8::downgrade( $text, 1 ) or Carp::croak("Wide character in subroutine entry");
- }
- }
- else {
- utf8::upgrade( $text );
- utf8::encode( $text );
- }
+ sub search_cpanmetadb {
+ my($self, $module, $version, $dev_release) = @_;
- $len = length $text;
+ require Menlo::Index::MetaDB;
+ $self->chat("Searching $module ($version) on cpanmetadb ...\n");
- ($max_depth, $max_size, $cb_object, $cb_sk_object, $F_HOOK)
- = @{$self}{qw/max_depth max_size cb_object cb_sk_object F_HOOK/};
+ my $args = { package => $module };
+ if ($self->with_version_range($version)) {
+ $args->{version_range} = $version;
+ }
- if ($max_size > 1) {
- use bytes;
- my $bytes = length $text;
- decode_error(
- sprintf("attempted decode of JSON text of %s bytes size, but max_size is set to %s"
- , $bytes, $max_size), 1
- ) if ($bytes > $max_size);
- }
+ my $index = Menlo::Index::MetaDB->new({ uri => $self->{cpanmetadb} });
+ my $pkg = $self->search_common($index, $args, $version);
+ return $pkg if $pkg;
- white(); # remove head white space
+ $self->diag_fail("Finding $module on cpanmetadb failed.");
+ return;
+ }
- decode_error("malformed JSON string, neither array, object, number, string or atom") unless defined $ch; # Is there a first character for JSON structure?
+ sub search_module {
+ my($self, $module, $version) = @_;
- my $result = value();
+ if ($self->{mirror_index}) {
+ $self->mask_output( chat => "Searching $module on mirror index $self->{mirror_index} ...\n" );
+ my $pkg = $self->search_mirror_index_local($self->{mirror_index}, $module, $version);
+ return $pkg if $pkg;
- if ( !$props->[ 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);
+ unless ($self->{cascade_search}) {
+ $self->mask_output( diag_fail => "Finding $module ($version) on mirror index $self->{mirror_index} failed." );
+ return;
}
-
- 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
-
- return ( $result, $consumed ) if $want_offset; # all right if decode_prefix
-
- decode_error("garbage after JSON object") if defined $ch;
-
- $result;
}
-
- sub next_chr {
- return $ch = undef if($at >= $len);
- $ch = substr($text, $at++, 1);
+ 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" );
- 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 $utf16;
- my $is_utf8;
+ my $pkg = $self->search_mirror_index($mirror, $module, $version);
+ return $pkg if $pkg;
- ($is_valid_utf8, $utf8_len) = ('', 0);
+ $self->mask_output( diag_fail => "Finding $module ($version) on mirror $mirror failed." );
+ }
- my $s = ''; # basically UTF8 flag on
+ return;
+ }
- if($ch eq '"' or ($singlequote and $ch eq "'")){
- my $boundChar = $ch;
+ sub source_for {
+ my($self, $mirror) = @_;
+ $mirror =~ s/[^\w\.\-]+/%/g;
- OUTER: while( defined(next_chr()) ){
+ my $dir = "$self->{home}/sources/$mirror";
+ File::Path::mkpath([ $dir ], 0, 0777);
- if($ch eq $boundChar){
- next_chr();
+ return $dir;
+ }
- if ($utf16) {
- decode_error("missing low surrogate character in surrogate pair");
- }
+ sub load_argv_from_fh {
+ my($self, $fh) = @_;
- utf8::decode($s) if($is_utf8);
+ my @argv;
+ while(defined(my $line = <$fh>)){
+ chomp $line;
+ $line =~ s/#.+$//; # comment
+ $line =~ s/^\s+//; # trim spaces
+ $line =~ s/\s+$//; # trim spaces
- return $s;
- }
- elsif($ch eq '\\'){
- next_chr();
- if(exists $escapes{$ch}){
- $s .= $escapes{$ch};
- }
- elsif($ch eq 'u'){ # UNICODE handling
- my $u = '';
+ push @argv, split ' ', $line if $line;
+ }
+ return @argv;
+ }
- for(1..4){
- $ch = next_chr();
- last OUTER if($ch !~ /[0-9a-fA-F]/);
- $u .= $ch;
- }
+ sub show_version {
+ my $self = shift;
- # 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");
- }
+ print "cpanm ($self->{name}) version $VERSION ($0)\n";
+ print "perl version $] ($^X)\n\n";
- if ( ( my $hex = hex( $u ) ) > 127 ) {
- $is_utf8 = 1;
- $s .= JSON_PP_decode_unicode($u) || next;
- }
- else {
- $s .= chr $hex;
- }
- }
+ 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};
+ }
- }
- else{
- unless ($loose) {
- $at -= 2;
- decode_error('illegal backslash escape sequence in string');
- }
- $s .= $ch;
- }
- }
- else{
+ print " \%ENV:\n";
+ for my $key (grep /^PERL/, sort keys %ENV) {
+ print " $key=$ENV{$key}\n";
+ }
- 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;
- }
+ print " \@INC:\n";
+ for my $inc (@INC) {
+ print " $inc\n" unless ref($inc) eq 'CODE';
+ }
- $is_utf8 = 1;
- }
+ return 1;
+ }
- if (!$loose) {
- if ($ch =~ /[\x00-\x1f\x22\x5c]/) { # '/' ok
- $at--;
- decode_error('invalid character encountered while parsing JSON string');
- }
- }
+ sub show_help {
+ my $self = shift;
- $s .= $ch;
- }
- }
- }
+ if ($_[0]) {
+ print <<USAGE;
+ Usage: cpanm [options] Module [...]
- decode_error("unexpected end of string while parsing JSON string");
+ Try `cpanm --help` or `man cpanm` for more options.
+ USAGE
+ return;
}
+ print <<HELP;
+ Usage: cpanm [options] Module [...]
+
+ Options:
+ -v,--verbose Turns on chatty output
+ -q,--quiet Turns off the most output
+ --interactive Turns on interactive configure (required for Task:: modules)
+ -f,--force force install
+ -n,--notest Do not run unit tests
+ --test-only Run tests only, do not install
+ -S,--sudo sudo to run install commands
+ --installdeps Only install dependencies
+ --showdeps Only display direct dependencies
+ --reinstall Reinstall the distribution even if you already have the latest version installed
+ --mirror Specify the base URL for the mirror (e.g. http://cpan.cpantesters.org/)
+ --mirror-only Use the mirror's index file instead of the CPAN Meta DB
+ -M,--from Use only this mirror base URL and its index file
+ --prompt Prompt when configure/build/test fails
+ -l,--local-lib Specify the install base to install modules
+ -L,--local-lib-contained Specify the install base to install all non-core modules
+ --self-contained Install all non-core modules, even if they're already installed.
+ --auto-cleanup Number of days that cpanm's work directories expire in. Defaults to 7
+
+ Commands:
+ --self-upgrade upgrades itself
+ --info Displays distribution info on CPAN
+ --look Opens the distribution with your SHELL
+ -U,--uninstall Uninstalls the modules (EXPERIMENTAL)
+ -V,--version Displays software version
+
+ Examples:
+
+ 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 -M https://cpan.metacpan.org App::perlbrew # use only this secure mirror and its index
+
+ You can also specify the default options in PERL_CPANM_OPT environment variable in the shell rc:
+
+ export PERL_CPANM_OPT="--prompt --reinstall -l ~/perl --mirror http://cpan.cpantesters.org"
+
+ Type `man cpanm` or `perldoc cpanm` for the more detailed explanation of the options.
- sub white {
- while( defined $ch ){
- if($ch eq '' or $ch =~ /\A[ \t\r\n]\z/){
- next_chr();
- }
- elsif($relaxed and $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;
- }
+ HELP
- last;
- }
+ return 1;
+ }
+
+ sub _writable {
+ my $dir = shift;
+ my @dir = File::Spec->splitdir($dir);
+ while (@dir) {
+ $dir = File::Spec->catdir(@dir);
+ if (-e $dir) {
+ return -w _;
}
+ pop @dir;
}
+ return;
+ }
- sub 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();
+ 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));
+ }
+ }
- if(defined $ch and $ch eq ']'){
- --$depth;
- next_chr();
- return $a;
- }
- else {
- while(defined($ch)){
- push @$a, value();
+ 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];
+ }
- white();
+ sub bootstrap_local_lib {
+ my $self = shift;
- if (!defined $ch) {
- last;
- }
+ # If -l is specified, use that.
+ if ($self->{local_lib}) {
+ return $self->setup_local_lib($self->{local_lib});
+ }
- if($ch eq ']'){
- --$depth;
- next_chr();
- return $a;
- }
+ # 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);
+ }
- if($ch ne ','){
- last;
- }
+ # root, locally-installed perl or --sudo: don't care about install_base
+ return if $self->{sudo} or (_writable($Config{installsitelib}) and _writable($Config{installsitebin}));
- next_chr();
- white();
+ # local::lib is configured in the shell -- yay
+ if ($ENV{PERL_MM_OPT} and ($ENV{MODULEBUILDRC} or $ENV{PERL_MB_OPT})) {
+ return;
+ }
- if ($relaxed and $ch eq ']') {
- --$depth;
- next_chr();
- return $a;
- }
+ $self->setup_local_lib;
- }
- }
+ $self->diag(<<DIAG, 1);
+ !
+ ! Can't write to $Config{installsitelib} and $Config{installsitebin}: Installing modules to $ENV{HOME}/perl5
+ ! To turn off this warning, you have to do one of the following:
+ ! - run me as a root or with --sudo option (to install to $Config{installsitelib} and $Config{installsitebin})
+ ! - Configure local::lib in your existing shell to set PERL_MM_OPT etc.
+ ! - Install local::lib by running the following commands
+ !
+ ! cpanm --local-lib=~/perl5 local::lib && eval \$(perl -I ~/perl5/lib/perl5/ -Mlocal::lib)
+ !
+ DIAG
+ sleep 2;
+ }
+
+ sub upgrade_toolchain {
+ my($self, $config_deps) = @_;
+
+ my %deps = map { $_->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',
+ });
- $at-- if defined $ch and $ch ne '';
- decode_error(", or ] expected while parsing array");
+ if ($deps{"ExtUtils::MakeMaker"}) {
+ $deps{"ExtUtils::MakeMaker"}->merge_with($reqs);
+ } elsif ($deps{"Module::Build"}) {
+ $deps{"Module::Build"}->merge_with($reqs);
+ $deps{"ExtUtils::Install"} ||= Menlo::Dependency->new("ExtUtils::Install", 0, 'configure');
+ $deps{"ExtUtils::Install"}->merge_with($reqs);
}
+ @$config_deps = values %deps;
+ }
- 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();
+ 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)},
+ );
+ }
- if(!defined $ch or $ch ne ':'){
- $at--;
- decode_error("':' expected");
- }
+ sub _setup_local_lib_env {
+ my($self, $base) = @_;
- next_chr();
- $o->{$k} = value();
- white();
+ $self->diag(<<WARN, 1) if $base =~ /\s/;
+ WARNING: Your lib directory name ($base) contains a space in it. It's known to cause issues with perl builder tools such as local::lib and MakeMaker. You're recommended to rename your directory.
+ WARN
- last if (!defined $ch);
+ local $SIG{__WARN__} = sub { }; # catch 'Attempting to write ...'
+ local::lib->setup_env_hash_for($base, 0);
+ }
- if($ch eq '}'){
- --$depth;
- next_chr();
- if ($F_HOOK) {
- return _json_object_hook($o);
- }
- return $o;
- }
+ sub setup_local_lib {
+ my($self, $base, $no_env) = @_;
+ $base = undef if $base eq '_';
- if($ch ne ','){
- last;
- }
+ 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;
+ }
+ }
- next_chr();
- white();
+ sub prompt_bool {
+ my($self, $mess, $def) = @_;
- if ($relaxed and $ch eq '}') {
- --$depth;
- next_chr();
- if ($F_HOOK) {
- return _json_object_hook($o);
- }
- return $o;
- }
+ 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 : "";
- $at-- if defined $ch and $ch ne '';
- decode_error(", or } expected while parsing object/hash");
+ if (!$self->{prompt} || (!$isa_tty && eof STDIN)) {
+ return $def;
}
-
- 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;
+ local $|=1;
+ local $\;
+ my $ans;
+ eval {
+ local $SIG{ALRM} = sub { undef $ans; die "alarm\n" };
+ print STDOUT "$mess $dispdef";
+ alarm $self->{prompt_timeout} if $self->{prompt_timeout};
+ $ans = <STDIN>;
+ alarm 0;
+ };
+ if ( defined $ans ) {
+ chomp $ans;
+ } else { # user hit ctrl-D or alarm timeout
+ print STDOUT "\n";
}
+ return (!defined $ans || $ans eq '') ? $def : $ans;
+ }
- 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;
- }
- }
+ 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");
+ }
- $at--; # for decode_error report
+ sub diag_fail {
+ my($self, $msg, $always) = @_;
+ chomp $msg;
+ if ($self->{in_progress}) {
+ $self->_diag("FAIL\n");
+ $self->{in_progress} = 0;
+ }
- 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");
+ 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 number {
- my $n = '';
- my $v;
- my $is_dec;
- my $is_exp;
+ sub _diag {
+ my($self, $msg, $always, $error) = @_;
+ my $fh = $error ? *STDERR : *STDOUT;
+ print {$fh} $msg if $always or $self->{verbose} or !$self->{quiet};
+ }
- if($ch eq '-'){
- $n = '-';
- next_chr;
- if (!defined $ch or $ch !~ /\d/) {
- decode_error("malformed number (no digits after initial minus)");
- }
- }
+ sub diag {
+ my($self, $msg, $always) = @_;
+ $self->_diag($msg, $always);
+ $self->log($msg);
+ }
- # According to RFC4627, hex or oct digits are invalid.
- if($ch eq '0'){
- my $peek = substr($text,$at,1);
- if($peek =~ /^[0-9a-dfA-DF]/){ # e may be valid (exponential)
- decode_error("malformed number (leading zero must not be followed by another digit)");
- }
- $n .= $ch;
- next_chr;
- }
+ sub chat {
+ my $self = shift;
+ print STDERR @_ if $self->{verbose};
+ $self->log(@_);
+ }
- while(defined $ch and $ch =~ /\d/){
- $n .= $ch;
- next_chr;
- }
+ sub mask_output {
+ my $self = shift;
+ my $method = shift;
+ $self->$method( $self->mask_uri_passwords(@_) );
+ }
- if(defined $ch and $ch eq '.'){
- $n .= '.';
- $is_dec = 1;
+ sub log {
+ my $self = shift;
+ open my $out, ">>$self->{log}";
+ print $out @_;
+ }
- next_chr;
- if (!defined $ch or $ch !~ /\d/) {
- decode_error("malformed number (no digits after decimal point)");
- }
- else {
- $n .= $ch;
- }
+ sub run_command {
+ my($self, $cmd) = @_;
- while(defined(next_chr) and $ch =~ /\d/){
- $n .= $ch;
- }
+ # TODO move to a more appropriate runner method
+ if (ref $cmd eq 'CODE') {
+ if ($self->{verbose}) {
+ return $cmd->();
+ } else {
+ require Capture::Tiny;
+ open my $logfh, ">>", $self->{log};
+ my $ret;
+ Capture::Tiny::capture(sub { $ret = $cmd->() }, stdout => $logfh, stderr => $logfh);
+ return $ret;
}
+ }
- if(defined $ch and ($ch eq 'e' or $ch eq 'E')){
- $n .= $ch;
- $is_exp = 1;
- 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;
- }
-
+ if (WIN32) {
+ $cmd = Menlo::Util::shell_quote(@$cmd) if ref $cmd eq 'ARRAY';
+ unless ($self->{verbose}) {
+ $cmd .= " >> " . Menlo::Util::shell_quote($self->{log}) . " 2>&1";
}
-
- $v .= $n;
-
- if ($is_dec or $is_exp) {
- if ($allow_bignum) {
- require Math::BigFloat;
- return Math::BigFloat->new($v);
- }
+ !system $cmd;
+ } else {
+ my $pid = fork;
+ if ($pid) {
+ waitpid $pid, 0;
+ return !$?;
} else {
- if (length $v > $max_intsize) {
- if ($allow_bignum) { # from Adam Sussman
- require Math::BigInt;
- return Math::BigInt->new($v);
- }
- else {
- return "$v";
- }
- }
+ $self->run_exec($cmd);
}
-
- return $is_dec ? $v/1.0 : 0+$v;
}
+ }
+ sub run_exec {
+ my($self, $cmd) = @_;
- 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 = 'U*';
-
- if ( OLD_PERL ) {
- my $type = $] < 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;
- }
+ if (ref $cmd eq 'ARRAY') {
+ unless ($self->{verbose}) {
+ open my $logfh, ">>", $self->{log};
+ open STDERR, '>&', $logfh;
+ open STDOUT, '>&', $logfh;
+ close $logfh;
}
-
- unless ( length $mess ) {
- $mess = '(end of string)';
+ exec @$cmd;
+ } else {
+ unless ($self->{verbose}) {
+ $cmd .= " >> " . Menlo::Util::shell_quote($self->{log}) . " 2>&1";
}
-
- Carp::croak (
- $no_rep ? "$error" : "$error, at character offset $at (before \"$mess\")"
- );
-
+ exec $cmd;
}
+ }
+ sub run_timeout {
+ my($self, $cmd, $timeout) = @_;
- 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];
- }
- }
+ return $self->run_command($cmd) if ref($cmd) eq 'CODE' || WIN32 || $self->{verbose} || !$timeout;
- my @val = $cb_object->($o) if ($cb_object);
- if (@val == 0 or @val > 1) {
- return $o;
- }
- else {
- return $val[0];
+ 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_command($cmd);
}
+ }
+ sub append_args {
+ my($self, $cmd, $phase) = @_;
- sub PP_decode_box {
- {
- text => $text,
- at => $at,
- ch => $ch,
- len => $len,
- depth => $depth,
- encoding => $encoding,
- is_valid_utf8 => $is_valid_utf8,
- };
+ return $cmd if ref $cmd ne 'ARRAY';
+
+ if (my $args = $self->{build_args}{$phase}) {
+ $cmd = join ' ', Menlo::Util::shell_quote(@$cmd), $args;
}
- } # PARSE
+ $cmd;
+ }
+ sub _use_unsafe_inc {
+ my($self, $dist) = @_;
- 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;
- }
+ # if it's set in the env (i.e. user's shell), just use that
+ if (exists $ENV{PERL_USE_UNSAFE_INC}) {
+ return $ENV{PERL_USE_UNSAFE_INC};
+ }
+ # it's set in CPAN Meta, prefer what the author says
+ if (exists $dist->{meta}{x_use_unsafe_inc}) {
+ $self->chat("Distribution opts in x_use_unsafe_inc: $dist->{meta}{x_use_unsafe_inc}\n");
+ return $dist->{meta}{x_use_unsafe_inc};
+ }
- sub _decode_unicode {
- my $un = pack('U', hex shift);
- utf8::encode( $un );
- return $un;
+ # otherwise set to 1 as a default to allow for old modules
+ return 1;
}
- #
- # Setup for various Perl versions (the code from JSON::PP58)
- #
-
- BEGIN {
+ sub configure {
+ my($self, $cmd, $dist, $depth) = @_;
- unless ( defined &utf8::is_utf8 ) {
- require Encode;
- *utf8::is_utf8 = *Encode::is_utf8;
- }
+ # trick AutoInstall
+ local $ENV{PERL5_CPAN_IS_RUNNING} = local $ENV{PERL5_CPANPLUS_IS_RUNNING} = $$;
- if ( !OLD_PERL ) {
- *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;
+ # e.g. skip CPAN configuration on local::lib
+ local $ENV{PERL5_CPANM_IS_RUNNING} = $$;
- if ($] < 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;
- }
- |;
- }
- }
+ 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};
- sub JSON::PP::incr_parse {
- local $Carp::CarpLevel = 1;
- ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_parse( @_ );
+ # 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=";
}
-
- sub JSON::PP::incr_skip {
- ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_skip;
+ # Lancaster Consensus
+ if ($self->{pure_perl}) {
+ $ENV{PERL_MM_OPT} .= " PUREPERL_ONLY=1";
+ $ENV{PERL_MB_OPT} .= " --pureperl-only";
}
+ local $ENV{PERL_USE_UNSAFE_INC} = $self->_use_unsafe_inc($dist);
- sub JSON::PP::incr_reset {
- ( $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new )->incr_reset;
- }
+ $cmd = $self->append_args($cmd, 'configure') if $depth == 0;
- eval q{
- sub JSON::PP::incr_text : lvalue {
- $_[0]->{_incr_parser} ||= JSON::PP::IncrParser->new;
+ local $self->{verbose} = $self->{verbose} || $self->{interactive};
+ $self->run_timeout($cmd, $self->{configure_timeout});
+ }
- if ( $_[0]->{_incr_parser}->{incr_pos} ) {
- Carp::croak("incr_text cannot be called when the incremental parser already started parsing");
- }
- $_[0]->{_incr_parser}->{incr_text};
- }
- } if ( $] >= 5.006 );
+ sub build {
+ my($self, $cmd, $distname, $dist, $depth) = @_;
- } # Setup for various Perl versions (the code from JSON::PP58)
+ local $ENV{PERL_MM_USE_DEFAULT} = !$self->{interactive};
+ local $ENV{PERL_USE_UNSAFE_INC} = $self->_use_unsafe_inc($dist);
- ###############################
- # Utilities
- #
+ $cmd = $self->append_args($cmd, 'build') if $depth == 0;
- BEGIN {
- eval 'require Scalar::Util';
- unless($@){
- *JSON::PP::blessed = \&Scalar::Util::blessed;
- *JSON::PP::reftype = \&Scalar::Util::reftype;
- *JSON::PP::refaddr = \&Scalar::Util::refaddr;
+ 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, $dist, $depth) if $ans eq 'r';
+ $self->show_build_log if $ans eq 'e';
+ $self->look if $ans eq 'l';
}
- 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;
- };
- require B;
- 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));
+ sub test {
+ my($self, $cmd, $distname, $dist, $depth) = @_;
+ return 1 if $self->{notest};
- my $t = ref(B::svref_2object($r));
+ # https://rt.cpan.org/Ticket/Display.html?id=48965#txn-1013385
+ local $ENV{PERL_MM_USE_DEFAULT} = !$self->{interactive};
- return
- exists $tmap{$t} ? $tmap{$t}
- : length(ref($$r)) ? 'REF'
- : 'SCALAR';
- };
- *JSON::PP::refaddr = sub {
- return undef unless length(ref($_[0]));
+ # https://github.com/Perl-Toolchain-Gang/toolchain-site/blob/master/lancaster-consensus.md
+ local $ENV{NONINTERACTIVE_TESTING} = !$self->{interactive};
- my $addr;
- if(defined(my $pkg = blessed($_[0]))) {
- $addr .= bless $_[0], 'Scalar::Util::Fake';
- bless $_[0], $pkg;
- }
- else {
- $addr .= $_[0]
- }
+ local $ENV{PERL_USE_UNSAFE_INC} = $self->_use_unsafe_inc($dist);
- $addr =~ /0x(\w+)/;
- local $^W;
- #no warnings 'portable';
- hex($1);
+ $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, $dist, $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, $dist, $depth) = @_;
- # shamelessly 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 # 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;
-
- $JSON::backportPP::IncrParser::VERSION = '1.01';
-
- sub new {
- my ( $class ) = @_;
-
- bless {
- incr_nest => 0,
- incr_text => undef,
- incr_pos => 0,
- incr_mode => 0,
- }, $class;
- }
+ if ($depth == 0 && $self->{test_only}) {
+ return 1;
+ }
+ return $self->run_command($cmd) if ref $cmd eq 'CODE';
- sub incr_parse {
- my ( $self, $coder, $text ) = @_;
+ local $ENV{PERL_USE_UNSAFE_INC} = $self->_use_unsafe_inc($dist);
- $self->{incr_text} = '' unless ( defined $self->{incr_text} );
+ if ($self->{sudo}) {
+ unshift @$cmd, "sudo";
+ }
- 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;
+ if ($self->{uninstall_shadows} && !$ENV{PERL_MM_OPT}) {
+ push @$cmd, @$uninst_opts;
}
- if ( defined wantarray ) {
- my $max_size = $coder->get_max_size;
- my $p = $self->{incr_pos};
- my @ret;
- {
- do {
- unless ( $self->{incr_nest} <= 0 and $self->{incr_mode} == INCR_M_JSON ) {
- $self->_incr_parse( $coder );
+ $cmd = $self->append_args($cmd, 'install') if $depth == 0;
- if ( $max_size and $self->{incr_pos} > $max_size ) {
- Carp::croak("attempted decode of JSON text of $self->{incr_pos} bytes size, but max_size is set to $max_size");
- }
- unless ( $self->{incr_nest} <= 0 and $self->{incr_mode} == INCR_M_JSON ) {
- # as an optimisation, do not accumulate white space in the incr buffer
- if ( $self->{incr_mode} == INCR_M_WS and $self->{incr_pos} ) {
- $self->{incr_pos} = 0;
- $self->{incr_text} = '';
- }
- last;
- }
- }
+ $self->run_command($cmd);
+ }
- my ($obj, $offset) = $coder->PP_decode_json( $self->{incr_text}, 0x00000001 );
- push @ret, $obj;
- use bytes;
- $self->{incr_text} = substr( $self->{incr_text}, $offset || 0 );
- $self->{incr_pos} = 0;
- $self->{incr_nest} = 0;
- $self->{incr_mode} = 0;
- last unless wantarray;
- } while ( wantarray );
- }
+ sub look {
+ my $self = shift;
- if ( wantarray ) {
- return @ret;
- }
- else { # in scalar context
- return $ret[0] ? $ret[0] : undef;
- }
+ 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;
- sub _incr_parse {
- my ($self, $coder) = @_;
- my $text = $self->{incr_text};
- my $len = length $text;
- my $p = $self->{incr_pos};
-
- INCR_PARSE:
- while ( $len > $p ) {
- my $s = substr( $text, $p, 1 );
- last INCR_PARSE unless defined $s;
- my $mode = $self->{incr_mode};
-
- if ( $mode == INCR_M_WS ) {
- while ( $len > $p ) {
- $s = substr( $text, $p, 1 );
- last INCR_PARSE unless defined $s;
- if ( ord($s) > 0x20 ) {
- if ( $s eq '#' ) {
- $self->{incr_mode} = INCR_M_C0;
- redo INCR_PARSE;
- } else {
- $self->{incr_mode} = INCR_M_JSON;
- redo INCR_PARSE;
- }
- }
- $p++;
- }
- } elsif ( $mode == INCR_M_BS ) {
- $p++;
- $self->{incr_mode} = INCR_M_STR;
- redo INCR_PARSE;
- } elsif ( $mode == INCR_M_C0 or $mode == INCR_M_C1 ) {
- while ( $len > $p ) {
- $s = substr( $text, $p, 1 );
- last INCR_PARSE unless defined $s;
- if ( $s eq "\n" ) {
- $self->{incr_mode} = $self->{incr_mode} == INCR_M_C0 ? INCR_M_WS : INCR_M_JSON;
- last;
- }
- $p++;
- }
- next;
- } elsif ( $mode == INCR_M_STR ) {
- while ( $len > $p ) {
- $s = substr( $text, $p, 1 );
- last INCR_PARSE unless defined $s;
- if ( $s eq '"' ) {
- $p++;
- $self->{incr_mode} = INCR_M_JSON;
+ my @pagers = (
+ $ENV{PAGER},
+ (WIN32 ? () : ('less')),
+ 'more'
+ );
+ my $pager;
+ while (@pagers) {
+ $pager = shift @pagers;
+ next unless $pager;
+ $pager = which($pager);
+ next unless $pager;
+ last;
+ }
- last INCR_PARSE unless $self->{incr_nest};
- redo INCR_PARSE;
- }
- elsif ( $s eq '\\' ) {
- $p++;
- if ( !defined substr($text, $p, 1) ) {
- $self->{incr_mode} = INCR_M_BS;
- last INCR_PARSE;
- }
- }
- $p++;
- }
- } elsif ( $mode == INCR_M_JSON ) {
- while ( $len > $p ) {
- $s = substr( $text, $p++, 1 );
- if ( $s eq "\x00" ) {
- $p--;
- last INCR_PARSE;
- } elsif ( $s eq "\x09" or $s eq "\x0a" or $s eq "\x0d" or $s eq "\x20" ) {
- if ( !$self->{incr_nest} ) {
- $p--; # do not eat the whitespace, let the next round do it
- last INCR_PARSE;
- }
- next;
- } elsif ( $s eq '"' ) {
- $self->{incr_mode} = INCR_M_STR;
- redo INCR_PARSE;
- } elsif ( $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?)');
- }
- next;
- } elsif ( $s eq ']' or $s eq '}' ) {
- if ( --$self->{incr_nest} <= 0 ) {
- last INCR_PARSE;
- }
- } elsif ( $s eq '#' ) {
- $self->{incr_mode} = INCR_M_C1;
- redo INCR_PARSE;
- }
- }
+ if ($pager) {
+ if (WIN32) {
+ system "@{[ qs $pager ]} < @{[ qs $self->{log}]}";
+ } else {
+ system $pager, $self->{log};
}
}
-
- $self->{incr_pos} = $p;
- $self->{incr_parsing} = $p ? 1 : 0; # for backward compatibility
- }
-
-
- sub incr_text {
- if ( $_[0]->{incr_pos} ) {
- Carp::croak("incr_text cannot be called when the incremental parser already started parsing");
+ else {
+ $self->diag_fail("You don't seem to have a PAGER :/");
}
- $_[0]->{incr_text};
}
-
- sub incr_skip {
- my $self = shift;
- $self->{incr_text} = substr( $self->{incr_text}, $self->{incr_pos} );
- $self->{incr_pos} = 0;
- $self->{incr_mode} = 0;
- $self->{incr_nest} = 0;
+ sub chdir {
+ my $self = shift;
+ Cwd::chdir(File::Spec->canonpath($_[0])) or die "$_[0]: $!";
}
-
- sub incr_reset {
+ sub configure_mirrors {
my $self = shift;
- $self->{incr_text} = undef;
- $self->{incr_pos} = 0;
- $self->{incr_mode} = 0;
- $self->{incr_nest} = 0;
+ unless (@{$self->{mirrors}}) {
+ $self->{mirrors} = [ 'http://www.cpan.org' ];
+ }
+ for (@{$self->{mirrors}}) {
+ s!^/!file:///!;
+ s!/$!!;
+ }
}
- ###############################
-
-
- 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
-
- $json = JSON::PP->new->ascii->pretty->allow_nonref;
-
- $pretty_printed_json_text = $json->encode( $perl_scalar );
- $perl_scalar = $json->decode( $json_text );
-
- # 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.91_04
-
- =head1 DESCRIPTION
-
- JSON::PP is a pure perl JSON decoder/encoder (as of RFC4627, which
- we know is obsolete but we still stick to; see below for an option
- to support part of RFC7159), and (almost) compatible to much
- faster L<JSON::XS> written by Marc Lehmann in C. JSON::PP works as
- a fallback module when you use L<JSON> module without having
- installed JSON::XS.
-
- Because of this fallback feature of JSON.pm, JSON::PP tries not to
- be more JavaScript-friendly than JSON::XS (i.e. not to escape extra
- characters such as U+2028 and U+2029 nor support RFC7159/ECMA-404),
- in order for you not to lose such JavaScript-friendliness silently
- when you use JSON.pm and install JSON::XS for speed or by accident.
- If you need JavaScript-friendly RFC7159-compliant pure perl module,
- try L<JSON::Tiny>, which is derived from L<Mojolicious> web
- framework and is also smaller and faster than JSON::PP.
-
- JSON::PP has been in the Perl core since Perl 5.14, mainly for
- CPAN toolchain modules to parse META.json.
-
- =head1 FUNCTIONAL INTERFACE
-
- This section is taken from JSON::XS almost verbatim. C<encode_json>
- and C<decode_json> are exported by default.
+ sub self_upgrade {
+ my $self = shift;
+ $self->check_upgrade;
+ $self->{argv} = [ 'Menlo' ];
+ return; # continue
+ }
- =head2 encode_json
+ sub install_module {
+ my($self, $module, $depth, $version, $dep) = @_;
- $json_text = encode_json $perl_scalar
+ $self->check_libs;
- Converts the given Perl data structure to a UTF-8 encoded, binary string
- (that is, the string contains octets only). Croaks on error.
-
- This function call is functionally identical to:
+ if ($self->{seen}{$module}++) {
+ # TODO: circular dependencies
+ $self->chat("Already tried $module. Skipping.\n");
+ return 1;
+ }
- $json_text = JSON::PP->new->utf8->encode($perl_scalar)
+ 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;
+ }
+ }
- Except being faster.
+ my $dist = $self->resolve_name($module, $version, $dep);
+ unless ($dist) {
+ my $what = $module . ($version ? " ($version)" : "");
+ $self->diag_fail("Couldn't find module or a distribution $what", 1);
+ return;
+ }
- =head2 decode_json
+ if ($dist->{distvname} && $self->{seen}{$dist->{distvname}}++) {
+ $self->chat("Already tried $dist->{distvname}. Skipping.\n");
+ return 1;
+ }
- $perl_scalar = decode_json $json_text
+ if ($self->{cmd} eq 'info') {
+ print $self->format_dist($dist), "\n";
+ return 1;
+ }
- The opposite of C<encode_json>: expects an UTF-8 (binary) string and tries
- to parse that as an UTF-8 encoded JSON text, returning the resulting
- reference. Croaks on error.
+ $dist->{depth} = $depth; # ugly hack
- This function call is functionally identical to:
+ 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;
+ }
- $perl_scalar = JSON::PP->new->utf8->decode($json_text)
+ # 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;
+ }
+ }
- Except being faster.
+ if ($dist->{dist} eq 'perl'){
+ $self->diag("skipping $dist->{pathname}\n");
+ return 1;
+ }
- =head2 JSON::PP::is_bool
+ $self->diag("--> Working on $module\n");
- $is_boolean = JSON::PP::is_bool($scalar)
+ $dist->{dir} ||= $self->fetch_module($dist);
- 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<true> and C<false> in Perl strings.
+ unless ($dist->{dir}) {
+ $self->diag_fail("Failed to fetch distribution $dist->{distvname}", 1);
+ return;
+ }
- See L<MAPPING>, below, for more information on how JSON values are mapped to
- Perl.
+ $self->chat("Entering $dist->{dir}\n");
+ $self->chdir($self->{base});
+ $self->chdir($dist->{dir});
- =head1 OBJECT-ORIENTED INTERFACE
+ if ($self->{cmd} eq 'look') {
+ $self->look;
+ return 1;
+ }
- This section is also taken from JSON::XS.
+ return $self->build_stuff($module, $dist, $depth);
+ }
- The object oriented interface lets you configure your own encoding or
- decoding style, within the limits of supported formats.
+ sub uninstall_search_path {
+ my $self = shift;
- =head2 new
+ $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)};
+ }
- $json = JSON::PP->new
+ sub uninstall_module {
+ my ($self, $module) = @_;
- Creates a new JSON::PP object that can be used to de/encode JSON
- strings. All boolean flags described below are by default I<disabled>.
+ $self->check_libs;
- The mutators for flags all return the JSON::PP object again and thus calls can
- be chained:
+ my @inc = $self->uninstall_search_path;
- my $json = JSON::PP->new->utf8->space_after->encode({a => [1,2]})
- => {"a": [1, 2]}
+ my($metadata, $packlist) = $self->packlists_containing($module, \@inc);
+ unless ($packlist) {
+ $self->diag_fail(<<DIAG, 1);
+ $module is not found in the following directories and can't be uninstalled.
- =head2 ascii
+ @{[ join(" \n", map " $_", @inc) ]}
- $json = $json->ascii([$enable])
-
- $enabled = $json->get_ascii
+ DIAG
+ return;
+ }
- If C<$enable> is true (or missing), then the C<encode> method will not
- generate characters outside the code range C<0..127> (which is ASCII). Any
- Unicode characters outside that range will be escaped using either a
- single \uXXXX (BMP characters) or a double \uHHHH\uLLLLL escape sequence,
- as per RFC4627. The resulting encoded JSON text can be treated as a native
- Unicode string, an ascii-encoded, latin1-encoded or UTF-8 encoded string,
- or any other superset of ASCII.
+ my @uninst_files = $self->uninstall_target($metadata, $packlist);
- If C<$enable> is false, then the C<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.
+ $self->ask_permission($module, \@uninst_files) or return;
+ $self->uninstall_files(@uninst_files, $packlist);
- See also the section I<ENCODING/CODESET FLAG NOTES> later in this document.
+ $self->diag("Successfully uninstalled $module\n", 1);
- The main use for this flag is to produce JSON texts that can be
- transmitted over a 7-bit channel, as the encoded JSON texts will not
- contain any 8 bit characters.
+ return 1;
+ }
- JSON::PP->new->ascii(1)->encode([chr 0x10401])
- => ["\ud801\udc01"]
+ sub packlists_containing {
+ my($self, $module, $inc) = @_;
- =head2 latin1
+ require Module::Metadata;
+ my $metadata = Module::Metadata->new_from_module($module, inc => $inc)
+ or return;
- $json = $json->latin1([$enable])
-
- $enabled = $json->get_latin1
+ 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;
+ }
+ };
- If C<$enable> is true (or missing), then the C<encode> method will encode
- the resulting JSON text as latin1 (or iso-8859-1), escaping any characters
- outside the code range C<0..255>. The resulting string can be treated as a
- latin1-encoded JSON text or a native Unicode string. The C<decode> method
- will not be affected in any way by this flag, as C<decode> by default
- expects Unicode, which is a strict superset of latin1.
+ {
+ require File::pushd;
+ my $pushd = File::pushd::pushd();
+ my @search = grep -d $_, map File::Spec->catdir($_, 'auto'), @$inc;
+ File::Find::find($wanted, @search);
+ }
- If C<$enable> is false, then the C<encode> method will not escape Unicode
- characters unless required by the JSON syntax or other flags.
+ return $metadata, $packlist;
+ }
- See also the section I<ENCODING/CODESET FLAG NOTES> later in this document.
+ sub uninstall_target {
+ my($self, $metadata, $packlist) = @_;
- The main use for this flag is efficiently encoding binary data as JSON
- text, as most octets will not be escaped, resulting in a smaller encoded
- size. The disadvantage is that the resulting JSON text is encoded
- in latin1 (and must correctly be treated as such when storing and
- transferring), a rare encoding for JSON. It is therefore most useful when
- you want to store data structures known to contain binary data efficiently
- in files or databases, not when talking to other JSON encoders/decoders.
+ # 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);
+ }
+ }
- JSON::PP->new->latin1->encode (["\x{89}\x{abc}"]
- => ["\x{89}\\u0abc"] # (perl syntax, U+abc escaped, U+89 not)
+ sub has_shadow_install {
+ my($self, $metadata) = @_;
- =head2 utf8
+ # 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;
+ }
- $json = $json->utf8([$enable])
-
- $enabled = $json->get_utf8
+ sub should_unlink {
+ my($self, $file) = @_;
- If C<$enable> is true (or missing), then the C<encode> method will encode
- the JSON result into UTF-8, as required by many protocols, while the
- C<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 C<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 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)});
+ }
+ }
- If C<$enable> is false, then the C<encode> method will return the JSON
- string as a (non-encoded) Unicode string, while C<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.
+ sub ask_permission {
+ my ($self, $module, $files) = @_;
- See also the section I<ENCODING/CODESET FLAG NOTES> later in this document.
+ $self->diag("$module contains the following files:\n\n");
+ for my $file (@$files) {
+ $self->diag(" $file\n");
+ }
+ $self->diag("\n");
- Example, output UTF-16BE-encoded JSON:
+ return 'force uninstall' if $self->{force};
+ local $self->{prompt} = 1;
+ return $self->prompt_bool("Are you sure you want to uninstall $module?", 'y');
+ }
- use Encode;
- $jsontext = encode "UTF-16BE", JSON::PP->new->encode ($object);
+ sub unpack_packlist {
+ my ($self, $packlist) = @_;
+ open my $fh, '<', $packlist or die "$packlist: $!";
+ map { chomp; $_ } <$fh>;
+ }
- Example, decode UTF-32LE-encoded JSON:
+ sub uninstall_files {
+ my ($self, @files) = @_;
- use Encode;
- $object = JSON::PP->new->decode (decode "UTF-32LE", $jsontext);
+ $self->diag("\n");
- =head2 pretty
+ for my $file (@files) {
+ $self->diag("Unlink: $file\n");
+ unlink $file or $self->diag_fail("$!: $file");
+ }
- $json = $json->pretty([$enable])
+ $self->diag("\n");
- This enables (or disables) all of the C<indent>, C<space_before> and
- C<space_after> (and in the future possibly more) flags in one call to
- generate the most readable (or most compact) form possible.
+ return 1;
+ }
- =head2 indent
+ sub format_dist {
+ my($self, $dist) = @_;
- $json = $json->indent([$enable])
-
- $enabled = $json->get_indent
+ # TODO support --dist-format?
+ return "$dist->{cpanid}/$dist->{filename}";
+ }
- If C<$enable> is true (or missing), then the C<encode> method will use a multiline
- format as output, putting every array member or object/hash key-value pair
- into its own line, indenting them properly.
+ sub trim {
+ local $_ = shift;
+ tr/\n/ /d;
+ s/^\s*|\s*$//g;
+ $_;
+ }
- If C<$enable> is false, no newlines or indenting will be produced, and the
- resulting JSON text is guaranteed not to contain any C<newlines>.
+ sub fetch_module {
+ my($self, $dist) = @_;
- This setting has no effect when decoding JSON texts.
+ $self->chdir($self->{base});
- The default indent space length is three.
- You can use C<indent_length> to change the length.
+ for my $uri (@{$dist->{uris}}) {
+ $self->mask_output( diag_progress => "Fetching $uri" );
- =head2 space_before
+ # Ugh, $dist->{filename} can contain sub directory
+ my $filename = $dist->{filename} || $uri;
+ my $name = File::Basename::basename($filename);
- $json = $json->space_before([$enable])
-
- $enabled = $json->get_space_before
+ 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;
+ };
- If C<$enable> is true (or missing), then the C<encode> method will add an extra
- optional space before the C<:> separating keys from values in JSON objects.
+ my($try, $file);
+ while ($try++ < 3) {
+ $file = $fetch->();
+ last if $cancelled or $file;
+ $self->mask_output( diag_fail => "Download $uri failed. Retrying ... ");
+ }
- If C<$enable> is false, then the C<encode> method will not add any extra
- space at those places.
+ if ($cancelled) {
+ $self->diag_fail("Download cancelled.");
+ return;
+ }
- This setting has no effect when decoding JSON texts. You will also
- most likely combine this setting with C<space_after>.
+ unless ($file) {
+ $self->mask_output( diag_fail => "Failed to download $uri");
+ next;
+ }
- Example, space_before enabled, space_after and indent disabled:
+ $self->diag_ok;
+ $dist->{local_path} = File::Spec->rel2abs($name);
- {"key" :"value"}
+ my $dir = $self->unpack($file, $uri, $dist);
+ next unless $dir; # unpack failed
- =head2 space_after
+ 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 $!;
+ }
- $json = $json->space_after([$enable])
-
- $enabled = $json->get_space_after
+ return $dist, $dir;
+ }
+ }
- If C<$enable> is true (or missing), then the C<encode> 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.
+ sub unpack {
+ my($self, $file, $uri, $dist) = @_;
- If C<$enable> is false, then the C<encode> method will not add any extra
- space at those places.
+ if ($self->{verify}) {
+ $self->verify_archive($file, $uri, $dist) or return;
+ }
- This setting has no effect when decoding JSON texts.
+ $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;
+ }
- Example, space_before and indent disabled, space_after enabled:
+ sub verify_checksums_signature {
+ my($self, $chk_file) = @_;
- {"key": "value"}
+ require Module::Signature; # no fatpack
- =head2 relaxed
+ $self->chat("Verifying the signature of CHECKSUMS\n");
- $json = $json->relaxed([$enable])
-
- $enabled = $json->get_relaxed
+ 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;
+ }
- If C<$enable> is true (or missing), then C<decode> will accept some
- extensions to normal JSON syntax (see below). C<encode> will not be
- affected in anyway. I<Be aware that this option makes you accept invalid
- JSON texts as if they were valid!>. I suggest only to use this option to
- parse application-specific files written by humans (configuration files,
- resource files etc.)
+ return 1;
+ }
- If C<$enable> is false (the default), then C<decode> will only accept
- valid JSON texts.
+ sub verify_archive {
+ my($self, $file, $uri, $dist) = @_;
- Currently accepted extensions are:
+ unless ($dist->{cpanid}) {
+ $self->chat("Archive '$file' does not seem to be from PAUSE. Skip verification.\n");
+ return 1;
+ }
- =over 4
+ (my $mirror = $uri) =~ s!/authors/id.*$!!;
- =item * list items can have an end-comma
+ (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);
- JSON I<separates> 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:
+ unless (-e $chk_file) {
+ $self->diag_fail("Fetching $chksum_uri failed.\n");
+ return;
+ }
- [
- 1,
- 2, <- this comma not normally allowed
- ]
- {
- "k1": "v1",
- "k2": "v2", <- this comma not normally allowed
- }
+ $self->diag_ok;
+ $self->verify_checksums_signature($chk_file) or return;
+ $self->verify_checksum($file, $chk_file);
+ }
- =item * shell-style '#'-comments
+ sub verify_checksum {
+ my($self, $file, $chk_file) = @_;
- 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.
+ $self->chat("Verifying the SHA1 for $file\n");
- [
- 1, # this comment not allowed in JSON
- # neither this one...
- ]
+ open my $fh, "<$chk_file" or die "$chk_file: $!";
+ my $data = join '', <$fh>;
+ $data =~ s/\015?\012/\n/g;
- =item * C-style multiple-line '/* */'-comments (JSON::PP only)
+ require Safe; # no fatpack
+ my $chksum = Safe->new->reval($data);
- Whenever JSON allows whitespace, C-style multiple-line comments are additionally
- allowed. Everything between C</*> and C<*/> is a comment, after which
- more white-space and comments are allowed.
+ if (!ref $chksum or ref $chksum ne 'HASH') {
+ $self->diag_fail("! Checksum file downloaded from $chk_file is broken.\n");
+ return;
+ }
- [
- 1, /* this comment not allowed in JSON */
- /* neither this one... */
- ]
+ if (my $sha = $chksum->{$file}{sha256}) {
+ my $hex = $self->sha_for(256, $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;
+ }
+ }
- =item * C++-style one-line '//'-comments (JSON::PP only)
+ sub sha_for {
+ my($self, $alg, $file) = @_;
- Whenever JSON allows whitespace, C++-style one-line 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.
+ require Digest::SHA; # no fatpack
- [
- 1, // this comment not allowed in JSON
- // neither this one...
- ]
+ open my $fh, "<", $file or die "$file: $!";
+ my $dg = Digest::SHA->new($alg);
+ my($data);
+ while (read($fh, $data, 4096)) {
+ $dg->add($data);
+ }
- =back
+ return $dg->hexdigest;
+ }
- =head2 canonical
+ sub verify_signature {
+ my($self, $dist) = @_;
- $json = $json->canonical([$enable])
-
- $enabled = $json->get_canonical
+ $self->diag_progress("Verifying the SIGNATURE file");
+ my $out = `@{[ qs $self->{cpansign} ]} -v --skip 2>&1`;
+ $self->log($out);
- If C<$enable> is true (or missing), then the C<encode> method will output JSON objects
- by sorting their keys. This is adding a comparatively high overhead.
+ if ($out =~ /Signature verified OK/) {
+ $self->diag_ok("Verified OK");
+ return 1;
+ } else {
+ $self->diag_fail("SIGNATURE verification for $dist->{filename} failed\n");
+ return;
+ }
+ }
- If C<$enable> is false, then the C<encode> method will output key-value
- pairs in the order Perl stores them (which will likely change between runs
- of the same script, and can change even within the same run from 5.18
- onwards).
+ sub resolve_name {
+ my($self, $module, $version, $dep) = @_;
- 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.
+ if ($dep && $dep->url) {
+ if ($dep->url =~ m!authors/id/(.*)!) {
+ return $self->cpan_dist($1, $dep->url);
+ } else {
+ return { uris => [ $dep->url ] };
+ }
+ }
- This setting has no effect when decoding JSON texts.
+ if ($dep && $dep->dist) {
+ return $self->cpan_dist($dep->dist, undef, $dep->mirror);
+ }
- This setting has currently no effect on tied hashes.
+ # Git
+ if ($module =~ /(?:^git:|\.git(?:@.+)?$)/) {
+ return $self->git_uri($module);
+ }
- =head2 allow_nonref
+ # URL
+ if ($module =~ /^(ftp|https?|file):/) {
+ if ($module =~ m!authors/id/(.*)!) {
+ return $self->cpan_dist($1, $module);
+ } else {
+ return { uris => [ $module ] };
+ }
+ }
- $json = $json->allow_nonref([$enable])
-
- $enabled = $json->get_allow_nonref
+ # Directory
+ if ($module =~ m!^[\./]! && -d $module) {
+ return {
+ source => 'local',
+ dir => Cwd::abs_path($module),
+ };
+ }
- If C<$enable> is true (or missing), then the C<encode> method can convert a
- non-reference into its corresponding string, number or null JSON value,
- which is an extension to RFC4627. Likewise, C<decode> will accept those JSON
- values instead of croaking.
+ # File
+ if (-f $module) {
+ return {
+ source => 'local',
+ uris => [ "file://" . Cwd::abs_path($module) ],
+ };
+ }
- If C<$enable> is false, then the C<encode> method will croak if it isn't
- passed an arrayref or hashref, as JSON texts must either be an object
- or array. Likewise, C<decode> will croak if given something that is not a
- JSON object or array.
+ # cpan URI
+ if ($module =~ s!^cpan:///distfile/!!) {
+ return $self->cpan_dist($module);
+ }
- Example, encode a Perl scalar as JSON value with enabled C<allow_nonref>,
- resulting in an invalid JSON text:
+ # 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);
+ }
- JSON::PP->new->allow_nonref->encode ("Hello, World!")
- => "Hello, World!"
+ # Module name
+ return $self->search_module($module, $version);
+ }
- =head2 allow_unknown
+ sub cpan_module_common {
+ my($self, $match) = @_;
- $json = $json->allow_unknown ([$enable])
-
- $enabled = $json->get_allow_unknown
+ (my $distfile = $match->{uri}) =~ s!^cpan:///distfile/!!;
- If C<$enable> is true (or missing), then C<encode> will I<not> throw an
- exception when it encounters values it cannot represent in JSON (for
- example, filehandles) but instead will encode a JSON C<null> value. Note
- that blessed objects are not included here and are handled separately by
- c<allow_blessed>.
+ my $mirrors = $self->{mirrors};
+ if ($match->{download_uri}) {
+ (my $mirror = $match->{download_uri}) =~ s!/authors/id/.*$!!;
+ $mirrors = [$mirror];
+ }
- If C<$enable> is false (the default), then C<encode> will throw an
- exception when it encounters anything it cannot encode as JSON.
+ local $self->{mirrors} = $mirrors;
+ return $self->cpan_module($match->{package}, $distfile, $match->{version});
+ }
- This option does not affect C<decode> in any way, and it is recommended to
- leave it off unless you know your communications partner.
+ sub cpan_module {
+ my($self, $module, $dist_file, $version) = @_;
- =head2 allow_blessed
+ my $dist = $self->cpan_dist($dist_file);
+ $dist->{module} = $module;
+ $dist->{module_version} = $version if $version && $version ne 'undef';
- $json = $json->allow_blessed([$enable])
-
- $enabled = $json->get_allow_blessed
+ return $dist;
+ }
- See L<OBJECT SERIALISATION> for details.
+ sub cpan_dist {
+ my($self, $dist, $url, $mirror) = @_;
- If C<$enable> is true (or missing), then the C<encode> method will not
- barf when it encounters a blessed reference that it cannot convert
- otherwise. Instead, a JSON C<null> value is encoded instead of the object.
+ # strip trailing slash
+ $mirror =~ s!/$!! if $mirror;
- If C<$enable> is false (the default), then C<encode> will throw an
- exception when it encounters a blessed object that it cannot convert
- otherwise.
+ $dist =~ s!^([A-Z]{2})!substr($1,0,1)."/".substr($1,0,2)."/".$1!e;
- This setting has no effect on C<decode>.
+ require CPAN::DistnameInfo;
+ my $d = CPAN::DistnameInfo->new($dist);
- =head2 convert_blessed
+ 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;
- $json = $json->convert_blessed([$enable])
-
- $enabled = $json->get_convert_blessed
+ my @mirrors = $mirror ? ($mirror) : @{$self->{mirrors}};
+ my @urls = map "$_/authors/id/$fn", @mirrors;
- See L<OBJECT SERIALISATION> for details.
+ $url = \@urls,
+ }
- If C<$enable> is true (or missing), then C<encode>, upon encountering a
- blessed object, will check for the availability of the C<TO_JSON> 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.
+ return {
+ $d->properties,
+ source => 'cpan',
+ uris => $url,
+ };
+ }
- The C<TO_JSON> method may safely call die if it wants. If C<TO_JSON>
- returns other blessed objects, those will be handled in the same
- way. C<TO_JSON> must take care of not causing an endless recursion cycle
- (== crash) in this case. The name of C<TO_JSON> 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 any C<to_json>
- function or method.
+ sub git_uri {
+ my ($self, $uri) = @_;
- If C<$enable> is false (the default), then C<encode> will not consider
- this type of conversion.
+ # 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
- This setting has no effect on C<decode>.
+ ($uri, my $commitish) = split /(?<=\.git)@/i, $uri, 2;
- =head2 filter_json_object
+ my $dir = File::Temp::tempdir(CLEANUP => 1);
- $json = $json->filter_json_object([$coderef])
+ $self->mask_output( diag_progress => "Cloning $uri" );
+ $self->run_command([ 'git', 'clone', $uri, $dir ]);
- When C<$coderef> is specified, it will be called from C<decode> each
- time it decodes a JSON object. The only argument 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<not> C<undef>, which is a valid scalar), the
- original deserialised hash will be inserted. This setting can slow down
- decoding considerably.
+ unless (-e "$dir/.git") {
+ $self->diag_fail("Failed cloning git repository $uri", 1);
+ return;
+ }
- When C<$coderef> is omitted or undefined, any existing callback will
- be removed and C<decode> will not change the deserialised hash in any
- way.
+ if ($commitish) {
+ require File::pushd;
+ my $dir = File::pushd::pushd($dir);
- Example, convert all JSON objects into the integer 5:
+ unless ($self->run_command([ 'git', 'checkout', $commitish ])) {
+ $self->diag_fail("Failed to checkout '$commitish' in git repository $uri\n");
+ return;
+ }
+ }
- 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}');
+ $self->diag_ok;
- =head2 filter_json_single_key_object
+ return {
+ source => 'local',
+ dir => $dir,
+ };
+ }
- $json = $json->filter_json_single_key_object($key [=> $coderef])
+ sub core_version_for {
+ my($self, $module) = @_;
- Works remotely similar to C<filter_json_object>, but is only called for
- JSON objects having a single key named C<$key>.
+ require Module::CoreList; # no fatpack
+ unless (exists $Module::CoreList::version{$]+0}) {
+ die sprintf("Module::CoreList %s (loaded from %s) doesn't seem to have entries for perl $]. " .
+ "You're strongly recommended to upgrade Module::CoreList from CPAN.\n",
+ $Module::CoreList::VERSION, $INC{"Module/CoreList.pm"});
+ }
- This C<$coderef> is called before the one specified via
- C<filter_json_object>, 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<undef> but the empty list),
- the callback from C<filter_json_object> will be called next, as if no
- single-key callback were specified.
+ unless (exists $Module::CoreList::version{$]+0}{$module}) {
+ return -1;
+ }
- If C<$coderef> is omitted or undefined, the corresponding callback will be
- disabled. There can only ever be one callback for a given key.
+ return $Module::CoreList::version{$]+0}{$module};
+ }
- As this callback gets called less often then the C<filter_json_object>
- 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.
+ sub search_inc {
+ my $self = shift;
+ $self->{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]
+ }
+ };
+ }
- 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.
+ sub check_module {
+ my($self, $mod, $want_ver) = @_;
- Example, decode JSON objects of the form C<< { "__widget__" => <id> } >>
- into the corresponding C<< $WIDGET{<id>} >> object:
+ require Module::Metadata;
+ my $meta = Module::Metadata->new_from_module($mod, inc => $self->search_inc)
+ or return 0, undef;
- # return whatever is in $WIDGET{5}:
- JSON::PP
- ->new
- ->filter_json_single_key_object (__widget__ => sub {
- $WIDGET{ $_[0] }
- })
- ->decode ('{"__widget__": 5')
+ my $version = $meta->version;
- # this can be used with a TO_JSON method in some "widget" class
- # for serialisation to json:
- sub WidgetBase::TO_JSON {
- my ($self) = @_;
+ # 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;
+ }
- unless ($self->{id}) {
- $self->{id} = ..get..some..id..;
- $WIDGET{$self->{id}} = $self;
- }
+ $self->{local_versions}{$mod} = $version;
- { __widget__ => $self->{id} }
- }
+ if ($self->is_deprecated($meta)){
+ return 0, $version;
+ } elsif ($self->satisfy_version($mod, $version, $want_ver)) {
+ return 1, ($version || 'undef');
+ } else {
+ return 0, $version;
+ }
+ }
- =head2 shrink
+ sub satisfy_version {
+ my($self, $mod, $version, $want_ver) = @_;
- $json = $json->shrink([$enable])
-
- $enabled = $json->get_shrink
+ $want_ver = '0' unless defined($want_ver) && length($want_ver);
- If C<$enable> is true (or missing), the string returned by C<encode> will
- be shrunk (i.e. downgraded if possible).
+ require CPAN::Meta::Requirements;
+ my $requirements = CPAN::Meta::Requirements->new;
+ $requirements->add_string_requirement($mod, $want_ver);
+ $requirements->accepts_module($mod, $version);
+ }
- The actual definition of what shrink does might change in future versions,
- but it will always try to save space at the expense of time.
+ sub unsatisfy_how {
+ my($self, $ver, $want_ver) = @_;
- If C<$enable> is false, then JSON::PP does nothing.
+ if ($want_ver =~ /^[v0-9\.\_]+$/) {
+ return "$ver < $want_ver";
+ } else {
+ return "$ver doesn't satisfy $want_ver";
+ }
+ }
- =head2 max_depth
+ sub is_deprecated {
+ my($self, $meta) = @_;
- $json = $json->max_depth([$maximum_nesting_depth])
-
- $max_depth = $json->get_max_depth
+ my $deprecated = eval {
+ require Module::CoreList; # no fatpack
+ Module::CoreList::is_deprecated($meta->{module});
+ };
- 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.
+ return $deprecated && $self->loaded_from_perl_lib($meta);
+ }
- 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.
+ sub loaded_from_perl_lib {
+ my($self, $meta) = @_;
- Setting the maximum depth to one disallows any nesting, so that ensures
- that the object is only a single hash/object or array.
+ 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;
+ }
+ }
- If no argument is given, the highest possible setting will be used, which
- is rarely useful.
+ return;
+ }
- See L<JSON::XS/SECURITY CONSIDERATIONS> for more info on why this is useful.
+ sub should_install {
+ my($self, $mod, $ver) = @_;
- =head2 max_size
+ $self->chat("Checking if you have $mod $ver ... ");
+ my($ok, $local) = $self->check_module($mod, $ver);
- $json = $json->max_size([$maximum_string_size])
-
- $max_size = $json->get_max_size
+ if ($ok) { $self->chat("Yes ($local)\n") }
+ elsif ($local) { $self->chat("No (" . $self->unsatisfy_how($local, $ver) . ")\n") }
+ else { $self->chat("No\n") }
- 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<decode>
- 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<encode> (yet).
+ return $mod unless $ok;
+ return;
+ }
- If no argument is given, the limit check will be deactivated (same as when
- C<0> is specified).
+ 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 => $]);
+ }
- See L<JSON::XS/SECURITY CONSIDERATIONS> for more info on why this is useful.
+ sub install_deps {
+ my($self, $dir, $depth, @deps) = @_;
- =head2 encode
+ 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;
+ }
+ }
- $json_text = $json->encode($perl_scalar)
+ if (@install) {
+ $self->diag("==> Found dependencies: " . join(", ", map $_->module, @install) . "\n");
+ }
- Converts the given Perl value or data structure to its JSON
- representation. Croaks on error.
+ for my $dep (@install) {
+ $self->install_module($dep->module, $depth + 1, $dep->version, $dep);
+ }
- =head2 decode
+ $self->chdir($self->{base});
+ $self->chdir($dir) if $dir;
- $perl_scalar = $json->decode($json_text)
+ 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;
+ }
+ }
- The opposite of C<encode>: expects a JSON text and tries to parse it,
- returning the resulting simple scalar or reference. Croaks on error.
+ sub unsatisfied_deps {
+ my($self, @deps) = @_;
- =head2 decode_prefix
+ require CPAN::Meta::Check;
+ require CPAN::Meta::Requirements;
- ($perl_scalar, $characters) = $json->decode_prefix($json_text)
+ my $reqs = CPAN::Meta::Requirements->new;
+ for my $dep (grep $_->is_requirement, @deps) {
+ $reqs->add_string_requirement($dep->module => $dep->requires_version || '0');
+ }
- This works like the C<decode> 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.
+ my $ret = CPAN::Meta::Check::check_requirements($reqs, 'requires', $self->{search_inc});
+ grep defined, values %$ret;
+ }
- This is useful if your JSON texts are not delimited by an outer protocol
- and you need to know where the JSON text ends.
+ sub install_deps_bailout {
+ my($self, $target, $dir, $depth, @deps) = @_;
- JSON::PP->new->decode_prefix ("[1] the tail")
- => ([1], 3)
+ 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;
+ }
+ }
- =head1 FLAGS FOR JSON::PP ONLY
+ return 1;
+ }
- The following flags and properties are for JSON::PP only. If you use
- any of these, you can't make your application run faster by replacing
- JSON::PP with JSON::XS. If you need these and also speed boost,
- try L<Cpanel::JSON::XS>, a fork of JSON::XS by Reini Urban, which
- supports some of these.
+ sub build_stuff {
+ my($self, $stuff, $dist, $depth) = @_;
- =head2 allow_singlequote
+ if ($self->{verify} && -e 'SIGNATURE') {
+ $self->verify_signature($dist) or return;
+ }
- $json = $json->allow_singlequote([$enable])
- $enabled = $json->get_allow_singlequote
+ require CPAN::Meta;
- If C<$enable> is true (or missing), then C<decode> will accept
- invalid JSON texts that contain strings that begin and end with
- single quotation marks. C<encode> will not be affected in anyway.
- I<Be aware that this option makes you accept invalid JSON texts
- as if they were valid!>. I suggest only to use this option to
- parse application-specific files written by humans (configuration
- files, resource files etc.)
+ 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} });
+ }
- If C<$enable> is false (the default), then C<decode> will only accept
- valid JSON texts.
+ $dist->{meta} = $dist->{cpanmeta} ? $dist->{cpanmeta}->as_struct : {};
- $json->allow_singlequote->decode(qq|{"foo":'bar'}|);
- $json->allow_singlequote->decode(qq|{'foo':"bar"}|);
- $json->allow_singlequote->decode(qq|{'foo':'bar'}|);
+ if ($self->opts_in_static_install($dist->{cpanmeta})) {
+ $dist->{static_install} = 1;
+ }
- =head2 allow_barekey
+ my @config_deps;
- $json = $json->allow_barekey([$enable])
- $enabled = $json->get_allow_barekey
+ if ($dist->{cpanmeta}) {
+ push @config_deps, Menlo::Dependency->from_prereqs(
+ $dist->{cpanmeta}->effective_prereqs, ['configure'], $self->{install_types},
+ );
+ }
- If C<$enable> is true (or missing), then C<decode> will accept
- invalid JSON texts that contain JSON objects whose names don't
- begin and end with quotation marks. C<encode> will not be affected
- in anyway. I<Be aware that this option makes you accept invalid JSON
- texts as if they were valid!>. I suggest only to use this option to
- parse application-specific files written by humans (configuration
- files, resource files etc.)
+ if (-e 'Build.PL' && !@config_deps) {
+ push @config_deps, Menlo::Dependency->from_versions(
+ { 'Module::Build' => '0.38' }, 'configure',
+ );
+ }
- If C<$enable> is false (the default), then C<decode> will only accept
- valid JSON texts.
+ $self->merge_with_cpanfile($dist, \@config_deps);
- $json->allow_barekey->decode(qq|{foo:"bar"}|);
+ $self->upgrade_toolchain(\@config_deps);
- =head2 allow_bignum
+ my $target = $dist->{meta}{name} ? "$dist->{meta}{name}-$dist->{meta}{version}" : $dist->{dir};
- $json = $json->allow_bignum([$enable])
- $enabled = $json->get_allow_bignum
+ unless ($self->skip_configure($dist, $depth)) {
+ $self->install_deps_bailout($target, $dist->{dir}, $depth, @config_deps)
+ or return;
+ }
- If C<$enable> is true (or missing), then C<decode> will convert
- big integers Perl cannot handle as integer into L<Math::BigInt>
- objects and convert floating numbers into L<Math::BigFloat>
- objects. C<encode> will convert C<Math::BigInt> and C<Math::BigFloat>
- objects into JSON numbers.
+ $self->diag_progress("Configuring $target");
- $json->allow_nonref->allow_bignum;
- $bigfloat = $json->decode('2.000000000000000000000000001');
- print $json->encode($bigfloat);
- # => 2.000000000000000000000000001
+ my $configure_state = $self->configure_this($dist, $depth);
+ $self->diag_ok($configure_state->{configured_ok} ? "OK" : "N/A");
- See also L<MAPPING>.
+ if ($dist->{cpanmeta} && $dist->{source} eq 'cpan') {
+ $dist->{provides} = $dist->{cpanmeta}{provides} || $self->extract_packages($dist->{cpanmeta}, ".");
+ }
- =head2 loose
+ # install direct 'test' dependencies for --installdeps, even with --notest
+ # TODO: remove build dependencies for static install
+ my $deps_only = $self->deps_only($depth);
+ $dist->{want_phases} = $self->{notest} && !$self->deps_only($depth)
+ ? [qw( build runtime )] : [qw( build test runtime )];
- $json = $json->loose([$enable])
- $enabled = $json->get_loose
+ push @{$dist->{want_phases}}, 'develop' if $self->{with_develop} && $depth == 0;
+ push @{$dist->{want_phases}}, 'configure' if $self->{with_configure} && $depth == 0;
- If C<$enable> is true (or missing), then C<decode> will accept
- invalid JSON texts that contain unescaped [\x00-\x1f\x22\x5c]
- characters. C<encode> will not be affected in anyway.
- I<Be aware that this option makes you accept invalid JSON texts
- as if they were valid!>. I suggest only to use this option to
- parse application-specific files written by humans (configuration
- files, resource files etc.)
+ my @deps = $self->find_prereqs($dist);
+ my $module_name = $self->find_module_name($configure_state) || $dist->{meta}{name};
+ $module_name =~ s/-/::/g;
- If C<$enable> is false (the default), then C<decode> will only accept
- valid JSON texts.
+ if ($self->{showdeps}) {
+ for my $dep (@config_deps, @deps) {
+ print $dep->module, ($dep->version ? ("~".$dep->version) : ""), "\n";
+ }
+ return 1;
+ }
- $json->loose->decode(qq|["abc
- def"]|);
+ my $distname = $dist->{meta}{name} ? "$dist->{meta}{name}-$dist->{meta}{version}" : $stuff;
- =head2 escape_slash
+ my $walkup;
+ if ($self->{scandeps}) {
+ $walkup = $self->scandeps_append_child($dist);
+ }
- $json = $json->escape_slash([$enable])
- $enabled = $json->get_escape_slash
+ $self->install_deps_bailout($distname, $dist->{dir}, $depth, @deps)
+ or return;
- If C<$enable> is true (or missing), then C<encode> will explicitly
- escape I<slash> (solidus; C<U+002F>) characters to reduce the risk of
- XSS (cross site scripting) that may be caused by C<< </script> >>
- in a JSON text, with the cost of bloating the size of JSON texts.
+ if ($self->{scandeps}) {
+ unless ($configure_state->{configured_ok}) {
+ my $diag = <<DIAG;
+ ! Configuring $distname failed. See $self->{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;
+ }
- This option may be useful when you embed JSON in HTML, but embedding
- arbitrary JSON in HTML (by some HTML template toolkit or by string
- interpolation) is risky in general. You must escape necessary
- characters in correct order, depending on the context.
+ 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;
+ }
+ }
- C<decode> will not be affected in anyway.
+ my $installed;
+ if ($configure_state->{static_install}) {
+ $self->diag_progress("Building " . ($self->{notest} ? "" : "and testing ") . $distname);
+ $self->build(sub { $configure_state->{static_install}->build }, $distname, $dist, $depth) &&
+ $self->test(sub { $configure_state->{static_install}->build("test") }, $distname, $dist, $depth) &&
+ $self->install(sub { $configure_state->{static_install}->build("install") }, [], $dist, $depth) &&
+ $installed++;
+ } elsif ($configure_state->{use_module_build} && -e 'Build' && -f _) {
+ $self->diag_progress("Building " . ($self->{notest} ? "" : "and testing ") . $distname);
+ $self->build([ $self->{perl}, "./Build" ], $distname, $dist, $depth) &&
+ $self->test([ $self->{perl}, "./Build", "test" ], $distname, $dist, $depth) &&
+ $self->install([ $self->{perl}, "./Build", "install" ], [ "--uninst", 1 ], $dist, $depth) &&
+ $installed++;
+ } elsif ($self->{make} && -e 'Makefile') {
+ $self->diag_progress("Building " . ($self->{notest} ? "" : "and testing ") . $distname);
+ $self->build([ $self->{make} ], $distname, $dist, $depth) &&
+ $self->test([ $self->{make}, "test" ], $distname, $dist, $depth) &&
+ $self->install([ $self->{make}, "install" ], [ "UNINST=1" ], $dist, $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'." }
- =head2 indent_length
+ $self->diag_fail("$why See $self->{log} for details.", 1);
+ return;
+ }
- $json = $json->indent_length($number_of_spaces)
- $length = $json->get_indent_length
+ 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->is_downgrade($version, $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;
+ }
+ }
- This option is only useful when you also enable C<indent> or C<pretty>.
+ sub is_downgrade {
+ my($self, $va, $vb) = @_;
+ eval { version::->new($va) < $vb };
+ }
- JSON::XS indents with three spaces when you C<encode> (if requested
- by C<indent> or C<pretty>), and the number cannot be changed.
- JSON::PP allows you to change/get the number of indent spaces with these
- mutator/accessor. The default number of spaces is three (the same as
- JSON::XS), and the acceptable range is from C<0> (no indentation;
- it'd be better to disable indentation by C<indent(0)>) to C<15>.
+ sub opts_in_static_install {
+ my($self, $meta) = @_;
- =head2 sort_by
+ return if !$self->{static_install};
- $json = $json->sort_by($code_ref)
- $json = $json->sort_by($subroutine_name)
+ # --sudo requires running a separate shell to prevent persistent configuration
+ # uninstall-shadows (default on < 5.12) is not supported in BuildPL spec, yet.
+ return if $self->{sudo} or $self->{uninstall_shadows};
- If you just want to sort keys (names) in JSON objects when you
- C<encode>, enable C<canonical> option (see above) that allows you to
- sort object keys alphabetically.
+ return $meta->{x_static_install} && $meta->{x_static_install} == 1;
+ }
- If you do need to sort non-alphabetically for whatever reasons,
- you can give a code reference (or a subroutine name) to C<sort_by>,
- then the argument will be passed to Perl's C<sort> built-in function.
+ sub skip_configure {
+ my($self, $dist, $depth) = @_;
- As the sorting is done in the JSON::PP scope, you usually need to
- prepend C<JSON::PP::> to the subroutine name, and the special variables
- C<$a> and C<$b> used in the subrontine used by C<sort> function.
+ return 1 if $self->{skip_configure};
+ return 1 if $dist->{static_install};
+ return 1 if $self->no_dynamic_config($dist->{meta}) && $self->deps_only($depth);
- Example:
+ return;
+ }
- my %ORDER = (id => 1, class => 2, name => 3);
- $json->sort_by(sub {
- ($ORDER{$JSON::PP::a} // 999) <=> ($ORDER{$JSON::PP::b} // 999)
- or $JSON::PP::a cmp $JSON::PP::b
- });
- print $json->encode([
- {name => 'CPAN', id => 1, href => 'http://cpan.org'}
- ]);
- # [{"id":1,"name":"CPAN","href":"http://cpan.org"}]
+ sub no_dynamic_config {
+ my($self, $meta) = @_;
+ exists $meta->{dynamic_config} && $meta->{dynamic_config} == 0;
+ }
- Note that C<sort_by> affects all the plain hashes in the data structure.
- If you need finer control, C<tie> necessary hashes with a module that
- implements ordered hash (such as L<Hash::Ordered> and L<Tie::IxHash>).
- C<canonical> and C<sort_by> don't affect the key order in C<tie>d
- hashes.
+ sub deps_only {
+ my($self, $depth) = @_;
+ ($self->{installdeps} && $depth == 0)
+ or $self->{showdeps}
+ or $self->{scandeps};
+ }
- use Hash::Ordered;
- tie my %hash, 'Hash::Ordered',
- (name => 'CPAN', id => 1, href => 'http://cpan.org');
- print $json->encode([\%hash]);
- # [{"name":"CPAN","id":1,"href":"http://cpan.org"}] # order is kept
+ sub perl_requirements {
+ my($self, @requires) = @_;
- =head1 INCREMENTAL PARSING
+ my @perl;
+ for my $requires (grep defined, @requires) {
+ if (exists $requires->{perl}) {
+ push @perl, Menlo::Dependency->new(perl => $requires->{perl});
+ }
+ }
- This section is also taken from JSON::XS.
+ return @perl;
+ }
- In some cases, there is the need for incremental parsing of JSON
- texts. While this module always has to keep both JSON text and resulting
- Perl data structure in memory at one time, it 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<decode_prefix> to see if a full JSON object is available, but
- is much more efficient (and can be implemented with a minimum of method
- calls).
+ sub configure_this {
+ my($self, $dist, $depth) = @_;
- JSON::PP 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 mismatched
- parentheses. 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<max_size>) to ensure the parser will stop
- parsing in the presence if syntax errors.
+ my $deps_only = $self->deps_only($depth);
+ if (-e $self->{cpanfile_path} && $deps_only) {
+ require Module::CPANfile;
+ $dist->{cpanfile} = eval { Module::CPANfile->load($self->{cpanfile_path}) };
+ $self->diag_fail($@, 1) if $@;
- The following methods implement this incremental parser.
+ $self->{cpanfile_global} ||= $dist->{cpanfile};
- =head2 incr_parse
+ return {
+ configured => 1,
+ configured_ok => !!$dist->{cpanfile},
+ use_module_build => 0,
+ };
+ }
- $json->incr_parse( [$string] ) # void context
-
- $obj_or_undef = $json->incr_parse( [$string] ) # scalar context
-
- @obj_or_empty = $json->incr_parse( [$string] ) # list context
+ if ($self->{skip_configure}) {
+ my $eumm = -e 'Makefile';
+ my $mb = -e 'Build' && -f _;
+ return {
+ configured => 1,
+ configured_ok => $eumm || $mb,
+ use_module_build => $mb,
+ };
+ }
- 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 ($deps_only && $self->no_dynamic_config($dist->{meta})) {
+ return {
+ configured => 1,
+ configured_ok => exists $dist->{meta}{prereqs},
+ use_module_build => 0,
+ };
+ }
- If C<$string> is given, then this string is appended to the already
- existing JSON fragment stored in the C<$json> object.
+ my $state = {};
- 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.
+ my $try_static = sub {
+ if ($dist->{static_install}) {
+ $self->chat("Distribution opts in x_static_install: $dist->{meta}{x_static_install}\n");
+ $self->static_install_configure($state, $dist, $depth);
+ }
+ };
- If the method is called in scalar context, then it will try to extract
- exactly I<one> JSON object. If that is successful, it will return this
- object, otherwise it will return C<undef>. If there is a parse error,
- this method will croak just as C<decode> would do (one can then use
- C<incr_skip> to skip the erroneous part). This is the most common way of
- using the method.
+ my $try_eumm = sub {
+ if (-e 'Makefile.PL') {
+ $self->chat("Running Makefile.PL\n");
- 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 (other than
- whitespace) 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.
+ # 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" ], $dist, $depth)) {
+ $state->{configured_ok} = -e 'Makefile';
+ }
+ $state->{configured}++;
+ }
+ };
- Example: Parse some JSON arrays/objects in a given string and return
- them.
+ my $try_mb = sub {
+ if (-e 'Build.PL') {
+ $self->chat("Running Build.PL\n");
+ if ($self->configure([ $self->{perl}, "Build.PL" ], $dist, $depth)) {
+ $state->{configured_ok} = -e 'Build' && -f _;
+ }
+ $state->{use_module_build}++;
+ $state->{configured}++;
+ }
+ };
- my @objs = JSON::PP->new->incr_parse ("[5][7][1,2]");
+ for my $try ($try_static, $try_mb, $try_eumm) {
+ $try->();
+ last if $state->{configured_ok};
+ }
- =head2 incr_text
+ 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';
+ }
+ }
- $lvalue_string = $json->incr_text
+ return $state;
+ }
- This method returns the currently stored JSON fragment as an lvalue, that
- is, you can manipulate it. This I<only> works when a preceding call to
- C<incr_parse> in I<scalar context> 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<will> fail under
- real world conditions). As a special exception, you can also call this
- method before having parsed anything.
+ sub static_install_configure {
+ my($self, $state, $dist, $depth) = @_;
- That means you can only use this function to look at or manipulate text
- before or after complete JSON objects, not while the parser is in the
- middle of parsing a JSON object.
+ my $args = $depth == 0 ? $self->{build_args}{configure} : [];
- 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).
+ require Menlo::Builder::Static;
+ my $builder = Menlo::Builder::Static->new(meta => $dist->{cpanmeta});
+ $self->configure(sub { $builder->configure($args || []) }, $dist, $depth);
- =head2 incr_skip
+ $state->{configured_ok} = 1;
+ $state->{static_install} = $builder;
+ $state->{configured}++;
+ }
- $json->incr_skip
+ sub find_module_name {
+ my($self, $state) = @_;
- This will reset the state of the incremental parser and will remove
- the parsed text from the input buffer so far. This is useful after
- C<incr_parse> 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.
+ return unless $state->{configured_ok};
- The difference to C<incr_reset> is that only text until the parse error
- occurred is removed.
+ if ($state->{use_module_build} &&
+ -e "_build/build_params") {
+ my $params = do { open my $in, "_build/build_params"; 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 eval($1);
+ }
+ }
+ }
- =head2 incr_reset
+ return;
+ }
- $json->incr_reset
+ sub list_files {
+ my $self = shift;
- This completely resets the incremental parser, that is, after this call,
- it will be as if the parser had never parsed anything.
+ 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;
+ }
+ }
- 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.
+ sub extract_packages {
+ my($self, $meta, $dir) = @_;
- =head1 MAPPING
+ 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;
+ };
- Most of this section is also taken from JSON::XS.
+ require Parse::PMFile;
- This section describes how JSON::PP maps Perl values to JSON values and
- vice versa. These mappings are designed to "do the right thing" in most
- circumstances automatically, preserving round-tripping characteristics
- (what you put in comes out as something equivalent).
+ my @files = grep { /\.pm(?:\.PL)?$/ && $try->($_) } $self->list_files;
- For the more enlightened: note that in the following descriptions,
- lowercase I<perl> refers to the Perl interpreter, while uppercase I<Perl>
- refers to the abstract Perl language itself.
+ my $provides = { };
- =head2 JSON -> PERL
+ for my $file (@files) {
+ my $parser = Parse::PMFile->new($meta, { UNSAFE => 1, ALLOW_DEV_VERSION => 1 });
+ my $packages = $parser->parse($file);
- =over 4
+ while (my($package, $meta) = each %$packages) {
+ $provides->{$package} ||= {
+ file => $meta->{infile},
+ ($meta->{version} eq 'undef') ? () : (version => $meta->{version}),
+ };
+ }
+ }
- =item object
+ return $provides;
+ }
- A JSON object becomes a reference to a hash in Perl. No ordering of object
- keys is preserved (JSON does not preserve object key ordering itself).
+ sub save_meta {
+ my($self, $module, $dist, $module_name, $config_deps, $build_deps) = @_;
- =item array
+ return unless $dist->{distvname} && $dist->{source} eq 'cpan';
- A JSON array becomes a reference to an array in Perl.
+ my $base = ($ENV{PERL_MM_OPT} || '') =~ /INSTALL_BASE=/
+ ? ($self->install_base($ENV{PERL_MM_OPT}) . "/lib/perl5") : $Config{sitelibexp};
- =item string
+ my $provides = $dist->{provides};
- 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.
+ File::Path::mkpath("blib/meta", 0, 0777);
- =item number
+ 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,
+ };
- 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.
+ require JSON::PP;
+ open my $fh, ">", "blib/meta/install.json" or die $!;
+ print $fh JSON::PP::encode_json($local);
- If the number consists of digits only, JSON::PP 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).
+ File::Copy::copy("MYMETA.json", "blib/meta/MYMETA.json");
- 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).
+ my @cmd = (
+ ($self->{sudo} ? 'sudo' : ()),
+ $^X,
+ '-MExtUtils::Install=install',
+ '-e',
+ qq[install({ 'blib/meta' => '$base/$Config{archname}/.meta/$dist->{distvname}' })],
+ );
+ $self->run_command(\@cmd);
+ }
- Note that precision is not accuracy - binary floating point values cannot
- represent most decimal fractions exactly, and when converting from and to
- floating point, JSON::PP only guarantees precision up to but not including
- the least significant bit.
+ 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";
+ }
- When C<allow_bignum> is enabled, big integer values and any numeric
- values will be converted into L<Math::BigInt> and L<Math::BigFloat>
- objects respectively, without becoming string scalars or losing
- precision.
+ sub configure_features {
+ my($self, $dist, @features) = @_;
+ map $_->identifier, grep { $self->effective_feature($dist, $_) } @features;
+ }
- =item true, false
+ sub effective_feature {
+ my($self, $dist, $feature) = @_;
- These JSON atoms become C<JSON::PP::true> and C<JSON::PP::false>,
- 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<JSON::PP::is_bool> function.
+ if ($dist->{depth} == 0) {
+ my $value = $self->{features}{$feature->identifier};
+ return $value if defined $value;
+ return 1 if $self->{features}{__all};
+ }
- =item null
+ if ($self->{interactive}) {
+ require CPAN::Meta::Requirements;
- A JSON null atom becomes C<undef> in Perl.
+ $self->diag("[@{[ $feature->description ]}]\n", 1);
- =item shell-style comments (C<< # I<text> >>)
+ 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));
+ }
+ }
- As a nonstandard extension to the JSON syntax that is enabled by the
- C<relaxed> setting, shell-style comments are allowed. They can start
- anywhere outside strings and go till the end of the line.
+ my $reqs = $req->as_string_hash;
+ my @missing;
+ for my $module (keys %$reqs) {
+ if ($self->should_install($module, $req->{$module})) {
+ push @missing, $module;
+ }
+ }
- =back
+ 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;
+ }
- =head2 PERL -> JSON
+ sub find_prereqs {
+ my($self, $dist) = @_;
- 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.
+ my @deps = $self->extract_meta_prereqs($dist);
- =over 4
+ if ($dist->{module} =~ /^Bundle::/i) {
+ push @deps, $self->bundle_deps($dist);
+ }
- =item hash references
+ $self->merge_with_cpanfile($dist, \@deps);
- 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. JSON::PP can optionally sort the hash keys
- (determined by the I<canonical> flag and/or I<sort_by> property), so
- the same data structure will serialise to the same JSON text (given
- same settings and version of JSON::PP), 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.
+ return @deps;
+ }
- =item array references
+ sub merge_with_cpanfile {
+ my($self, $dist, $deps) = @_;
- Perl array references become JSON arrays.
+ if ($self->{cpanfile_requirements} && !$dist->{cpanfile}) {
+ for my $dep (@$deps) {
+ $dep->merge_with($self->{cpanfile_requirements});
+ }
+ }
- =item other references
+ if ($self->{cpanfile_global}) {
+ for my $dep (@$deps) {
+ my $opts = $self->{cpanfile_global}->options_for_module($dep->module)
+ or next;
- 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<false> and C<true> atoms in JSON. You can
- also use C<JSON::PP::false> and C<JSON::PP::true> to improve
- readability.
+ $dep->dist($opts->{dist}) if $opts->{dist};
+ $dep->mirror($opts->{mirror}) if $opts->{mirror};
+ $dep->url($opts->{url}) if $opts->{url};
+ }
+ }
+ }
- to_json [\0, JSON::PP::true] # yields [false,true]
+ sub extract_meta_prereqs {
+ my($self, $dist) = @_;
- =item JSON::PP::true, JSON::PP::false
+ 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 Menlo::Dependency->from_prereqs($prereqs, $dist->{want_phases}, $self->{install_types});
+ }
- These special values become JSON true and JSON false values,
- respectively. You can also use C<\1> and C<\0> directly if you want.
+ require CPAN::Meta;
- =item JSON::PP::null
+ my @meta = qw(MYMETA.json MYMETA.yml);
+ if ($self->no_dynamic_config($dist->{meta})) {
+ push @meta, qw(META.json META.yml);
+ }
- This special value becomes JSON null.
+ my @deps;
+ my($meta_file) = grep -f, @meta;
+ 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);
+ }
+ }
- =item blessed objects
+ $self->diag_fail("No MYMETA file is found after configure. Your toolchain is too old?");
+ return;
+ }
- Blessed objects are not directly representable in JSON, but C<JSON::PP>
- allows various ways of handling objects. See L<OBJECT SERIALISATION>,
- below, for details.
+ sub bundle_deps {
+ my($self, $dist) = @_;
- =item simple scalars
+ my $match;
+ if ($dist->{module}) {
+ $match = sub {
+ my $meta = Module::Metadata->new_from_file($_[0]);
+ $meta && ($meta->name eq $dist->{module});
+ };
+ } else {
+ $match = sub { 1 };
+ }
- Simple Perl scalars (any scalar that is not a reference) are the most
- difficult objects to encode: JSON::PP will encode undefined scalars as
- JSON C<null> values, scalars that have last been used in a string context
- before encoding as JSON strings, and anything else as number value:
+ my @files;
+ File::Find::find({
+ wanted => sub {
+ push @files, File::Spec->rel2abs($_) if /\.pm$/i && $match->($_);
+ },
+ no_chdir => 1,
+ }, '.');
- # dump as number
- encode_json [2] # yields [2]
- encode_json [-3.0e17] # yields [-3e+17]
- my $value = 5; encode_json [$value] # yields [5]
+ my @deps;
- # used as string, so dump as string
- print $value;
- encode_json [$value] # yields ["5"]
+ 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, Menlo::Dependency->new($1, $self->maybe_version($2));
+ }
+ }
+ }
- # undef becomes null
- encode_json [undef] # yields [null]
+ return @deps;
+ }
- You can force the type to be a string by stringifying it:
+ sub maybe_version {
+ my($self, $string) = @_;
+ return $string && $string =~ /^\.?\d/ ? $string : undef;
+ }
- 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
- # (but for older perls)
+ sub extract_prereqs {
+ my($self, $meta, $dist) = @_;
- You can force the type to be a number by numifying it:
+ my @features = $self->configure_features($dist, $meta->features);
- 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.
+ my $prereqs = $meta->effective_prereqs(\@features)->clone;
+ $self->adjust_prereqs($dist, $prereqs);
- You cannot currently force the type in other, less obscure, ways.
+ return Menlo::Dependency->from_prereqs($prereqs, $dist->{want_phases}, $self->{install_types});
+ }
- 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.
+ sub adjust_prereqs {
+ my($self, $dist, $prereqs) = @_;
- JSON::PP (and JSON::XS) trusts what you pass to C<encode> method
- (or C<encode_json> function) is a clean, validated data structure with
- values that can be represented as valid JSON values only, because it's
- not from an external data source (as opposed to JSON texts you pass to
- C<decode> or C<decode_json>, which JSON::PP considers tainted and
- doesn't trust). As JSON::PP doesn't know exactly what you and consumers
- of your JSON texts want the unexpected values to be (you may want to
- convert them into null, or to stringify them with or without
- normalisation (string representation of infinities/NaN may vary
- depending on platforms), or to croak without conversion), you're advised
- to do what you and your consumers need before you encode, and also not
- to numify values that may start with values that look like a number
- (including infinities/NaN), without validating.
+ # 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
+ if (-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);
+ }
+ }
+ }
- =back
+ # Static installation is optional and we're adding runtime dependencies
+ if ($dist->{static_install}) {
+ my $reqs = $prereqs->requirements_for('test' => 'requires');
+ $reqs->add_minimum('TAP::Harness::Env' => 0);
+ }
+ }
- =head2 OBJECT SERIALISATION
+ sub cleanup_workdirs {
+ my $self = shift;
- As for Perl objects, JSON::PP only supports a pure JSON representation (without the ability to deserialise the object automatically again).
+ my $expire = time - 24 * 60 * 60 * $self->{auto_cleanup};
+ my @targets;
- =head3 SERIALISATION
+ 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";
+ }
+ }
- What happens when C<JSON::PP> encounters a Perl object depends on the
- C<allow_blessed>, C<convert_blessed> and C<allow_bignum> settings, which are
- used in this order:
+ 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
+ }
+ }
- =over 4
+ sub scandeps_append_child {
+ my($self, $dist) = @_;
- =item 1. C<convert_blessed> is enabled and the object has a C<TO_JSON> method.
+ my $new_node = [ $dist, [] ];
- In this case, the C<TO_JSON> method of the object is invoked in scalar
- context. It must return a single scalar that can be directly encoded into
- JSON. This scalar replaces the object in the JSON text.
+ my $curr_node = $self->{scandeps_current} || [ undef, $self->{scandeps_tree} ];
+ push @{$curr_node->[1]}, $new_node;
- For example, the following C<TO_JSON> method will convert all L<URI>
- objects to JSON strings when serialised. The fact that these values
- originally were L<URI> objects is lost.
+ $self->{scandeps_current} = $new_node;
- sub URI::TO_JSON {
- my ($uri) = @_;
- $uri->as_string
- }
+ return sub { $self->{scandeps_current} = $curr_node };
+ }
- =item 2. C<allow_bignum> is enabled and the object is a C<Math::BigInt> or C<Math::BigFloat>.
+ sub dump_scandeps {
+ my $self = shift;
- The object will be serialised as a JSON number value.
+ 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 CPAN::Meta::YAML;
+ print CPAN::Meta::YAML::Dump($self->{scandeps_tree});
+ } else {
+ $self->diag("Unknown format: $self->{format}\n");
+ }
+ }
- =item 3. C<allow_blessed> is enabled.
+ sub walk_down {
+ my($self, $cb, $pre) = @_;
+ $self->_do_walk_down($self->{scandeps_tree}, $cb, 0, $pre);
+ }
- The object will be serialised as a JSON null value.
+ sub _do_walk_down {
+ my($self, $children, $cb, $depth, $pre) = @_;
- =item 4. none of the above
+ # 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;
+ }
+ }
- If none of the settings are enabled or the respective methods are missing,
- C<JSON::PP> throws an exception.
+ sub DESTROY {
+ my $self = shift;
+ $self->{at_exit}->($self) if $self->{at_exit};
+ }
- =back
+ # Utils
- =head1 ENCODING/CODESET FLAG NOTES
+ sub mirror {
+ my($self, $uri, $local) = @_;
+ if ($uri =~ /^file:/) {
+ $self->file_mirror($uri, $local);
+ } else {
+ $self->{http}->mirror($uri, $local);
+ }
+ }
- This section is taken from JSON::XS.
+ sub untar { $_[0]->{_backends}{untar}->(@_) };
+ sub unzip { $_[0]->{_backends}{unzip}->(@_) };
- The interested reader might have seen a number of flags that signify
- encodings or codesets - C<utf8>, C<latin1> and C<ascii>. There seems to be
- some confusion on what these do, so here is a short comparison:
+ sub uri_to_file {
+ my($self, $uri) = @_;
- C<utf8> controls whether the JSON text created by C<encode> (and expected
- by C<decode>) is UTF-8 encoded or not, while C<latin1> and C<ascii> only
- control whether C<encode> escapes character values outside their respective
- codeset range. Neither of these flags conflict with each other, although
- some combinations make less sense than others.
+ # file:///path/to/file -> /path/to/file
+ # file://C:/path -> C:/path
+ if ($uri =~ s!file:/+!!) {
+ $uri = "/$uri" unless $uri =~ m![a-zA-Z]:!;
+ }
- Care has been taken to make all flags symmetrical with respect to
- C<encode> and C<decode>, that is, texts encoded with any combination of
- these flag values will be correctly decoded when the same flags are used
- - in general, if you use different flag settings while encoding vs. when
- decoding you likely have a bug somewhere.
+ return $uri;
+ }
- Below comes a verbose discussion of these flags. Note that a "codeset" is
- simply an abstract set of character-codepoint pairs, while an encoding
- takes those codepoint numbers and I<encodes> them, in our case into
- octets. Unicode is (among other things) a codeset, UTF-8 is an encoding,
- and ISO-8859-1 (= latin 1) and ASCII are both codesets I<and> encodings at
- the same time, which can be confusing.
+ sub file_get {
+ my($self, $uri) = @_;
+ my $file = $self->uri_to_file($uri);
+ open my $fh, "<$file" or return;
+ join '', <$fh>;
+ }
- =over 4
+ sub file_mirror {
+ my($self, $uri, $path) = @_;
+ my $file = $self->uri_to_file($uri);
- =item C<utf8> flag disabled
+ my $source_mtime = (stat $file)[9];
- When C<utf8> is disabled (the default), then C<encode>/C<decode> generate
- and expect Unicode strings, that is, characters with high ordinal Unicode
- values (> 255) will be encoded as such characters, and likewise such
- characters are decoded as-is, no changes to them will be done, except
- "(re-)interpreting" them as Unicode codepoints or Unicode characters,
- respectively (to Perl, these are the same thing in strings unless you do
- funny/weird/dumb stuff).
+ # Don't mirror a file that's already there (like the index)
+ return 1 if -e $path && (stat $path)[9] >= $source_mtime;
- This is useful when you want to do the encoding yourself (e.g. when you
- want to have UTF-16 encoded JSON texts) or when some other layer does
- the encoding for you (for example, when printing to a terminal using a
- filehandle that transparently encodes to UTF-8 you certainly do NOT want
- to UTF-8 encode your data first and have Perl encode it another time).
+ File::Copy::copy($file, $path);
- =item C<utf8> flag enabled
+ utime $source_mtime, $source_mtime, $path;
+ }
- If the C<utf8>-flag is enabled, C<encode>/C<decode> will encode all
- characters using the corresponding UTF-8 multi-byte sequence, and will
- expect your input strings to be encoded as UTF-8, that is, no "character"
- of the input string must have any value > 255, as UTF-8 does not allow
- that.
+ sub configure_http {
+ my $self = shift;
- The C<utf8> flag therefore switches between two modes: disabled means you
- will get a Unicode string in Perl, enabled means you get an UTF-8 encoded
- octet/binary string in Perl.
+ require HTTP::Tinyish;
- =item C<latin1> or C<ascii> flags enabled
+ my @try = qw(HTTPTiny);
+ unshift @try, 'Wget' if $self->{try_wget};
+ unshift @try, 'Curl' if $self->{try_curl};
+ unshift @try, 'LWP' if $self->{try_lwp};
- With C<latin1> (or C<ascii>) enabled, C<encode> will escape characters
- with ordinal values > 255 (> 127 with C<ascii>) and encode the remaining
- characters as specified by the C<utf8> flag.
+ my @protocol = ('http');
+ push @protocol, 'https'
+ if grep /^https:/, @{$self->{mirrors}};
- If C<utf8> is disabled, then the result is also correctly encoded in those
- character sets (as both are proper subsets of Unicode, meaning that a
- Unicode string with all character values < 256 is the same thing as a
- ISO-8859-1 string, and a Unicode string with all character values < 128 is
- the same thing as an ASCII string in Perl).
+ my $backend;
+ for my $try (map "HTTP::Tinyish::$_", @try) {
+ if (my $meta = HTTP::Tinyish->configure_backend($try)) {
+ if ((grep $try->supports($_), @protocol) == @protocol) {
+ for my $tool (sort keys %$meta){
+ (my $desc = $meta->{$tool}) =~ s/^(.*?)\n.*/$1/s;
+ $self->chat("You have $tool: $desc\n");
+ }
+ $backend = $try;
+ last;
+ }
+ }
+ }
- If C<utf8> is enabled, you still get a correct UTF-8-encoded string,
- regardless of these flags, just some more characters will be escaped using
- C<\uXXXX> then before.
+ $backend->new(agent => "Menlo/$Menlo::VERSION", verify_SSL => 1);
+ }
- Note that ISO-8859-1-I<encoded> strings are not compatible with UTF-8
- encoding, while ASCII-encoded strings are. That is because the ISO-8859-1
- encoding is NOT a subset of UTF-8 (despite the ISO-8859-1 I<codeset> being
- a subset of Unicode), while ASCII is.
+ sub init_tools {
+ my $self = shift;
- Surprisingly, C<decode> will ignore these flags and so treat all input
- values as governed by the C<utf8> flag. If it is disabled, this allows you
- to decode ISO-8859-1- and ASCII-encoded strings, as both strict subsets of
- Unicode. If it is enabled, you can correctly decode UTF-8 encoded strings.
+ return if $self->{initialized}++;
- So neither C<latin1> nor C<ascii> are incompatible with the C<utf8> flag -
- they only govern when the JSON output engine escapes a character or not.
+ if ($self->{make} = which($Config{make})) {
+ $self->chat("You have make $self->{make}\n");
+ }
- The main use for C<latin1> is to relatively efficiently store binary data
- as JSON, at the expense of breaking compatibility with most JSON decoders.
+ $self->{http} = $self->configure_http;
- The main use for C<ascii> is to force the output to not contain characters
- with values > 127, which means you can interpret the resulting string
- as UTF-8, ISO-8859-1, ASCII, KOI8-R or most about any character set and
- 8-bit-encoding, and still get the same data structure back. This is useful
- when your channel for JSON transfer is not 8-bit clean or the encoding
- might be mangled in between (e.g. in mail), and works because ASCII is a
- proper subset of most 8-bit and multibyte encodings in use in the world.
+ my $tar = which('tar');
+ my $tar_ver;
+ my $maybe_bad_tar = sub { WIN32 || BAD_TAR || (($tar_ver = `@{[ qs $tar ]} --version 2>/dev/null`) =~ /GNU.*1\.13/i) };
- =back
+ if ($tar && !$maybe_bad_tar->()) {
+ chomp $tar_ver;
+ $self->chat("You have $tar: $tar_ver\n");
+ $self->{_backends}{untar} = sub {
+ my($self, $tarfile) = @_;
- =head1 SEE ALSO
+ my $xf = ($self->{verbose} ? 'v' : '')."xf";
+ my $ar = $tarfile =~ /bz2$/ ? 'j' : 'z';
- The F<json_pp> command line utility for quick experiments.
+ my($root, @others) = `@{[ qs $tar ]} ${ar}tf @{[ qs $tarfile ]}`
+ or return undef;
- L<JSON::XS>, L<Cpanel::JSON::XS>, and L<JSON::Tiny> for faster alternatives.
- L<JSON> and L<JSON::MaybeXS> for easy migration.
+ FILE: {
+ chomp $root;
+ $root =~ s!^\./!!;
+ $root =~ s{^(.+?)/.*$}{$1};
- L<JSON::backportPP::Compat5005> and L<JSON::backportPP::Compat5006> for older perl users.
+ if (!length($root)) {
+ # archive had ./ as the first entry, so try again
+ $root = shift(@others);
+ redo FILE if $root;
+ }
+ }
- RFC4627 (L<http://www.ietf.org/rfc/rfc4627.txt>)
+ $self->run_command([ $tar, $ar.$xf, $tarfile ]);
+ return $root if -d $root;
- =head1 AUTHOR
+ $self->diag_fail("Bad archive: $tarfile");
+ return undef;
+ }
+ } elsif ( $tar
+ and my $gzip = which('gzip')
+ and my $bzip2 = 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) = `@{[ qs $ar ]} -dc @{[ qs $tarfile ]} | @{[ qs $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;
+ }
+ }
- Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
+ system "@{[ qs $ar ]} -dc @{[ qs $tarfile ]} | @{[ qs $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";
+ };
+ }
- =head1 COPYRIGHT AND LICENSE
+ if (my $unzip = which('unzip')) {
+ $self->chat("You have $unzip\n");
+ $self->{_backends}{unzip} = sub {
+ my($self, $zipfile) = @_;
- Copyright 2007-2016 by Makamaka Hannyaharamitu
+ my @opt = $self->{verbose} ? () : ('-q');
+ my(undef, $root, @others) = `@{[ qs $unzip ]} -t @{[ qs $zipfile ]}`
+ or return undef;
+ FILE: {
+ chomp $root;
+ if ($root !~ s{^\s+testing:\s+([^/]+)/.*?\s+OK$}{$1}) {
+ $root = shift(@others);
+ redo FILE if $root;
+ }
+ }
- This library is free software; you can redistribute it and/or modify
- it under the same terms as Perl itself.
+ $self->run_command([ $unzip, @opt, $zipfile ]);
+ return $root if -d $root;
- =cut
-JSON_BACKPORTPP
-
-$fatpacked{"JSON/backportPP/Boolean.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_BACKPORTPP_BOOLEAN';
- package # This is JSON::backportPP
- JSON::PP::Boolean;
+ $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();
+ }
- use strict;
- use overload (
- "0+" => sub { ${$_[0]} },
- "++" => sub { $_[0] = ${$_[0]} + 1 },
- "--" => sub { $_[0] = ${$_[0]} - 1 },
- fallback => 1,
- );
+ my ($root) = $zip->membersMatching( qr<^[^/]+/$> );
+ $root &&= $root->fileName;
+ return -d $root ? $root : undef;
+ };
+ }
+ }
- $JSON::backportPP::Boolean::VERSION = '2.94';
+ sub mask_uri_passwords {
+ my($self, @strings) = @_;
+ s{ (https?://) ([^:/]+) : [^@/]+ @ }{$1$2:********@}gx for @strings;
+ return @strings;
+ }
1;
__END__
+ =encoding utf-8
+
=head1 NAME
- JSON::PP::Boolean - dummy module providing JSON::PP::Boolean
+ Menlo::CLI::Compat - cpanm compatible CPAN installer
=head1 SYNOPSIS
- # do not "use" yourself
+ use Menlo::CLI::Compat;
+
+ my $app = Menlo::CLI::Compat->new;
+ $app->parse_options(@ARGV);
+ $app->run;
=head1 DESCRIPTION
- This module exists only to provide overload resolution for Storable and similar modules. See
- L<JSON::PP> for more info about this class.
+ Menlo::CLI::Compat is a port of App::cpanminus to Menlo, and provides
+ a compatibility layer for users and clients to depend on the specific
+ cpanm behaviors.
- =head1 AUTHOR
+ =head1 SEE ALSO
- This idea is from L<JSON::XS::Boolean> written by Marc Lehmann <schmorp[at]schmorp.de>
+ L<Menlo>, L<Menlo::Legacy>
=cut
-JSON_BACKPORTPP_BOOLEAN
+MENLO_CLI_COMPAT
-$fatpacked{"JSON/backportPP/Compat5005.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_BACKPORTPP_COMPAT5005';
- package # This is JSON::backportPP
- JSON::backportPP5005;
-
- use 5.005;
+$fatpacked{"Menlo/Dependency.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MENLO_DEPENDENCY';
+ package Menlo::Dependency;
use strict;
+ use CPAN::Meta::Requirements;
+ use Class::Tiny qw( module version type original_version dist mirror url );
- my @properties;
-
- $JSON::PP5005::VERSION = '1.10';
+ sub BUILDARGS {
+ my($class, $module, $version, $type) = @_;
+ return {
+ module => $module,
+ version => $version,
+ type => $type || 'requires',
+ };
+ }
- BEGIN {
+ sub from_prereqs {
+ my($class, $prereqs, $phases, $types) = @_;
- sub utf8::is_utf8 {
- 0; # It is considered that UTF8 flag off for Perl 5.005.
+ my @deps;
+ for my $type (@$types) {
+ push @deps, $class->from_versions(
+ $prereqs->merged_requirements($phases, [$type])->as_string_hash,
+ $type,
+ );
}
- sub utf8::upgrade {
- }
+ return @deps;
+ }
- sub utf8::downgrade {
- 1; # must always return true.
- }
+ sub from_versions {
+ my($class, $versions, $type) = @_;
- sub utf8::encode {
+ my @deps;
+ while (my($module, $version) = each %$versions) {
+ push @deps, $class->new($module, $version, $type)
}
- sub utf8::decode {
- }
+ @deps;
+ }
+
+ sub merge_with {
+ my($self, $requirements) = @_;
- *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;
+ # save the original requirement
+ $self->original_version($self->version);
- # missing in B module.
- sub B::SVp_IOK () { 0x01000000; }
- sub B::SVp_NOK () { 0x02000000; }
- sub B::SVp_POK () { 0x04000000; }
+ # 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));
+ }
- $INC{'bytes.pm'} = 1; # dummy
+ $self->version( $requirements->requirements_for_module($self->module) );
}
+ sub requires_version {
+ my $self = shift;
+ # original_version may be 0
+ if (defined $self->original_version) {
+ return $self->original_version;
+ }
- sub _encode_ascii {
- join('', map { $_ <= 127 ? chr($_) : sprintf('\u%04x', $_) } unpack('C*', $_[0]) );
+ $self->version;
}
-
- sub _encode_latin1 {
- join('', map { chr($_) } unpack('C*', $_[0]) );
+ sub is_requirement {
+ $_[0]->type eq 'requires';
}
+ 1;
+MENLO_DEPENDENCY
+
+$fatpacked{"Menlo/Index/MetaCPAN.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MENLO_INDEX_METACPAN';
+ use 5.008001;
+ use strict;
+ use warnings;
+
+ package Menlo::Index::MetaCPAN;
+ # ABSTRACT: Search index via MetaCPAN
+ # VERSION
- 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));
+ use parent 'CPAN::Common::Index';
- 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");
- }
- }
+ use Class::Tiny qw/uri include_dev/;
+ use Carp;
+ use HTTP::Tinyish;
+ use JSON::PP ();
+ use Time::Local ();
- sub _decode_unicode {
- my ($u) = @_;
- my ($utf8bit);
+ sub BUILD {
+ my $self = shift;
+ my $uri = $self->uri;
+ $uri = "https://fastapi.metacpan.org/v1/download_url/"
+ unless defined $uri;
+ # ensure URI ends in '/'
+ $uri =~ s{/?$}{/};
+ $self->uri($uri);
+ return;
+ }
- if ( $u =~ /^00([89a-f][0-9a-f])$/i ) { # 0x80-0xff
- return pack( 'H2', $1 );
- }
+ sub search_packages {
+ my ( $self, $args ) = @_;
+ Carp::croak("Argument to search_packages must be hash reference")
+ unless ref $args eq 'HASH';
+
+ my $range;
+ if ( $args->{version} ) {
+ $range = "== $args->{version}";
+ } elsif ( $args->{version_range} ) {
+ $range = $args->{version_range};
+ }
+ my %query = (
+ ($self->include_dev ? (dev => 1) : ()),
+ ($range ? (version => $range) : ()),
+ );
+ my $query = join "&", map { "$_=" . $self->_uri_escape($query{$_}) } sort keys %query;
- my $bit = unpack("B*", pack("H*", $u));
+ my $uri = $self->uri . $args->{package} . ($query ? "?$query" : "");
+ my $res = HTTP::Tinyish->new->get($uri);
+ return unless $res->{success};
- 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");
+ my $dist_meta = eval { JSON::PP::decode_json($res->{content}) };
+ if ($dist_meta && $dist_meta->{download_url}) {
+ (my $distfile = $dist_meta->{download_url}) =~ s!.+/authors/id/\w/\w\w/!!;
+
+ return {
+ package => $args->{package},
+ version => $dist_meta->{version},
+ uri => "cpan:///distfile/$distfile",
+ download_uri => $self->_download_uri("http://cpan.metacpan.org", $distfile),
+ };
}
- return pack('B*', $utf8bit);
+ return;
}
+ sub _parse_date {
+ my($self, $date) = @_;
+ my @date = $date =~ /^(\d{4})-(\d\d)-(\d\d)T(\d\d):(\d\d):(\d\d)$/;
+ Time::Local::timegm($date[5], $date[4], $date[3], $date[2], $date[1] - 1, $date[0] - 1900);
+ }
- 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");
- }
+ sub _uri_escape {
+ my($self, $string) = @_;
+ $string =~ s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/eg;
+ $string;
+ }
- $_[0]->{_incr_parser}->{incr_text} = $_[1] if ( @_ > 1 );
- $_[0]->{_incr_parser}->{incr_text};
+ sub _download_uri {
+ my($self, $base, $distfile) = @_;
+ join "/", $base, "authors/id", substr($distfile, 0, 1), substr($distfile, 0, 2), $distfile;
}
+ sub index_age { return time } # pretend always current
- 1;
- __END__
+ sub search_authors { return } # not supported
- =pod
+ 1;
- =head1 NAME
+ =for Pod::Coverage attributes validate_attributes search_packages search_authors BUILD
- JSON::PP5005 - Helper module in using JSON::PP in Perl 5.005
+ =head1 SYNOPSIS
- =head1 DESCRIPTION
+ use CPAN::Common::Index::MetaCPAN;
- JSON::PP calls internally.
+ $index = CPAN::Common::Index::MetaCPAN->new({ include_dev => 1 });
+ $index->search_packages({ package => "Moose", version => "1.1" });
+ $index->search_packages({ package => "Moose", version_range => ">= 1.1, < 2" });
- =head1 AUTHOR
+ =head1 DESCRIPTION
- Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
+ This module implements a CPAN::Common::Index that searches for packages against
+ the MetaCPAN API.
+ This backend supports searching modules with a version range (as
+ specified in L<CPAN::Meta::Spec>) which is translated into MetaCPAN
+ search query.
- =head1 COPYRIGHT AND LICENSE
+ There is also a support for I<dev> release search, by passing
+ C<include_dev> parameter to the index object.
- Copyright 2007-2012 by Makamaka Hannyaharamitu
+ The result may include an optional field C<download_uri> which
+ suggests a specific mirror URL to download from, which can be
+ C<backpan.org> if the archive was deleted, or C<cpan.metacpan.org> if
+ the release date is within 1 day (because some mirrors might not have
+ synced it yet).
- This library is free software; you can redistribute it and/or modify
- it under the same terms as Perl itself.
+ There is no support for searching packages with a regular expression, nor searching authors.
=cut
-JSON_BACKPORTPP_COMPAT5005
+ # vim: ts=4 sts=4 sw=4 et:
+MENLO_INDEX_METACPAN
-$fatpacked{"JSON/backportPP/Compat5006.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_BACKPORTPP_COMPAT5006';
- package # This is JSON::backportPP
- JSON::backportPP56;
-
- use 5.006;
+$fatpacked{"Menlo/Index/MetaDB.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MENLO_INDEX_METADB';
+ use 5.008001;
use strict;
+ use warnings;
- my @properties;
+ package Menlo::Index::MetaDB;
+ # ABSTRACT: Search index via CPAN MetaDB
- $JSON::PP56::VERSION = '1.08';
+ our $VERSION = "1.9019";
- BEGIN {
+ use parent 'CPAN::Common::Index';
- sub utf8::is_utf8 {
- my $len = length $_[0]; # char length
- {
- use bytes; # byte length;
- return $len != length $_[0]; # if !=, UTF8-flagged on.
- }
- }
+ use Class::Tiny qw/uri/;
+ use Carp;
+ use CPAN::Meta::YAML;
+ use CPAN::Meta::Requirements;
+ use HTTP::Tiny;
- sub utf8::upgrade {
- ; # noop;
- }
+ sub BUILD {
+ my $self = shift;
+ my $uri = $self->uri;
+ $uri = "http://cpanmetadb.plackperl.org/v1.0/"
+ unless defined $uri;
+ # ensure URI ends in '/'
+ $uri =~ s{/?$}{/};
+ $self->uri($uri);
+ return;
+ }
+
+ sub search_packages {
+ my ( $self, $args ) = @_;
+ Carp::croak("Argument to search_packages must be hash reference")
+ unless ref $args eq 'HASH';
+ return
+ unless exists $args->{package} && ref $args->{package} eq '';
- sub utf8::downgrade ($;$) {
- return 1 unless ( utf8::is_utf8( $_[0] ) );
+ my $mod = $args->{package};
- 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);
- }
+ if ($args->{version} || $args->{version_range}) {
+ my $res = HTTP::Tiny->new->get( $self->uri . "history/$mod" );
+ return unless $res->{success};
+
+ my $range = defined $args->{version} ? "== $args->{version}" : $args->{version_range};
+ my $reqs = CPAN::Meta::Requirements->from_string_hash({ $mod => $range });
+
+ my @found;
+ for my $line ( split /\r?\n/, $res->{content} ) {
+ if ($line =~ /^$mod\s+(\S+)\s+(\S+)$/) {
+ push @found, {
+ version => $1,
+ version_o => version::->parse($1),
+ distfile => $2,
+ };
}
- $_[0] = $downgrade;
- return 1;
- }
- else {
- Carp::croak("Wide character in subroutine entry") unless ( $_[1] );
- 0;
}
- }
+ return unless @found;
+ $found[-1]->{latest} = 1;
- sub utf8::encode ($) { # UTF8 flag off
- if ( utf8::is_utf8( $_[0] ) ) {
- $_[0] = pack( "C*", unpack( "C*", $_[0] ) );
+ my $match;
+ for my $try (sort { $b->{version_o} <=> $a->{version_o} } @found) {
+ if ($reqs->accepts_module($mod => $try->{version_o})) {
+ $match = $try, last;
+ }
}
- else {
- $_[0] = pack( "U*", unpack( "C*", $_[0] ) );
- $_[0] = pack( "C*", unpack( "C*", $_[0] ) );
+
+ if ($match) {
+ my $file = $match->{distfile};
+ $file =~ s{^./../}{}; # strip leading
+ return {
+ package => $mod,
+ version => $match->{version},
+ uri => "cpan:///distfile/$file",
+ ($match->{latest} ? () :
+ (download_uri => "http://backpan.perl.org/authors/id/$match->{distfile}")),
+ };
+ }
+ } else {
+ my $res = HTTP::Tiny->new->get( $self->uri . "package/$mod" );
+ return unless $res->{success};
+
+ if ( my $yaml = CPAN::Meta::YAML->read_string( $res->{content} ) ) {
+ my $meta = $yaml->[0];
+ if ( $meta && $meta->{distfile} ) {
+ my $file = $meta->{distfile};
+ $file =~ s{^./../}{}; # strip leading
+ return {
+ package => $mod,
+ version => $meta->{version},
+ uri => "cpan:///distfile/$file",
+ };
+ }
}
}
+ return;
+ }
- sub utf8::decode ($) { # UTF8 flag on
- if ( _is_valid_utf8( $_[0] ) ) {
- utf8::downgrade( $_[0] );
- $_[0] = pack( "U*", unpack( "U*", $_[0] ) );
- }
- }
+ sub index_age { return time }; # pretend always current
+ sub search_authors { return }; # not supported
- *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;
+ 1;
- unless ( defined &B::SVp_NOK ) { # missing in B module.
- eval q{ sub B::SVp_NOK () { 0x02000000; } };
- }
+ =for Pod::Coverage attributes validate_attributes search_packages search_authors BUILD
- }
+ =head1 SYNOPSIS
+ use CPAN::Common::Index::MetaDB;
+ $index = CPAN::Common::Index::MetaDB->new;
- sub _encode_ascii {
- join('',
- map {
- $_ <= 127 ?
- chr($_) :
- $_ <= 65535 ?
- sprintf('\u%04x', $_) : sprintf('\u%x\u%x', JSON::PP::_encode_surrogates($_));
- } _unpack_emu($_[0])
- );
- }
+ $index->search_packages({ package => "Moose" });
+ $index->search_packages({ package => "Moose", version_range => ">= 2.0" });
+ =head1 DESCRIPTION
- sub _encode_latin1 {
- join('',
- map {
- $_ <= 255 ?
- chr($_) :
- $_ <= 65535 ?
- sprintf('\u%04x', $_) : sprintf('\u%x\u%x', JSON::PP::_encode_surrogates($_));
- } _unpack_emu($_[0])
- );
- }
+ This module implements a CPAN::Common::Index that searches for packages against
+ the same CPAN MetaDB API used by L<cpanminus>.
+ There is no support for advanced package queries or searching authors. It just
+ takes a package name and returns the corresponding version and distribution.
- 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]);
- }
+ =cut
+ # vim: ts=4 sts=4 sw=4 et:
+MENLO_INDEX_METADB
+
+$fatpacked{"Menlo/Index/Mirror.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MENLO_INDEX_MIRROR';
+ package Menlo::Index::Mirror;
+ use strict;
+ use parent qw(CPAN::Common::Index::Mirror);
+ use Class::Tiny qw(fetcher);
- sub _is_valid_utf8 {
- my $str = $_[0];
- my $is_utf8;
+ use File::Basename ();
+ use File::Spec ();
+ use URI ();
- 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;
- }
+ our $HAS_IO_UNCOMPRESS_GUNZIP = eval { require IO::Uncompress::Gunzip };
+
+ my %INDICES = (
+ # mailrc => 'authors/01mailrc.txt.gz',
+ packages => 'modules/02packages.details.txt.gz',
+ );
+
+ sub refresh_index {
+ my $self = shift;
+ for my $file ( values %INDICES ) {
+ my $remote = URI->new_abs( $file, $self->mirror );
+ $remote =~ s/\.gz$//
+ unless $HAS_IO_UNCOMPRESS_GUNZIP;
+ my $local = File::Spec->catfile( $self->cache, File::Basename::basename($file) );
+ $self->fetcher->($remote, $local)
+ or Carp::croak( "Cannot fetch $remote to $local");
+ if ($HAS_IO_UNCOMPRESS_GUNZIP) {
+ ( my $uncompressed = $local ) =~ s/\.gz$//;
+ IO::Uncompress::Gunzip::gunzip( $local, $uncompressed )
+ or Carp::croak "gunzip failed: $IO::Uncompress::Gunzip::GunzipError\n";
}
}
-
- return $is_utf8;
}
+ 1;
+MENLO_INDEX_MIRROR
+
+$fatpacked{"Menlo/Legacy.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MENLO_LEGACY';
+ package Menlo::Legacy;
+
+ use strict;
+ our $VERSION = '1.9022';
1;
__END__
- =pod
+ =encoding utf-8
=head1 NAME
- JSON::PP56 - Helper module in using JSON::PP in Perl 5.6
+ Menlo::Legacy - Legacy internal and client support for Menlo
=head1 DESCRIPTION
- JSON::PP calls internally.
+ Menlo::Legacy is a package to install L<Menlo::CLI::Compat> which is a
+ compatibility library that implements the classic version of cpanminus
+ internals and behavios. This is so that existing users of cpanm and
+ API clients such as L<Carton>, L<Carmel> and L<App::cpm>) can rely on
+ the stable features and specific behaviors of cpanm.
+
+ This way Menlo can evolve and be refactored without the fear of
+ breaking any downstream clients, including C<cpanm> itself.
=head1 AUTHOR
- Makamaka Hannyaharamitu, E<lt>makamaka[at]cpan.orgE<gt>
+ Tatsuhiko Miyagawa E<lt>miyagawa@bulknews.netE<gt>
+ =head1 COPYRIGHT
- =head1 COPYRIGHT AND LICENSE
+ Copyright 2018- Tatsuhiko Miyagawa
- Copyright 2007-2012 by Makamaka Hannyaharamitu
+ =head1 LICENSE
This library is free software; you can redistribute it and/or modify
- it under the same terms as Perl itself.
+ it under the same terms as Perl itself.
+
+ =head1 SEE ALSO
+
+ L<Menlo::CLI::Compat>
=cut
+MENLO_LEGACY
+
+$fatpacked{"Menlo/Util.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MENLO_UTIL';
+ package Menlo::Util;
+ use strict;
+
+ use Exporter;
+ our @ISA = qw(Exporter);
+ our @EXPORT_OK = qw(WIN32);
+
+ use constant WIN32 => $^O eq 'MSWin32';
-JSON_BACKPORTPP_COMPAT5006
+ if (WIN32) {
+ require Win32::ShellQuote;
+ *shell_quote = \&Win32::ShellQuote::quote_native;
+ } else {
+ require String::ShellQuote;
+ *shell_quote = \&String::ShellQuote::shell_quote_best_effort;
+ }
+
+ 1;
+
+MENLO_UTIL
$fatpacked{"Module/CPANfile.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE';
package Module::CPANfile;
@@ -68438,7 +50973,7 @@ $fatpacked{"Module/CPANfile.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
use Module::CPANfile::Environment;
use Module::CPANfile::Requirement;
- our $VERSION = '1.1002';
+ our $VERSION = '1.1004';
BEGIN {
if (${^TAINT}) {
@@ -68533,10 +51068,8 @@ $fatpacked{"Module/CPANfile.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
sub prereqs_with {
my($self, @feature_identifiers) = @_;
- my $prereqs = $self->prereqs;
my @others = map { $self->feature($_)->prereqs } @feature_identifiers;
-
- $prereqs->with_merged_prereqs(\@others);
+ $self->prereqs->with_merged_prereqs(\@others);
}
sub prereq_specs {
@@ -68571,10 +51104,9 @@ $fatpacked{"Module/CPANfile.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
CPAN::Meta->new($struct)->save($file, { version => $version });
}
- sub _dump {
- my $str = shift;
+ sub _d($) {
require Data::Dumper;
- chomp(my $value = Data::Dumper->new([$str])->Terse(1)->Dump);
+ chomp(my $value = Data::Dumper->new([$_[0]])->Terse(1)->Dump);
$value;
}
@@ -68594,9 +51126,9 @@ $fatpacked{"Module/CPANfile.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
$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 .= "feature @{[ _d $feature->{identifier} ]}, @{[ _d $feature->{description} ]} => sub {\n";
+ $code .= $self->_dump_prereqs($feature->{prereqs}->as_string_hash, $include_empty, 4);
+ $code .= "};\n\n";
}
$code =~ s/\n+$/\n/s;
@@ -68609,7 +51141,7 @@ $fatpacked{"Module/CPANfile.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
my $code = "";
for my $url (@$mirrors) {
- $code .= "mirror '$url';\n";
+ $code .= "mirror @{[ _d $url ]};\n";
}
$code =~ s/\n+$/\n/s;
@@ -68622,7 +51154,7 @@ $fatpacked{"Module/CPANfile.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
my $code = '';
for my $phase (qw(runtime configure build test develop)) {
my $indent = $phase eq 'runtime' ? '' : ' ';
- $indent = (' ' x ($base_indent || 0)) . $indent;
+ $indent .= (' ' x ($base_indent || 0));
my($phase_code, $requirements);
$phase_code .= "on $phase => sub {\n" unless $phase eq 'runtime';
@@ -68631,8 +51163,21 @@ $fatpacked{"Module/CPANfile.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
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";
+ ? "${indent}$type @{[ _d $mod ]}"
+ : "${indent}$type @{[ _d $mod ]}, @{[ _d $ver ]}";
+
+ my $options = $self->options_for_module($mod) || {};
+ if (%$options) {
+ my @opts;
+ for my $key (keys %$options) {
+ my $k = $key =~ /^[a-zA-Z0-9_]+$/ ? $key : _d $key;
+ push @opts, "$k => @{[ _d $options->{$k} ]}";
+ }
+
+ $phase_code .= ",\n" . join(",\n", map " $indent$_", @opts);
+ }
+
+ $phase_code .= ";\n";
$requirements++;
}
}
@@ -68761,6 +51306,25 @@ $fatpacked{"Module/CPANfile.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
version in the second argument, which defaults to 1.4 in case the
given file is YAML, and 2 if it is JSON.
+ =item options_for_module
+
+ my $options = $file->options_for_module($module);
+
+ Returns the extra options specified for a given module as a hash
+ reference. Returns C<undef> when the given module is not specified in
+ the C<cpanfile>.
+
+ For example,
+
+ # cpanfile
+ requires 'Plack', '1.000',
+ dist => "MIYAGAWA/Plack-1.000.tar.gz";
+
+ # ...
+ my $file = Module::CPANfile->load;
+ my $options = $file->options_for_module('Plack');
+ # => { dist => "MIYAGAWA/Plack-1.000.tar.gz" }
+
=back
=head1 AUTHOR
@@ -68915,7 +51479,7 @@ $fatpacked{"Module/CPANfile/Environment.pm"} = '#line '.(1+__LINE__).' "'.__FILE
sub add_prereq {
my($self, $type, $module, @args) = @_;
- $self->prereqs->add_prereq(
+ $self->prereqs->add(
feature => $self->{feature},
phase => $self->{phase},
type => $type,
@@ -68965,12 +51529,6 @@ $fatpacked{"Module/CPANfile/Prereq.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\
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
@@ -68989,7 +51547,7 @@ $fatpacked{"Module/CPANfile/Prereqs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."
for my $phase (keys %$prereqs) {
for my $type (keys %{ $prereqs->{$phase} }) {
while (my($module, $requirement) = each %{ $prereqs->{$phase}{$type} }) {
- $self->add_prereq(
+ $self->add(
phase => $phase,
type => $type,
module => $module,
@@ -69005,7 +51563,7 @@ $fatpacked{"Module/CPANfile/Prereqs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."
sub new {
my $class = shift;
bless {
- prereqs => [],
+ prereqs => {},
features => {},
}, $class;
}
@@ -69015,14 +51573,12 @@ $fatpacked{"Module/CPANfile/Prereqs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."
$self->{features}{$identifier} = { description => $description };
}
- sub add_prereq {
+ sub add {
my($self, %args) = @_;
- $self->add( Module::CPANfile::Prereq->new(%args) );
- }
- sub add {
- my($self, $prereq) = @_;
- push @{$self->{prereqs}}, $prereq;
+ my $feature = $args{feature} || '';
+ push @{$self->{prereqs}{$feature}},
+ Module::CPANfile::Prereq->new(%args);
}
sub as_cpan_meta {
@@ -69031,24 +51587,25 @@ $fatpacked{"Module/CPANfile/Prereqs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."
}
sub build_cpan_meta {
- my($self, $identifier) = @_;
+ my($self, $feature) = @_;
+ CPAN::Meta::Prereqs->new($self->specs($feature));
+ }
- my $prereq_spec = {};
- $self->prereq_each($identifier, sub {
- my $prereq = shift;
- $prereq_spec->{$prereq->phase}{$prereq->type}{$prereq->module} = $prereq->requirement->version;
- });
+ sub specs {
+ my($self, $feature) = @_;
- CPAN::Meta::Prereqs->new($prereq_spec);
- }
+ $feature = ''
+ unless defined $feature;
- sub prereq_each {
- my($self, $identifier, $code) = @_;
+ my $prereqs = $self->{prereqs}{$feature} || [];
+ my $specs = {};
- for my $prereq (@{$self->{prereqs}}) {
- next unless $prereq->match_feature($identifier);
- $code->($prereq);
+ for my $prereq (@$prereqs) {
+ $specs->{$prereq->phase}{$prereq->type}{$prereq->module} =
+ $prereq->requirement->version;
}
+
+ return $specs;
}
sub merged_requirements {
@@ -69065,8 +51622,10 @@ $fatpacked{"Module/CPANfile/Prereqs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."
sub find {
my($self, $module) = @_;
- for my $prereq (@{$self->{prereqs}}) {
- return $prereq if $prereq->module eq $module;
+ for my $feature ('', keys %{$self->{features}}) {
+ for my $prereq (@{$self->{prereqs}{$feature}}) {
+ return $prereq if $prereq->module eq $module;
+ }
}
return;
@@ -69122,640 +51681,1192 @@ $fatpacked{"Module/CPANfile/Requirement.pm"} = '#line '.(1+__LINE__).' "'.__FILE
1;
MODULE_CPANFILE_REQUIREMENT
-$fatpacked{"Module/Reader.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_READER';
- package Module::Reader;
- BEGIN { require 5.006 }
- use strict;
- use warnings;
+$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:tw=78
+ package Module::Metadata; # git description: v1.000035-3-gaa51be1
+ # ABSTRACT: Gather package and POD information from perl module files
- our $VERSION = '0.003003';
- $VERSION = eval $VERSION;
+ # Adapted from Perl-licensed code originally distributed with
+ # Module-Build by Ken Williams
- use Exporter (); BEGIN { *import = \&Exporter::import }
- our @EXPORT_OK = qw(module_content module_handle);
- our %EXPORT_TAGS = (all => [@EXPORT_OK]);
-
- use File::Spec ();
- use Scalar::Util qw(reftype refaddr openhandle);
- use Carp qw(croak);
- use Config ();
- use Errno qw(EACCES);
- use constant _OPEN_LAYERS => "$]" >= 5.008_000 ? ':' : '';
- use constant _ABORT_ON_EACCES => "$]" >= 5.017_001;
- use constant _ALLOW_PREFIX => "$]" >= 5.008009;
- use constant _VMS => $^O eq 'VMS' && !!require VMS::Filespec;
- use constant _WIN32 => $^O eq 'MSWin32';
- use constant _PMC_ENABLED => !(
- exists &Config::non_bincompat_options
- ? grep { $_ eq 'PERL_DISABLE_PMC' } Config::non_bincompat_options()
- : $Config::Config{ccflags} =~ /(?:^|\s)-DPERL_DISABLE_PMC\b/
- );
- use constant _FAKE_FILE_FORMAT => do {
- my $uvx = $Config::Config{uvxformat} || '';
- $uvx =~ tr/"\0//d;
- $uvx ||= 'lx';
- "/loader/0x%$uvx/%s"
- };
+ # 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 _mod_to_file {
- my $module = shift;
- (my $file = "$module.pm") =~ s{::}{/}g;
- $file;
- }
+ sub __clean_eval { eval $_[0] }
+ use strict;
+ use warnings;
- sub module_content {
- my $opts = ref $_[-1] eq 'HASH' && pop @_ || {};
- my $module = shift;
- $opts->{inc} = [@_]
- if @_;
- __PACKAGE__->new($opts)->module($module)->content;
- }
+ our $VERSION = '1.000036';
- sub module_handle {
- my $opts = ref $_[-1] eq 'HASH' && pop @_ || {};
- my $module = shift;
- $opts->{inc} = [@_]
- if @_;
- __PACKAGE__->new($opts)->module($module)->handle;
+ 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 }
}
-
- sub new {
- my $class = shift;
- my %options;
- if (@_ == 1 && ref $_[-1]) {
- %options = %{(pop)};
- }
- elsif (@_ % 2 == 0) {
- %options = @_;
+ 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 {
- croak "Expected hash ref, or key value pairs. Got ".@_." arguments.";
+ *log_info = sub (&) { warn $_[0]->() };
}
-
- $options{inc} ||= \@INC;
- $options{found} = \%INC
- if exists $options{found} && $options{found} eq 1;
- $options{pmc} = _PMC_ENABLED
- if !exists $options{pmc};
- $options{open} = 1
- if !exists $options{open};
- $options{abort_on_eacces} = _ABORT_ON_EACCES
- if !exists $options{abort_on_eacces};
- $options{check_hooks_for_nonsearchable} = 1
- if !exists $options{check_hooks_for_nonsearchable};
- bless \%options, $class;
}
+ use File::Find qw(find);
- sub module {
- my ($self, $module) = @_;
- $self->file(_mod_to_file($module));
- }
+ my $V_NUM_REGEXP = qr{v?[0-9._]+}; # crudely, a v-string or decimal
- sub modules {
- my ($self, $module) = @_;
- $self->files(_mod_to_file($module));
- }
+ 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;
- sub file {
- my ($self, $file) = @_;
- $self->_find($file);
- }
+ 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 files {
- my ($self, $file) = @_;
- $self->_find($file, 1);
}
- sub _searchable {
- my $file = shift;
- File::Spec->file_name_is_absolute($file) ? 0
- : _WIN32 && $file =~ m{^\.\.?[/\\]} ? 0
- : $file =~ m{^\.\.?/} ? 0
- : 1
+
+ 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);
}
- sub _find {
- my ($self, $file, $all) = @_;
+ {
- my @found;
- eval {
- if (my $found = $self->{found}) {
- if (defined( my $full = $found->{$file} )) {
- my $open = length ref $full ? $self->_open_ref($full, $file)
- : $self->_open_file($full, $file);
- push @found, $open
- if $open;
- }
+ 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;
};
- if (!$all) {
- return $found[0]
- if @found;
- die $@
- if $@;
- }
- my $searchable = _searchable($file);
- if (!$searchable) {
- my $open = $self->_open_file($file);
- if ($all) {
- push @found, $open;
+ # 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;
}
- elsif ($open) {
- return $open;
+
+ 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 "Can't locate $file";
+ 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
}
- my $search = $self->{inc};
- for my $inc (@$search) {
- my $open;
- if (!$searchable) {
- last
- if !$self->{check_hooks_for_nonsearchable};
- next
- if !length ref $inc;
+ sub package_versions_from_directory {
+ my ( $class, $dir, $files ) = @_;
+
+ my @files;
+
+ if ( $files ) {
+ @files = @$files;
}
- eval {
- if (!length ref $inc) {
- my $full = _VMS ? VMS::Filespec::unixpath($inc) : $inc;
- $full =~ s{/?$}{/};
- $full .= $file;
- $open = $self->_open_file($full, $file, $inc);
+ 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->abs2rel( $file, $dir );
+ my @path = File::Spec->splitdir( $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,
+ } );
+ }
}
- else {
- $open = $self->_open_ref($inc, $file);
+ }
+
+ # 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} );
}
- push @found, $open
- if $open;
- };
- if (!$all) {
- return $found[0]
- if @found;
- die $@
- if $@;
}
+
+ # 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;
}
- croak "Can't locate $file"
- if !$all;
- return @found;
- }
-
- sub _open_file {
- my ($self, $full, $file, $inc) = @_;
- $file = $full
- if !defined $file;
- for my $try (
- ($self->{pmc} && $file =~ /\.pm\z/ ? $full.'c' : ()),
- $full,
- ) {
- my $pmc = $full ne $try;
- if (-e $try) {
- next
- if -d _ || -b _;
- if (open my $fh, '<'._OPEN_LAYERS, $try) {
- return Module::Reader::File->new(
- filename => $file,
- ($self->{open} ? (raw_filehandle => $fh) : ()),
- found_file => $full,
- disk_file => $try,
- is_pmc => $pmc,
- (defined $inc ? (inc_entry => $inc) : ()),
- );
+ }
+
+
+ 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);
+
+ @{$self->{packages}} = __uniq(@{$self->{packages}});
+
+ unless($self->{module} and length($self->{module})) {
+ # CAVEAT (possible TODO): .pmc files not treated the same as .pm
+ if ($self->{filename} =~ /\.pm$/) {
+ my ($v, $d, $f) = File::Spec->splitpath($self->{filename});
+ $f =~ s/\..+$//;
+ my @candidates = grep /(^|::)$f$/, @{$self->{packages}};
+ $self->{module} = shift(@candidates); # this may be undef
+ }
+ else {
+ # this seems like an atrocious heuristic, albeit marginally better than
+ # what was here before. It should be rewritten entirely to be more like
+ # "if it's not a .pm file, it's not require()able as a name, therefore
+ # name() should be undef."
+ if ((grep /main/, @{$self->{packages}})
+ or (grep /main/, keys %{$self->{versions}})) {
+ $self->{module} = 'main';
+ }
+ else {
+ # TODO: this should maybe default to undef instead
+ $self->{module} = $self->{packages}[0] || '';
}
}
+ }
+
+ $self->{version} = $self->{versions}{$self->{module}}
+ if defined( $self->{module} );
- croak "Can't locate $file: $full: $!"
- if $self->{abort_on_eacces} && $! == EACCES && !$pmc;
+ 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
+ # CAVEAT (possible TODO): .pmc files are not discoverable here
+ $testfile .= '.pm';
+ return [ File::Spec->rel2abs( $testfile ), $dir ]
+ if -e $testfile;
}
return;
}
- sub _open_ref {
- my ($self, $inc, $file) = @_;
+ # class method
+ sub find_module_by_name {
+ my $found = shift()->_do_find_module(@_) or return;
+ return $found->[0];
+ }
- my @cb;
- {
- # strings in arrayrefs are taken as sub names relative to main
- package
- main;
- no strict 'refs';
- no warnings 'uninitialized';
- @cb = defined Scalar::Util::blessed $inc ? $inc->INC($file)
- : ref $inc eq 'ARRAY' ? $inc->[0]->($inc, $file)
- : $inc->($inc, $file);
+ # 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
- unless length ref $cb[0];
+ return ( $sigil, $variable_name, $package );
+ }
- my $fake_file = sprintf _FAKE_FILE_FORMAT, refaddr($inc), $file;
+ # 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 $fh;
- my $prefix;
- my $cb;
- my $cb_options;
+ my $pos = tell $fh;
+ return unless defined $pos;
- if (_ALLOW_PREFIX && reftype $cb[0] eq 'SCALAR') {
- $prefix = shift @cb;
- }
+ my $buf = ' ' x 2;
+ my $count = read $fh, $buf, length $buf;
+ return unless defined $count and $count >= 2;
- if ((reftype $cb[0]||'') eq 'GLOB' && openhandle $cb[0]) {
- $fh = shift @cb;
+ 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 ((reftype $cb[0]||'') eq 'CODE') {
- $cb = $cb[0];
- # only one or zero callback options will be passed
- $cb_options = @cb > 1 ? [ $cb[1] ] : undef;
+ if ( defined $encoding ) {
+ if ( "$]" >= 5.008 ) {
+ binmode( $fh, ":encoding($encoding)" );
+ }
}
- elsif (!defined $fh && !defined $prefix) {
- return;
+ else {
+ seek $fh, $pos, SEEK_SET
+ or croak( sprintf "Can't reset position to the top of '$filename'" );
}
- return Module::Reader::File->new(
- filename => $file,
- found_file => $fake_file,
- inc_entry => $inc,
- (defined $prefix ? (prefix => $prefix) : ()),
- (defined $fh ? (raw_filehandle => $fh) : ()),
- (defined $cb ? (read_callback => $cb) : ()),
- (defined $cb_options ? (read_callback_options => $cb_options) : ()),
- );
+
+ return $encoding;
}
- sub inc { $_[0]->{inc} }
- sub found { $_[0]->{found} }
- sub pmc { $_[0]->{pmc} }
- sub open { $_[0]->{open} }
+ sub _parse_fh {
+ my ($self, $fh) = @_;
- {
- package Module::Reader::File;
- use constant _OPEN_STRING => "$]" >= 5.008 || !require IO::String;
- use Carp 'croak';
-
- sub new {
- my ($class, %opts) = @_;
- my $filename = $opts{filename};
- if (!exists $opts{module} && $opts{filename}
- && $opts{filename} =~ m{\A(\w+(?:/\w+)?)\.pm\z}) {
- my $module = $1;
- $module =~ s{/}{::}g;
- $opts{module} = $module;
- }
- bless \%opts, $class;
+ 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";
+ }
+ next;
+ }
+ elsif ( $is_cut ) {
+ if ( $self->{collect_pod} && length( $pod_data ) ) {
+ $pod{$pod_sect} = $pod_data;
+ $pod_data = '';
+ }
+ $pod_sect = '';
+ next;
+ }
+
+ # 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 ) {
+ # we do NOT save this package in found @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;
+ }
+ }
+ } # end loop over each line
+
+ if ( $self->{collect_pod} && length($pod_data) ) {
+ $pod{$pod_sect} = $pod_data;
}
- sub filename { $_[0]->{filename} }
- sub module { $_[0]->{module} }
- sub found_file { $_[0]->{found_file} }
- sub disk_file { $_[0]->{disk_file} }
- sub is_pmc { $_[0]->{is_pmc} }
- sub inc_entry { $_[0]->{inc_entry} }
- sub read_callback { $_[0]->{read_callback} }
- sub read_callback_options { $_[0]->{read_callback_options} }
- sub raw_filehandle {
- $_[0]->{raw_filehandle} ||= !$_[0]->{disk_file} ? undef : do {
- open my $fh, '<'.Module::Reader::_OPEN_LAYERS, $_[0]->{disk_file}
- or croak "Can't locate $_[0]->{disk_file}";
- $fh;
+ $self->{versions} = \%vers;
+ $self->{packages} = \@packages;
+ $self->{pod} = \%pod;
+ $self->{pod_headings} = \@pod;
+ }
+
+ sub __uniq (@)
+ {
+ my (%seen, $key);
+ grep !$seen{ $key = $_ }++, @_;
+ }
+
+ {
+ 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;
+ return \$$variable_name if defined \$$variable_name;
+ return \$Module::Metadata::_version::p${pn}::$variable_name;
};
+ };
+
+ $eval = $1 if $eval =~ m{^(.+)}s;
+
+ local $^W;
+ # Try to get the $VERSION
+ my $vsub = __clean_eval($eval);
+ # some modules say $VERSION <equal sign> $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 $@;
- sub content {
- my $self = shift;
- return $self->{content}
- if exists $self->{content};
- my $fh = $self->raw_filehandle;
- my $cb = $self->read_callback;
- my $content = defined $self->{prefix} ? ${$self->{prefix}} : '';
- if ($fh && !$cb) {
- local $/;
- $content .= <$fh>;
- }
- if ($cb) {
- my @params = @{$self->read_callback_options||[]};
- while (1) {
- local $_ = $fh ? <$fh> : '';
- $_ = ''
- if !defined;
- # perlfunc/require says that the first parameter will be a reference the
- # sub itself. this is wrong. 0 will be passed.
- last if !$cb->(0, @params);
- $content .= $_;
- }
+ (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;
}
- return $self->{content} = $content;
+
+ 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 handle {
+ sub version {
my $self = shift;
- my $fh = $self->raw_filehandle;
- if ($fh && !$self->read_callback && -f $fh) {
- open my $dup, '<&', $fh
- or croak "can't dup file handle: $!";
- return $dup;
+ my $mod = shift || $self->{module};
+ my $vers;
+ if ( defined( $mod ) && length( $mod ) &&
+ exists( $self->{versions}{$mod} ) ) {
+ return $self->{versions}{$mod};
+ }
+ else {
+ return undef;
}
- my $content = $self->content;
- if (_OPEN_STRING) {
- open my $fh, '<', \$content;
- return $fh;
+ }
+
+ sub pod {
+ my $self = shift;
+ my $sect = shift;
+ if ( defined( $sect ) && length( $sect ) &&
+ exists( $self->{pod}{$sect} ) ) {
+ return $self->{pod}{$sect};
}
else {
- return IO::String->new($content);
+ 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;
__END__
+ =pod
+
+ =encoding UTF-8
+
=head1 NAME
- Module::Reader - Find and read perl modules like perl does
+ Module::Metadata - Gather package and POD information from perl module files
- =head1 SYNOPSIS
+ =head1 VERSION
- use Module::Reader;
+ version 1.000036
- my $reader = Module::Reader->new;
- my $module = $reader->module("My::Module");
- my $filename = $module->found_file;
- my $content = $module->content;
- my $file_handle = $module->handle;
+ =head1 SYNOPSIS
- # search options
- my $other_reader = Module::Reader->new(inc => ["/some/lib/dir", "/another/lib/dir"]);
- my $other_reader2 = Module::Reader->new(found => { 'My/Module.pm' => '/a_location.pm' });
+ use Module::Metadata;
- # Functional Interface
- use Module::Reader qw(module_handle module_content);
- my $io = module_handle('My::Module');
- my $content = module_content('My::Module');
+ # 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 finds modules in C<@INC> using the same algorithm perl does. From
- that, it will give you the source content of a module, the file name (where
- available), and how it was found. Searches (and content) are based on the same
- internal rules that perl uses for F<require|perlfunc/require> and
- F<do|perlfunc/do>.
+ 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 C<eval>ed, as is traditional
+ in the CPAN toolchain.
- =head1 EXPORTS
+ =head1 CLASS METHODS
- =head2 module_handle ( $module_name, @search_directories )
+ =head2 C<< new_from_file($filename, collect_pod => 1) >>
- Returns an IO handle for the given module.
+ Constructs a C<Module::Metadata> object given the path to a file. Returns
+ undef if the filename does not exist.
- =head2 module_content ( $module_name, @search_directories )
+ C<collect_pod> 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.
- Returns the content of a given module.
+ 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.
- =head1 ATTRIBUTES
+ =head2 C<< new_from_handle($handle, $filename, collect_pod => 1) >>
- =over 4
+ This works just like C<new_from_file>, except that a handle can be provided
+ as the first argument.
- =item inc
+ 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<filename> argument is
+ mandatory or undef will be returned.
- An array reference containing a list of directories or hooks to search for
- modules or files. This will be used in the same manner that
- L<require|perlfunc/require> uses L<< C<@INC>|perlvar/@INC >>. If not provided,
- L<< C<@INC>|perlvar/@INC >> itself will be used.
+ You are responsible for setting the decoding layers on C<$handle> if
+ required.
- =item found
+ =head2 C<< new_from_module($module, collect_pod => 1, inc => \@dirs) >>
- A hash reference of module filenames (of C<My/Module.pm> format>) to files that
- exist on disk, working the same as L<< C<%INC>|perlvar/%INC >>. The values can
- optionally be an L<< C<@INC> hook|perlfunc/require >>. This option can also be
- 1, in which case L<< C<%INC>|perlfunc/%INC >> will be used instead.
+ Constructs a C<Module::Metadata> object given a module or package name.
+ Returns undef if the module cannot be found.
- =item pmc
+ In addition to accepting the C<collect_pod> argument as described above,
+ this method accepts a C<inc> argument which is a reference to an array of
+ directories to search for the module. If none are given, the default is
+ @INC.
- A boolean controlling if C<.pmc> files should be found in preference to C<.pm>
- files. If not specified, the same behavior perl was compiled with will be used.
+ 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.
- =item open
+ =head2 C<< find_module_by_name($module, \@dirs) >>
- A boolean controlling if the files found will be opened immediately when found.
- Defaults to true.
+ 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.
- =item abort_on_eacces
+ Can be called as either an object or a class method.
- A boolean controlling if an error should be thrown or if the path should be
- skipped when encountering C<EACCES> (access denied) errors. Defaults to true
- on perl 5.18 and above, matching the behavior of L<require|perlfunc/require>.
+ =head2 C<< find_module_dir_by_name($module, \@dirs) >>
- =item check_hooks_for_nonsearchable
+ 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.
- For non-searchable paths (absolute paths and those starting with C<./> or
- C<../>) attempt to check the hook items (and not the directories) in C<@INC> if
- the file cannot be found directly. This matches the behavior of perl. Defaults
- to true.
+ Can be called as either an object or a class method.
- =back
+ =head2 C<< provides( %options ) >>
- =head1 METHODS
+ This is a convenience wrapper around C<package_versions_from_directory>
+ to generate a CPAN META C<provides> data structure. It takes key/value
+ pairs. Valid option keys include:
- =head2 module
+ =over
- Returns a L<file object|/FILE OBJECTS> for the given module name. If the module
- can't be found, an exception will be raised.
+ =item version B<(required)>
- =head2 file
+ Specifies which version of the L<CPAN::Meta::Spec> should be used as
+ the format of the C<provides> 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<provides> changes.
- Returns a L<file object|/FILE OBJECTS> for the given file name. If the file
- can't be found, an exception will be raised. For absolute paths, or files
- starting with C<./> or C<../> (and C<.\> or C<..\> on Windows), no directory
- search will be performed.
+ The C<version> option is required. If it is omitted or if
+ an unsupported version is given, then C<provides> will throw an error.
- =head2 modules
+ =item dir
- Returns an array of L<file objects|/FILE OBJECTS> for a given module name. This
- will give every file that could be loaded based on the L</inc> options.
+ Directory to search recursively for F<.pm> files. May not be specified with
+ C<files>.
- =head2 files
+ =item files
- Returns an array of L<file objects|/FILE OBJECTS> for a given file name. This
- will give every file that could be loaded based on the L</inc> options.
+ Array reference of files to examine. May not be specified with C<dir>.
- =head1 FILE OBJECTS
+ =item prefix
- The file objects returned represent an entry that could be found in
- L<< C<@INC>|perlvar/@INC >>. While they will generally be files that exist on
- the file system somewhere, they may also represent files that only exist only in
- memory or have arbitrary filters applied.
+ String to prepend to the C<file> field of the resulting output. This defaults
+ to F<lib>, which is the common case for most CPAN distributions with their
+ F<.pm> files in F<lib>. This option ensures the META information has the
+ correct relative path even when the C<dir> or C<files> arguments are
+ absolute or have relative paths from a location other than the distribution
+ root.
- =head2 FILE METHODS
+ =back
- =head3 filename
+ For example, given C<dir> of 'lib' and C<prefix> of 'lib', the return value
+ is a hashref of the form:
- The filename that was searched for.
+ {
+ '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:
- =head3 module
+ {
+ 'Package::Name' => {
+ version => '0.123',
+ file => 'Package/Name.pm'
+ },
+ 'OtherPackage::Name' => ...
+ }
- If a module was searched for, or a file of the matching form (C<My/Module.pm>),
- this will be the module searched for.
+ The C<DB> and C<main> packages are always omitted, as are any "private"
+ packages that have leading underscores in the namespace (e.g.
+ C<Foo::_private>)
- =head3 found_file
+ Note that the file path is relative to C<$dir> if that is specified.
+ This B<must not> be used directly for CPAN META C<provides>. See
+ the C<provides> method instead.
- The path to the file found by L<require|perlfunc/require>.
+ =head2 C<< log_info (internal) >>
- This may not represent an actual file that exists, but the file name that perl
- will use for the file for things like L<caller|perlfunc/caller> or
- L<__FILE__|perlfunc/__FILE__>.
+ Used internally to perform logging; imported from Log::Contextual if
+ Log::Contextual has already been loaded, otherwise simply calls warn.
- For C<.pmc> files, this will be the C<.pm> form of the file.
+ =head1 OBJECT METHODS
- For L<< C<@INC> hooks|perlfunc/require >> this will be a file name of the form
- C</loader/0x123456abcdef/My/Module.pm>, matching how perl treats them internally.
+ =head2 C<< name() >>
- =head3 disk_file
+ 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'.
- The path to the file that exists on disk. When the file is found via an
- L<< C<@INC> hook|perlfunc/require >>, this will be undef.
+ =head2 C<< version($package) >>
- =head3 content
+ Returns the version as defined by the $VERSION variable for the
+ package as returned by the C<name> 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.
- The content of the found file.
+ =head2 C<< filename() >>
- =head3 handle
+ 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.
- A file handle to the found file's content.
+ =head2 C<< packages_inside() >>
- =head3 is_pmc
+ Returns a list of packages. Note: this is a raw list of packages
+ discovered (or assumed, in the case of C<main>). It is not
+ filtered for C<DB>, C<main> or private packages the way the
+ C<provides> 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.
- A boolean value representing if the file found was C<.pmc> variant of the file
- requested.
+ =head2 C<< pod_inside() >>
- =head3 inc_entry
+ Returns a list of POD sections.
- The directory or L<hook|perlfunc/require> that was used to find the given file
- or module. If L</found> is used, this may be undef.
+ =head2 C<< contains_pod() >>
- =head2 RAW HOOK DATA
+ Returns true if there is any POD in the file.
- File objects also have methods for the raw file handle and read callbacks used
- to read a file. Interacting with the handle or callback can impact the return
- values of L</content> and L</handle>, and vice versa. It should generally be
- avoided unless you are introspecting the F<< C<@INC> hooks|perlfunc/require >>.
+ =head2 C<< pod($section) >>
- =head3 raw_filehandle
+ Returns the POD data in the given section.
- The raw file handle to the file found. This will be either a file handle to a
- file found on disk, or something returned by an
- F<< C<@INC> hook|perlfunc/require >>. The hook callback, if it exists, will not
- be taken into account by this method.
+ =head2 C<< is_indexable($package) >> or C<< is_indexable() >>
- =head3 read_callback
+ Available since version 1.000020.
- A callback used to read content, or modify a file handle from an C<@INC> hook.
+ 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<package> declarations, and does not take any
+ ownership information into account.
- =head3 read_callback_options
+ =head1 SUPPORT
- An array reference of arguments to send to the read callback whem reading or
- modifying content from a file handle. Will contain either zero or one entries.
+ Bugs may be submitted through L<the RT bug tracker|https://rt.cpan.org/Public/Dist/Display.html?Name=Module-Metadata>
+ (or L<bug-Module-Metadata@rt.cpan.org|mailto:bug-Module-Metadata@rt.cpan.org>).
- =head1 SEE ALSO
+ There is also a mailing list available for users of this distribution, at
+ L<http://lists.perl.org/list/cpan-workers.html>.
- Numerous other modules attempt to do C<@INC> searches similar to this module,
- but no other module accurately represents how perl itself uses
- L<< C<@INC>|perlvar/@INC >>. Most don't match perl's behavior regarding
- character and block devices, directories, or permissions. Often, C<.pmc> files
- are not taken into account.
+ There is also an irc channel available for users of this distribution, at
+ L<C<#toolchain> on C<irc.perl.org>|irc://irc.perl.org/#toolchain>.
- Some of these modules have other use cases. The following comments are
- primarily related to their ability to search C<@INC>.
+ =head1 AUTHOR
+
+ Original code from Module::Build::ModuleInfo by Ken Williams
+ <kwilliams@cpan.org>, Randy W. Sims <RandyS@ThePierianSpring.org>
+
+ Released as Module::Metadata by Matt S Trout (mst) <mst@shadowcat.co.uk> with
+ assistance from David Golden (xdg) <dagolden@cpan.org>.
+
+ =head1 CONTRIBUTORS
+
+ =for stopwords Karen Etheridge David Golden Vincent Pit Matt S Trout Chris Nehren Graham Knop Olivier Mengué Tomas Doran tokuhirom Christian Walde Tatsuhiko Miyagawa Peter Rabbitson Steve Hay Jerry D. Hedden Craig A. Berry Mitchell Steinbrunner Edward Zborowski Gareth Harper James Raspass 'BinGOs' Williams Josh Jore Kent Fredric
=over 4
- =item L<App::moduleswhere>
+ =item *
+
+ Karen Etheridge <ether@cpan.org>
+
+ =item *
- Only available as a command line utility. Inaccurately gives the first file
- found on disk in C<@INC>.
+ David Golden <dagolden@cpan.org>
- =item L<App::whichpm>
+ =item *
- Inaccurately gives the first file found on disk in C<@INC>.
+ Vincent Pit <perl@profvince.com>
- =item L<Class::Inspector>
+ =item *
- For unloaded modules, inaccurately checks if a module exists.
+ Matt S Trout <mst@shadowcat.co.uk>
- =item L<Module::Data>
+ =item *
- Same caveats as L</Path::ScanINC>.
+ Chris Nehren <apeiron@cpan.org>
- =item L<Module::Filename>
+ =item *
- Inaccurately gives the first file found on disk in C<@INC>.
+ Graham Knop <haarg@haarg.org>
- =item L<Module::Finder>
+ =item *
- Inaccurately searches for C<.pm> and C<.pmc> files in subdirectories of C<@INC>.
+ Olivier Mengué <dolmen@cpan.org>
- =item L<Module::Info>
+ =item *
- Inaccurately searches C<@INC> for files and gives inaccurate information for the
- files that it finds.
+ Tomas Doran <bobtfish@bobtfish.net>
- =item L<Module::Locate>
+ =item *
- Inaccurately searches C<@INC> for matching files. Attempts to handle hooks, but
- handles most cases wrong.
+ tokuhirom <tokuhirom@gmail.com>
- =item L<Module::Mapper>
+ =item *
- Searches for C<.pm> and C<.pod> files in relatively unpredictable fashion,
- based usually on the current directory. Optionally, can inaccurately scan
- C<@INC>.
+ Christian Walde <walde.christian@googlemail.com>
- =item L<Module::Metadata>
+ =item *
- Primarily designed as a version number extractor. Meant to find files on disk,
- avoiding the nuance involved in perl's file loading.
+ Tatsuhiko Miyagawa <miyagawa@bulknews.net>
- =item L<Module::Path>
+ =item *
- Inaccurately gives the first file found on disk in C<@INC>.
+ Peter Rabbitson <ribasushi@cpan.org>
- =item L<Module::Util>
+ =item *
- Inaccurately searches for modules, ignoring C<@INC> hooks.
+ Steve Hay <steve.m.hay@googlemail.com>
- =item L<Path::ScanINC>
+ =item *
- Inaccurately searches for files, with confusing output for C<@INC> hooks.
+ Jerry D. Hedden <jdhedden@cpan.org>
- =item L<Pod::Perldoc>
+ =item *
- Primarily meant for searching for related documentation. Finds related module
- files, or sometimes C<.pod> files. Unpredictable search path.
+ Craig A. Berry <cberry@cpan.org>
- =back
+ =item *
- =head1 AUTHOR
+ Craig A. Berry <craigberry@mac.com>
- haarg - Graham Knop (cpan:HAARG) <haarg@haarg.org>
+ =item *
- =head2 CONTRIBUTORS
+ David Mitchell <davem@iabyn.com>
- None yet.
+ =item *
- =head1 COPYRIGHT
+ David Steinbrunner <dsteinbrunner@pobox.com>
- Copyright (c) 2013 the Module::Reader L</AUTHOR> and L</CONTRIBUTORS>
- as listed above.
+ =item *
- =head1 LICENSE
+ Edward Zborowski <ed@rubensteintech.com>
- This library is free software and may be distributed under the same terms
- as perl itself.
+ =item *
+
+ Gareth Harper <gareth@broadbean.com>
+
+ =item *
+
+ James Raspass <jraspass@gmail.com>
+
+ =item *
+
+ Chris 'BinGOs' Williams <chris@bingosnet.co.uk>
+
+ =item *
+
+ Josh Jore <jjore@cpan.org>
+
+ =item *
+
+ Kent Fredric <kentnl@cpan.org>
+
+ =back
+
+ =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_READER
+MODULE_METADATA
$fatpacked{"Parse/CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PARSE_CPAN_META';
use 5.008001;
@@ -70105,6 +53216,924 @@ $fatpacked{"Parse/CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<
=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.41';
+ 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
+ }
+ }
+ unless ($self->_version_ok($pp)) {
+ $errors{$package} = {
+ long_version => qq{Version string exceeds maximum allowed length of 16b: "$pp->{version}"},
+ infile => $pp->{infile},
+ };
+ next;
+ }
+ $checked_in{$package} = $ppp->{$package};
+ } # end foreach package
+
+ return (wantarray && %errors) ? (\%checked_in, \%errors) : \%checked_in;
+ }
+
+ sub _version_ok {
+ my ($self, $pp) = @_;
+ return if length($pp->{version} || 0) > 16;
+ return 1
+ }
+
+ 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) {
+ no warnings;
+ $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
+ #(?<![*\$\\@%&]) # no sigils
+ ^[\s\{;]*
+ \bpackage\s+
+ ([\w\:\']+)
+ \s*
+ (?: $ | [\}\;] | \{ | \s+($version::STRICT) )
+ }x) {
+ $pkg = $1;
+ $strict_version = $2;
+ if ($pkg eq "DB"){
+ # XXX if pumpkin and perl make him comaintainer! I
+ # think I always made the pumpkins comaint on DB
+ # without further ado (?)
+ next PLINE;
+ }
+ }
+
+ if ($pkg) {
+ # Found something
+
+ # from package
+ $pkg =~ s/\'/::/g;
+ next PLINE unless $pkg =~ /^[A-Za-z]/;
+ next PLINE unless $pkg =~ /\w$/;
+ next PLINE if $pkg eq "main";
+ # Perl::Critic::Policy::TestingAndDebugging::ProhibitShebangWarningsArg
+ # database for modid in mods, package in packages, package in perms
+ # alter table mods modify modid varchar(128) binary NOT NULL default '';
+ # alter table packages modify package varchar(128) binary NOT NULL default '';
+ next PLINE if length($pkg) > 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 (<FH>) {
+ $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 /(?<!\\)([\$*])(([\w\:\']*)\bVERSION)\b.*(?<![!><=])\=(?![=>])/;
+ 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/) {
+ no warnings;
+ $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)
+ no warnings;
+ $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<PAUSE::Permissions>) 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<eval> to parse a version under older perls. If you want it to use always C<eval> (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<Parse::LocalDistribution>, L<PAUSE::Permissions>
+
+ Most part of this module is derived from PAUSE and CPAN::Version.
+
+ L<https://github.com/andk/pause>
+
+ L<https://github.com/andk/cpanpm>
+
+ =head1 AUTHOR
+
+ Andreas Koenig E<lt>andreas.koenig@anima.deE<gt>
+
+ Kenichi Ishigaki, E<lt>ishigaki@cpan.orgE<gt>
+
+ =head1 COPYRIGHT AND LICENSE
+
+ Copyright 1995 - 2013 by Andreas Koenig E<lt>andk@cpan.orgE<gt> 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{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_TINY';
use 5.008001;
use strict;
@@ -70113,7 +54142,7 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
package Path::Tiny;
# ABSTRACT: File path utility
- our $VERSION = '0.104';
+ our $VERSION = '0.108';
# Dependencies
use Config;
@@ -70131,7 +54160,6 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
DIR => 3,
FILE => 4,
TEMP => 5,
- IS_BSD => ( scalar $^O =~ /bsd$/ ),
IS_WIN32 => ( $^O eq 'MSWin32' ),
};
@@ -70149,13 +54177,26 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
my $HAS_UU; # has Unicode::UTF8; lazily populated
sub _check_UU {
- !!eval { require Unicode::UTF8; Unicode::UTF8->VERSION(0.58); 1 };
+ local $SIG{__DIE__}; # prevent outer handler from being called
+ !!eval {
+ require Unicode::UTF8;
+ Unicode::UTF8->VERSION(0.58);
+ 1;
+ };
}
- my $HAS_PU; # has PerlIO::utf8_strict; lazily populated
+ my $HAS_PU; # has PerlIO::utf8_strict; lazily populated
sub _check_PU {
- !!eval { require PerlIO::utf8_strict; PerlIO::utf8_strict->VERSION(0.003); 1 };
+ local $SIG{__DIE__}; # prevent outer handler from being called
+ !!eval {
+ # MUST preload Encode or $SIG{__DIE__} localization fails
+ # on some Perl 5.8.8 (maybe other 5.8.*) compiled with -O2.
+ require Encode;
+ require PerlIO::utf8_strict;
+ PerlIO::utf8_strict->VERSION(0.003);
+ 1;
+ };
}
my $HAS_FLOCK = $Config{d_flock} || $Config{d_fcntl_can_lock} || $Config{d_lockf};
@@ -70219,26 +54260,26 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
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
+ # flock doesn't work on NFS on BSD or on some filesystems like lustre.
+ # 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' }
+ { package flock; use warnings::register }
#>>>
- my $WARNED_BSD_NFS = 0;
+ my $WARNED_NO_FLOCK = 0;
sub _throw {
my ( $self, $function, $file, $msg ) = @_;
- if ( IS_BSD()
- && $function =~ /^flock/
- && $! =~ /operation not supported/i
+ if ( $function =~ /^flock/
+ && $! =~ /operation not supported|function not implemented/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++;
+ if ( !$WARNED_NO_FLOCK ) {
+ warnings::warn( flock => "Flock not available: '$!': continuing in unsafe mode" );
+ $WARNED_NO_FLOCK++;
}
}
else {
@@ -70611,8 +54652,9 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
#pod path("foo.txt")->append_raw(@data);
#pod path("foo.txt")->append_utf8(@data);
#pod
- #pod Appends data to a file. The file is locked with C<flock> prior to writing. An
- #pod optional hash reference may be used to pass options. Valid options are:
+ #pod Appends data to a file. The file is locked with C<flock> prior to writing
+ #pod and closed afterwards. An optional hash reference may be used to pass
+ #pod options. Valid options are:
#pod
#pod =for :list
#pod * C<binmode>: passed to C<binmode()> on the handle used for writing.
@@ -70773,6 +54815,11 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
#pod like C<catfile> or C<catdir> from File::Spec, but without caring about
#pod file or directories.
#pod
+ #pod B<WARNING>: because the argument could contain C<..> or refer to symlinks,
+ #pod there is no guarantee that the new path refers to an actual descendent of
+ #pod the original. If this is important to you, transform parent and child with
+ #pod L</realpath> and check them with L</subsumes>.
+ #pod
#pod Current API available since 0.001.
#pod
#pod =cut
@@ -71127,7 +55174,7 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
$binmode = "" unless defined $binmode;
my ( $fh, $lock, $trunc );
- if ( $HAS_FLOCK && $args->{locked} ) {
+ if ( $HAS_FLOCK && $args->{locked} && !$ENV{PERL_PATH_TINY_NO_FLOCK} ) {
require Fcntl;
# truncating file modes shouldn't truncate until lock acquired
if ( grep { $opentype eq $_ } qw( > +> ) ) {
@@ -71445,7 +55492,7 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
#pod
#pod Move the current path to the given destination path using Perl's
#pod built-in L<rename|perlfunc/rename> function. Returns the result
- #pod of the C<rename> function.
+ #pod of the C<rename> function (except it throws an exception if it fails).
#pod
#pod Current API available since 0.001.
#pod
@@ -72246,7 +56293,7 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
=head1 VERSION
- version 0.104
+ version 0.108
=head1 SYNOPSIS
@@ -72305,7 +56352,7 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
the object gives you back the path (after some clean up).
File input/output methods C<flock> handles before reading or writing,
- as appropriate (if supported by the platform).
+ as appropriate (if supported by the platform and/or filesystem).
The C<*_utf8> methods (C<slurp_utf8>, C<lines_utf8>, etc.) operate in raw
mode. On Windows, that means they will not have CRLF translation from the
@@ -72479,8 +56526,9 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
path("foo.txt")->append_raw(@data);
path("foo.txt")->append_utf8(@data);
- Appends data to a file. The file is locked with C<flock> prior to writing. An
- optional hash reference may be used to pass options. Valid options are:
+ Appends data to a file. The file is locked with C<flock> prior to writing
+ and closed afterwards. An optional hash reference may be used to pass
+ options. Valid options are:
=over 4
@@ -72567,6 +56615,11 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
like C<catfile> or C<catdir> from File::Spec, but without caring about
file or directories.
+ B<WARNING>: because the argument could contain C<..> or refer to symlinks,
+ there is no guarantee that the new path refers to an actual descendent of
+ the original. If this is important to you, transform parent and child with
+ L</realpath> and check them with L</subsumes>.
+
Current API available since 0.001.
=head2 children
@@ -72848,7 +56901,7 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
Move the current path to the given destination path using Perl's
built-in L<rename|perlfunc/rename> function. Returns the result
- of the C<rename> function.
+ of the C<rename> function (except it throws an exception if it fails).
Current API available since 0.001.
@@ -73205,7 +57258,7 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
=for Pod::Coverage openr_utf8 opena_utf8 openw_utf8 openrw_utf8
openr_raw opena_raw openw_raw openrw_raw
- IS_BSD IS_WIN32 FREEZE THAW TO_JSON abs2rel
+ IS_WIN32 FREEZE THAW TO_JSON abs2rel
=head1 EXCEPTION HANDLING
@@ -73237,6 +57290,14 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
Exception objects will stringify as the C<msg> field.
+ =head1 ENVIRONMENT
+
+ =head2 PERL_PATH_TINY_NO_FLOCK
+
+ If the environment variable C<PERL_PATH_TINY_NO_FLOCK> is set to a true
+ value then flock will NOT be used when accessing files (this is not
+ recommended).
+
=head1 CAVEATS
=head2 Subclassing not supported
@@ -73250,17 +57311,26 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
If flock is not supported on a platform, it will not be used, even if
locking is requested.
+ In situations where a platform normally would support locking, but the
+ flock fails due to a filesystem limitation, Path::Tiny has some heuristics
+ to detect this and will warn once and continue in an unsafe mode. If you
+ want this failure to be fatal, you can fatalize the 'flock' warnings
+ category:
+
+ use warnings FATAL => 'flock';
+
See additional caveats below.
=head3 NFS and BSD
On BSD, Perl's flock implementation may not work to lock files on an
- NFS filesystem. Path::Tiny has some heuristics to detect this
- and will warn once and let you continue in an unsafe mode. If you
- want this failure to be fatal, you can fatalize the 'flock' warnings
- category:
+ NFS filesystem. If detected, this situation will warn once, as described
+ above.
- use warnings FATAL => 'flock';
+ =head3 Lustre
+
+ The Lustre filesystem does not support flock. If detected, this situation
+ will warn once, as described above.
=head3 AIX and locking
@@ -73377,7 +57447,7 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
=head1 CONTRIBUTORS
- =for stopwords Alex Efros Chris Williams Dave Rolsky David Steinbrunner Doug Bell Gabor Szabo Gabriel Andrade George Hartzell Geraud Continsouzas Goro Fuji Graham Knop Ollis James Hunt John Karr Karen Etheridge Mark Ellis Martin Kjeldsen Michael G. Schwern Nigel Gregoire Philippe Bruhat (BooK) Regina Verbae Roy Ivy III Shlomi Fish Smylers Tatsuhiko Miyagawa Toby Inkster Yanick Champoux 김도형 - Keedi Kim
+ =for stopwords Alex Efros Aristotle Pagaltzis Chris Williams Dave Rolsky David Steinbrunner Doug Bell Gabor Szabo Gabriel Andrade George Hartzell Geraud Continsouzas Goro Fuji Graham Knop Ollis Ian Sillitoe James Hunt John Karr Karen Etheridge Mark Ellis Martin H. Sluka Kjeldsen Michael G. Schwern Nigel Gregoire Philippe Bruhat (BooK) Regina Verbae Roy Ivy III Shlomi Fish Smylers Tatsuhiko Miyagawa Toby Inkster Yanick Champoux 김도형 - Keedi Kim
=over 4
@@ -73387,6 +57457,10 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
=item *
+ Aristotle Pagaltzis <pagaltzis@gmx.de>
+
+ =item *
+
Chris Williams <bingos@cpan.org>
=item *
@@ -73431,6 +57505,10 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
=item *
+ Ian Sillitoe <ian@sillit.com>
+
+ =item *
+
James Hunt <james@niftylogic.com>
=item *
@@ -73447,6 +57525,10 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
=item *
+ Martin H. Sluka <fany@cpan.org>
+
+ =item *
+
Martin Kjeldsen <mk@bluepipe.dk>
=item *
@@ -73506,12 +57588,593 @@ $fatpacked{"Path/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PATH_
=cut
PATH_TINY
+$fatpacked{"Search/Dict.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'SEARCH_DICT';
+ package Search::Dict;
+ require 5.000;
+ require Exporter;
+
+ my $fc_available;
+ BEGIN {
+ $fc_available = '5.015008';
+ if ( $] ge $fc_available ) {
+ require feature;
+ 'feature'->import('fc'); # string avoids warning on old Perls <sigh>
+ }
+ }
+
+ use strict;
+
+ our $VERSION = '1.07';
+ our @ISA = qw(Exporter);
+ our @EXPORT = qw(look);
+
+ =head1 NAME
+
+ Search::Dict - look - search for key in dictionary file
+
+ =head1 SYNOPSIS
+
+ use Search::Dict;
+ look *FILEHANDLE, $key, $dict, $fold;
+
+ use Search::Dict;
+ look *FILEHANDLE, $params;
+
+ =head1 DESCRIPTION
+
+ Sets file position in FILEHANDLE to be first line greater than or equal
+ (stringwise) to I<$key>. Returns the new file position, or -1 if an error
+ occurs.
+
+ The flags specify dictionary order and case folding:
+
+ If I<$dict> is true, search by dictionary order (ignore anything but word
+ characters and whitespace). The default is honour all characters.
+
+ If I<$fold> is true, ignore case. The default is to honour case.
+
+ If there are only three arguments and the third argument is a hash
+ reference, the keys of that hash can have values C<dict>, C<fold>, and
+ C<comp> or C<xfrm> (see below), and their corresponding values will be
+ used as the parameters.
+
+ If a comparison subroutine (comp) is defined, it must return less than zero,
+ zero, or greater than zero, if the first comparand is less than,
+ equal, or greater than the second comparand.
+
+ If a transformation subroutine (xfrm) is defined, its value is used to
+ transform the lines read from the filehandle before their comparison.
+
+ =cut
+
+ sub look {
+ my($fh,$key,$dict,$fold) = @_;
+ my ($comp, $xfrm);
+ if (@_ == 3 && ref $dict eq 'HASH') {
+ my $params = $dict;
+ $dict = 0;
+ $dict = $params->{dict} if exists $params->{dict};
+ $fold = $params->{fold} if exists $params->{fold};
+ $comp = $params->{comp} if exists $params->{comp};
+ $xfrm = $params->{xfrm} if exists $params->{xfrm};
+ }
+ $comp = sub { $_[0] cmp $_[1] } unless defined $comp;
+ local($_);
+ my $fno = fileno $fh;
+ my @stat;
+ if ( defined $fno && $fno >= 0 && ! tied *{$fh} ) { # real, open file
+ @stat = eval { stat($fh) }; # in case fileno lies
+ }
+ my($size, $blksize) = @stat[7,11];
+ $size = do { seek($fh,0,2); my $s = tell($fh); seek($fh,0,0); $s }
+ unless defined $size;
+ $blksize ||= 8192;
+ $key =~ s/[^\w\s]//g if $dict;
+ if ( $fold ) {
+ $key = $] ge $fc_available ? fc($key) : lc($key);
+ }
+ # find the right block
+ my($min, $max) = (0, int($size / $blksize));
+ my $mid;
+ while ($max - $min > 1) {
+ $mid = int(($max + $min) / 2);
+ seek($fh, $mid * $blksize, 0)
+ or return -1;
+ <$fh> if $mid; # probably a partial line
+ $_ = <$fh>;
+ $_ = $xfrm->($_) if defined $xfrm;
+ chomp;
+ s/[^\w\s]//g if $dict;
+ if ( $fold ) {
+ $_ = $] ge $fc_available ? fc($_) : lc($_);
+ }
+ if (defined($_) && $comp->($_, $key) < 0) {
+ $min = $mid;
+ }
+ else {
+ $max = $mid;
+ }
+ }
+ # find the right line
+ $min *= $blksize;
+ seek($fh,$min,0)
+ or return -1;
+ <$fh> if $min;
+ for (;;) {
+ $min = tell($fh);
+ defined($_ = <$fh>)
+ or last;
+ $_ = $xfrm->($_) if defined $xfrm;
+ chomp;
+ s/[^\w\s]//g if $dict;
+ if ( $fold ) {
+ $_ = $] ge $fc_available ? fc($_) : lc($_);
+ }
+ last if $comp->($_, $key) >= 0;
+ }
+ seek($fh,$min,0);
+ $min;
+ }
+
+ 1;
+SEARCH_DICT
+
+$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<shell_quote> [I<string>]...
+
+ B<shell_quote> quotes strings so they can be passed through the shell.
+ Each I<string> is quoted so that the shell will pass it along as a
+ single argument and without further interpretation. If no I<string>s
+ are given an empty string is returned.
+
+ If any I<string> can't be safely quoted B<shell_quote> will B<croak>.
+
+ =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<shell_quote_best_effort> [I<string>]...
+
+ This is like B<shell_quote>, 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<shell_comment_quote> [I<string>]
+
+ B<shell_comment_quote> quotes the I<string> 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<string> arguments
+ in the future. I haven't done this yet because I'm not sure if the
+ I<string>s 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 <F<roderick@argon.org>>
+
+ =head1 SEE ALSO
+
+ perl(1).
+
+ =cut
+STRING_SHELLQUOTE
+
+$fatpacked{"Tie/Handle/Offset.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TIE_HANDLE_OFFSET';
+ use strict;
+ BEGIN{ if (not $] < 5.006) { require warnings; warnings->import } }
+
+ package Tie::Handle::Offset;
+ # ABSTRACT: Tied handle that hides the beginning of a file
+
+ our $VERSION = '0.004';
+
+ use Tie::Handle;
+ our @ISA = qw/Tie::Handle/;
+
+ #--------------------------------------------------------------------------#
+ # Glob slot accessor
+ #--------------------------------------------------------------------------#
+
+ sub offset {
+ my $self = shift;
+ if ( @_ ) {
+ return ${*$self}{offset} = shift;
+ }
+ else {
+ return ${*$self}{offset};
+ }
+ }
+
+ #--------------------------------------------------------------------------#
+ # Tied handle methods
+ #--------------------------------------------------------------------------#
+
+ sub TIEHANDLE
+ {
+ my $class = shift;
+ my $params;
+ $params = pop if ref $_[-1] eq 'HASH';
+
+ my $self = \do { no warnings 'once'; local *HANDLE};
+ bless $self,$class;
+
+ $self->OPEN(@_) if (@_);
+ if ( $params->{offset} ) {
+ seek( $self, $self->offset( $params->{offset} ), 0 );
+ }
+ return $self;
+ }
+
+ sub TELL {
+ my $cur = tell($_[0]) - $_[0]->offset;
+ # XXX shouldn't ever be less than zero, but just in case...
+ return $cur > 0 ? $cur : 0;
+ }
+
+ sub SEEK {
+ my ($self, $pos, $whence) = @_;
+ my $rc;
+ if ( $whence == 0 || $whence == 1 ) { # pos from start, cur
+ $rc = seek($self, $pos + $self->offset, $whence);
+ }
+ elsif ( _size($self) + $pos < $self->offset ) { # from end
+ $rc = '';
+ }
+ else {
+ $rc = seek($self,$pos,$whence);
+ }
+ return $rc;
+ }
+
+ sub OPEN
+ {
+ $_[0]->offset(0);
+ $_[0]->CLOSE if defined($_[0]->FILENO);
+ @_ == 2 ? open($_[0], $_[1]) : open($_[0], $_[1], $_[2]);
+ }
+
+ sub _size {
+ my ($self) = @_;
+ my $cur = tell($self);
+ seek($self,0,2); # end
+ my $size = tell($self);
+ seek($self,$cur,0); # reset
+ return $size;
+ }
+
+ #--------------------------------------------------------------------------#
+ # Methods copied from Tie::StdHandle to avoid dependency on Perl 5.8.9/5.10.0
+ #--------------------------------------------------------------------------#
+
+ sub EOF { eof($_[0]) }
+ sub FILENO { fileno($_[0]) }
+ sub CLOSE { close($_[0]) }
+ sub BINMODE { binmode($_[0]) }
+ sub READ { read($_[0],$_[1],$_[2]) }
+ sub READLINE { my $fh = $_[0]; <$fh> }
+ sub GETC { getc($_[0]) }
+
+ sub WRITE
+ {
+ my $fh = $_[0];
+ print $fh substr($_[1],0,$_[2])
+ }
+
+ 1;
+
+
+ # vim: ts=2 sts=2 sw=2 et:
+
+ __END__
+
+ =pod
+
+ =encoding UTF-8
+
+ =head1 NAME
+
+ Tie::Handle::Offset - Tied handle that hides the beginning of a file
+
+ =head1 VERSION
+
+ version 0.004
+
+ =head1 SYNOPSIS
+
+ use Tie::Handle::Offset;
+
+ tie *FH, 'Tie::Handle::Offset', "<", $filename, { offset => 20 };
+
+ =head1 DESCRIPTION
+
+ This modules provides a file handle that hides the beginning of a file.
+ After opening, the file is positioned at the offset location. C<seek()> and
+ C<tell()> calls are modified to preserve the offset.
+
+ For example, C<tell($fh)> will return 0, though the actual file position
+ is at the offset. Likewise, C<seek($fh,80,0)> will seek to 80 bytes from
+ the offset instead of 80 bytes from the actual start of the file.
+
+ =for Pod::Coverage method_names_here
+
+ =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<https://github.com/dagolden/tie-handle-offset/issues>.
+ 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<https://github.com/dagolden/tie-handle-offset>
+
+ git clone https://github.com/dagolden/tie-handle-offset.git
+
+ =head1 AUTHOR
+
+ David Golden <dagolden@cpan.org>
+
+ =head1 COPYRIGHT AND LICENSE
+
+ This software is Copyright (c) 2012 by David Golden.
+
+ This is free software, licensed under:
+
+ The Apache License, Version 2.0, January 2004
+
+ =cut
+TIE_HANDLE_OFFSET
+
+$fatpacked{"Tie/Handle/SkipHeader.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TIE_HANDLE_SKIPHEADER';
+ use strict;
+ BEGIN{ if (not $] < 5.006) { require warnings; warnings->import } }
+
+ package Tie::Handle::SkipHeader;
+ # ABSTRACT: Tied handle that hides an RFC822-style header
+
+ our $VERSION = '0.004';
+
+ use Tie::Handle::Offset;
+ our @ISA = qw/Tie::Handle::Offset/;
+
+ sub TIEHANDLE
+ {
+ my $class = shift;
+ pop if ref $_[-1] eq 'HASH'; # we don't take any arguments
+ return $class->SUPER::TIEHANDLE(@_);
+ }
+
+ # read to blank/whitespace line and set offset right after
+ sub OPEN
+ {
+ my $self = shift;
+ my $rc = $self->SUPER::OPEN(@_);
+ while ( my $line = <$self> ) {
+ last if $line =~ /\A\s*\Z/;
+ }
+ $self->offset( tell($self) );
+ return $rc;
+ }
+
+ 1;
+
+
+ # vim: ts=2 sts=2 sw=2 et:
+
+ __END__
+
+ =pod
+
+ =encoding UTF-8
+
+ =head1 NAME
+
+ Tie::Handle::SkipHeader - Tied handle that hides an RFC822-style header
+
+ =head1 VERSION
+
+ version 0.004
+
+ =head1 SYNOPSIS
+
+ use Tie::Handle::SkipHeader;
+
+ tie *FH, 'Tie::Handle::SkipHeader', "<", $filename;
+
+ =head1 DESCRIPTION
+
+ This subclass of L<Tie::Handle::Offset> automatically hides an email-style
+ message header. After opening the file, it reads up to a blank or
+ white-space-only line and sets the offset to the next byte.
+
+ =for Pod::Coverage method_names_here
+
+ =head1 AUTHOR
+
+ David Golden <dagolden@cpan.org>
+
+ =head1 COPYRIGHT AND LICENSE
+
+ This software is Copyright (c) 2012 by David Golden.
+
+ This is free software, licensed under:
+
+ The Apache License, Version 2.0, January 2004
+
+ =cut
+TIE_HANDLE_SKIPHEADER
+
$fatpacked{"Try/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TRY_TINY';
- package Try::Tiny; # git description: v0.27-8-g8dc27c7
+ package Try::Tiny; # git description: v0.29-2-g3b23a06
use 5.006;
# ABSTRACT: Minimal try/catch with proper preservation of $@
- our $VERSION = '0.28';
+ our $VERSION = '0.30';
use strict;
use warnings;
@@ -73579,8 +58242,7 @@ $fatpacked{"Try/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TRY_TI
# $catch->();
# name the blocks if we have Sub::Name installed
- my $caller = caller;
- _subname("${caller}::try {...} " => $try)
+ _subname(caller().'::try {...} ' => $try)
if _HAS_SUBNAME;
# set up scope guards to invoke the finally blocks at the end.
@@ -73649,8 +58311,7 @@ $fatpacked{"Try/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TRY_TI
croak 'Useless bare catch()' unless wantarray;
- my $caller = caller;
- _subname("${caller}::catch {...} " => $block)
+ _subname(caller().'::catch {...} ' => $block)
if _HAS_SUBNAME;
return (
bless(\$block, 'Try::Tiny::Catch'),
@@ -73663,8 +58324,7 @@ $fatpacked{"Try/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TRY_TI
croak 'Useless bare finally()' unless wantarray;
- my $caller = caller;
- _subname("${caller}::finally {...} " => $block)
+ _subname(caller().'::finally {...} ' => $block)
if _HAS_SUBNAME;
return (
bless(\$block, 'Try::Tiny::Finally'),
@@ -73717,7 +58377,7 @@ $fatpacked{"Try/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TRY_TI
=head1 VERSION
- version 0.28
+ version 0.30
=head1 SYNOPSIS
@@ -73908,8 +58568,10 @@ $fatpacked{"Try/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TRY_TI
C<$@> must be properly localized before invoking C<eval> in order to avoid this
issue.
- More specifically, C<$@> is clobbered at the beginning of the C<eval>, which
- also makes it impossible to capture the previous error before you die (for
+ More specifically,
+ L<before Perl version 5.14.0|perl5140delta/"Exception Handling">
+ C<$@> was clobbered at the beginning of the C<eval>, which
+ also made it impossible to capture the previous error before you die (for
instance when making exception objects with error stacks).
For this reason C<try> will actually set C<$@> to its previous value (the one
@@ -73952,7 +58614,7 @@ $fatpacked{"Try/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TRY_TI
C<$@> could also be an overloaded error object that evaluates to false, but
that's asking for trouble anyway.
- The classic failure mode is:
+ The classic failure mode (fixed in L<Perl 5.14.0|perl5140delta/"Exception Handling">) is:
sub Object::DESTROY {
eval { ... }
@@ -73988,9 +58650,11 @@ $fatpacked{"Try/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TRY_TI
This is because an C<eval> that caught a C<die> will always return a false
value.
- =head1 SHINY SYNTAX
+ =head1 ALTERNATE SYNTAX
- Using Perl 5.10 you can use L<perlsyn/"Switch statements">.
+ Using Perl 5.10 you can use L<perlsyn/"Switch statements"> (but please don't,
+ because that syntax has since been deprecated because there was too much
+ unexpected magical behaviour).
=for stopwords topicalizer
@@ -74135,8 +58799,8 @@ $fatpacked{"Try/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TRY_TI
}
}
- Note that this behavior was changed once again in L<Perl5 version 18
- |https://metacpan.org/module/perldelta#given-now-aliases-the-global-_>.
+ Note that this behavior was changed once again in
+ L<Perl5 version 18|https://metacpan.org/module/perldelta#given-now-aliases-the-global-_>.
However, since the entirety of lexical C<$_> is now L<considered experimental
|https://metacpan.org/module/perldelta#Lexical-_-is-now-experimental>, it
is unclear whether the new version 18 behavior is final.
@@ -74208,7 +58872,7 @@ $fatpacked{"Try/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TRY_TI
=head1 CONTRIBUTORS
- =for stopwords Karen Etheridge Peter Rabbitson Ricardo Signes Mark Fowler Graham Knop Lukas Mai Dagfinn Ilmari Mannsåker Paul Howarth Rudolf Leermakers anaxagoras awalker chromatic Alex cm-perl Andrew Yates David Lowe Glenn Hans Dieter Pearcey Jonathan Yu Marc Mims Stosberg Pali
+ =for stopwords Karen Etheridge Peter Rabbitson Ricardo Signes Mark Fowler Graham Knop Lukas Mai Aristotle Pagaltzis Dagfinn Ilmari Mannsåker Paul Howarth Rudolf Leermakers anaxagoras awalker chromatic Alex cm-perl Andrew Yates David Lowe Glenn Hans Dieter Pearcey Jens Berthold Jonathan Yu Marc Mims Stosberg Pali
=over 4
@@ -74238,6 +58902,10 @@ $fatpacked{"Try/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TRY_TI
=item *
+ Aristotle Pagaltzis <pagaltzis@gmx.de>
+
+ =item *
+
Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>
=item *
@@ -74286,6 +58954,10 @@ $fatpacked{"Try/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TRY_TI
=item *
+ Jens Berthold <jens@jebecs.de>
+
+ =item *
+
Jonathan Yu <JAWNSY@cpan.org>
=item *
@@ -74313,2112 +58985,9926 @@ $fatpacked{"Try/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TRY_TI
=cut
TRY_TINY
-$fatpacked{"Types/Serialiser.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TYPES_SERIALISER';
- =head1 NAME
+$fatpacked{"URI.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI';
+ package URI;
+
+ use strict;
+ use warnings;
- Types::Serialiser - simple data types for common serialisation formats
+ our $VERSION = '1.76';
- =encoding utf-8
+ our ($ABS_REMOTE_LEADING_DOTS, $ABS_ALLOW_RELATIVE_SCHEME, $DEFAULT_QUERY_FORM_DELIMITER);
+
+ my %implements; # mapping from scheme to implementor class
+
+ # Some "official" character classes
+
+ our $reserved = q(;/?:@&=+$,[]);
+ our $mark = q(-_.!~*'()); #'; emacs
+ our $unreserved = "A-Za-z0-9\Q$mark\E";
+ our $uric = quotemeta($reserved) . $unreserved . "%";
+
+ our $scheme_re = '[a-zA-Z][a-zA-Z0-9.+\-]*';
+
+ use Carp ();
+ use URI::Escape ();
+
+ use overload ('""' => sub { ${$_[0]} },
+ '==' => sub { _obj_eq(@_) },
+ '!=' => sub { !_obj_eq(@_) },
+ fallback => 1,
+ );
+
+ # Check if two objects are the same object
+ sub _obj_eq {
+ return overload::StrVal($_[0]) eq overload::StrVal($_[1]);
+ }
+
+ sub new
+ {
+ my($class, $uri, $scheme) = @_;
+
+ $uri = defined ($uri) ? "$uri" : ""; # stringify
+ # Get rid of potential wrapping
+ $uri =~ s/^<(?:URL:)?(.*)>$/$1/; #
+ $uri =~ s/^"(.*)"$/$1/;
+ $uri =~ s/^\s+//;
+ $uri =~ s/\s+$//;
+
+ my $impclass;
+ if ($uri =~ m/^($scheme_re):/so) {
+ $scheme = $1;
+ }
+ else {
+ if (($impclass = ref($scheme))) {
+ $scheme = $scheme->scheme;
+ }
+ elsif ($scheme && $scheme =~ m/^($scheme_re)(?::|$)/o) {
+ $scheme = $1;
+ }
+ }
+ $impclass ||= implementor($scheme) ||
+ do {
+ require URI::_foreign;
+ $impclass = 'URI::_foreign';
+ };
+
+ return $impclass->_init($uri, $scheme);
+ }
+
+
+ sub new_abs
+ {
+ my($class, $uri, $base) = @_;
+ $uri = $class->new($uri, $base);
+ $uri->abs($base);
+ }
+
+
+ sub _init
+ {
+ my $class = shift;
+ my($str, $scheme) = @_;
+ # find all funny characters and encode the bytes.
+ $str = $class->_uric_escape($str);
+ $str = "$scheme:$str" unless $str =~ /^$scheme_re:/o ||
+ $class->_no_scheme_ok;
+ my $self = bless \$str, $class;
+ $self;
+ }
+
+
+ sub _uric_escape
+ {
+ my($class, $str) = @_;
+ $str =~ s*([^$uric\#])* URI::Escape::escape_char($1) *ego;
+ utf8::downgrade($str);
+ return $str;
+ }
+
+ my %require_attempted;
+
+ sub implementor
+ {
+ my($scheme, $impclass) = @_;
+ if (!$scheme || $scheme !~ /\A$scheme_re\z/o) {
+ require URI::_generic;
+ return "URI::_generic";
+ }
+
+ $scheme = lc($scheme);
+
+ if ($impclass) {
+ # Set the implementor class for a given scheme
+ my $old = $implements{$scheme};
+ $impclass->_init_implementor($scheme);
+ $implements{$scheme} = $impclass;
+ return $old;
+ }
+
+ my $ic = $implements{$scheme};
+ return $ic if $ic;
+
+ # scheme not yet known, look for internal or
+ # preloaded (with 'use') implementation
+ $ic = "URI::$scheme"; # default location
+
+ # turn scheme into a valid perl identifier by a simple transformation...
+ $ic =~ s/\+/_P/g;
+ $ic =~ s/\./_O/g;
+ $ic =~ s/\-/_/g;
+
+ no strict 'refs';
+ # check we actually have one for the scheme:
+ unless (@{"${ic}::ISA"}) {
+ if (not exists $require_attempted{$ic}) {
+ # Try to load it
+ my $_old_error = $@;
+ eval "require $ic";
+ die $@ if $@ && $@ !~ /Can\'t locate.*in \@INC/;
+ $@ = $_old_error;
+ }
+ return undef unless @{"${ic}::ISA"};
+ }
+
+ $ic->_init_implementor($scheme);
+ $implements{$scheme} = $ic;
+ $ic;
+ }
+
+
+ sub _init_implementor
+ {
+ my($class, $scheme) = @_;
+ # Remember that one implementor class may actually
+ # serve to implement several URI schemes.
+ }
+
+
+ sub clone
+ {
+ my $self = shift;
+ my $other = $$self;
+ bless \$other, ref $self;
+ }
+
+ sub TO_JSON { ${$_[0]} }
+
+ sub _no_scheme_ok { 0 }
+
+ sub _scheme
+ {
+ my $self = shift;
+
+ unless (@_) {
+ return undef unless $$self =~ /^($scheme_re):/o;
+ return $1;
+ }
+
+ my $old;
+ my $new = shift;
+ if (defined($new) && length($new)) {
+ Carp::croak("Bad scheme '$new'") unless $new =~ /^$scheme_re$/o;
+ $old = $1 if $$self =~ s/^($scheme_re)://o;
+ my $newself = URI->new("$new:$$self");
+ $$self = $$newself;
+ bless $self, ref($newself);
+ }
+ else {
+ if ($self->_no_scheme_ok) {
+ $old = $1 if $$self =~ s/^($scheme_re)://o;
+ Carp::carp("Oops, opaque part now look like scheme")
+ if $^W && $$self =~ m/^$scheme_re:/o
+ }
+ else {
+ $old = $1 if $$self =~ m/^($scheme_re):/o;
+ }
+ }
+
+ return $old;
+ }
+
+ sub scheme
+ {
+ my $scheme = shift->_scheme(@_);
+ return undef unless defined $scheme;
+ lc($scheme);
+ }
+
+ sub has_recognized_scheme {
+ my $self = shift;
+ return ref($self) !~ /^URI::_(?:foreign|generic)\z/;
+ }
+
+ sub opaque
+ {
+ my $self = shift;
+
+ unless (@_) {
+ $$self =~ /^(?:$scheme_re:)?([^\#]*)/o or die;
+ return $1;
+ }
+
+ $$self =~ /^($scheme_re:)? # optional scheme
+ ([^\#]*) # opaque
+ (\#.*)? # optional fragment
+ $/sx or die;
+
+ my $old_scheme = $1;
+ my $old_opaque = $2;
+ my $old_frag = $3;
+
+ my $new_opaque = shift;
+ $new_opaque = "" unless defined $new_opaque;
+ $new_opaque =~ s/([^$uric])/ URI::Escape::escape_char($1)/ego;
+ utf8::downgrade($new_opaque);
+
+ $$self = defined($old_scheme) ? $old_scheme : "";
+ $$self .= $new_opaque;
+ $$self .= $old_frag if defined $old_frag;
+
+ $old_opaque;
+ }
+
+ sub path { goto &opaque } # alias
+
+
+ sub fragment
+ {
+ my $self = shift;
+ unless (@_) {
+ return undef unless $$self =~ /\#(.*)/s;
+ return $1;
+ }
+
+ my $old;
+ $old = $1 if $$self =~ s/\#(.*)//s;
+
+ my $new_frag = shift;
+ if (defined $new_frag) {
+ $new_frag =~ s/([^$uric])/ URI::Escape::escape_char($1) /ego;
+ utf8::downgrade($new_frag);
+ $$self .= "#$new_frag";
+ }
+ $old;
+ }
+
+
+ sub as_string
+ {
+ my $self = shift;
+ $$self;
+ }
+
+
+ sub as_iri
+ {
+ my $self = shift;
+ my $str = $$self;
+ if ($str =~ s/%([89a-fA-F][0-9a-fA-F])/chr(hex($1))/eg) {
+ # All this crap because the more obvious:
+ #
+ # Encode::decode("UTF-8", $str, sub { sprintf "%%%02X", shift })
+ #
+ # doesn't work before Encode 2.39. Wait for a standard release
+ # to bundle that version.
+
+ require Encode;
+ my $enc = Encode::find_encoding("UTF-8");
+ my $u = "";
+ while (length $str) {
+ $u .= $enc->decode($str, Encode::FB_QUIET());
+ if (length $str) {
+ # escape next char
+ $u .= URI::Escape::escape_char(substr($str, 0, 1, ""));
+ }
+ }
+ $str = $u;
+ }
+ return $str;
+ }
+
+
+ sub canonical
+ {
+ # Make sure scheme is lowercased, that we don't escape unreserved chars,
+ # and that we use upcase escape sequences.
+
+ my $self = shift;
+ my $scheme = $self->_scheme || "";
+ my $uc_scheme = $scheme =~ /[A-Z]/;
+ my $esc = $$self =~ /%[a-fA-F0-9]{2}/;
+ return $self unless $uc_scheme || $esc;
+
+ my $other = $self->clone;
+ if ($uc_scheme) {
+ $other->_scheme(lc $scheme);
+ }
+ if ($esc) {
+ $$other =~ s{%([0-9a-fA-F]{2})}
+ { my $a = chr(hex($1));
+ $a =~ /^[$unreserved]\z/o ? $a : "%\U$1"
+ }ge;
+ }
+ return $other;
+ }
+
+ # Compare two URIs, subclasses will provide a more correct implementation
+ sub eq {
+ my($self, $other) = @_;
+ $self = URI->new($self, $other) unless ref $self;
+ $other = URI->new($other, $self) unless ref $other;
+ ref($self) eq ref($other) && # same class
+ $self->canonical->as_string eq $other->canonical->as_string;
+ }
+
+ # generic-URI transformation methods
+ sub abs { $_[0]; }
+ sub rel { $_[0]; }
+
+ sub secure { 0 }
+
+ # help out Storable
+ sub STORABLE_freeze {
+ my($self, $cloning) = @_;
+ return $$self;
+ }
+
+ sub STORABLE_thaw {
+ my($self, $cloning, $str) = @_;
+ $$self = $str;
+ }
+
+ 1;
+
+ __END__
+
+ =head1 NAME
+
+ URI - Uniform Resource Identifiers (absolute and relative)
=head1 SYNOPSIS
+ use URI;
+
+ $u1 = URI->new("http://www.perl.com");
+ $u2 = URI->new("foo", "http");
+ $u3 = $u2->abs($u1);
+ $u4 = $u3->clone;
+ $u5 = URI->new("HTTP://WWW.perl.com:80")->canonical;
+
+ $str = $u->as_string;
+ $str = "$u";
+
+ $scheme = $u->scheme;
+ $opaque = $u->opaque;
+ $path = $u->path;
+ $frag = $u->fragment;
+
+ $u->scheme("ftp");
+ $u->host("ftp.perl.com");
+ $u->path("cpan/");
+
=head1 DESCRIPTION
- This module provides some extra datatypes that are used by common
- serialisation formats such as JSON or CBOR. The idea is to have a
- repository of simple/small constants and containers that can be shared by
- different implementations so they become interoperable between each other.
+ This module implements the C<URI> class. Objects of this class
+ represent "Uniform Resource Identifier references" as specified in RFC
+ 2396 (and updated by RFC 2732).
+
+ A Uniform Resource Identifier is a compact string of characters that
+ identifies an abstract or physical resource. A Uniform Resource
+ Identifier can be further classified as either a Uniform Resource Locator
+ (URL) or a Uniform Resource Name (URN). The distinction between URL
+ and URN does not matter to the C<URI> class interface. A
+ "URI-reference" is a URI that may have additional information attached
+ in the form of a fragment identifier.
+
+ An absolute URI reference consists of three parts: a I<scheme>, a
+ I<scheme-specific part> and a I<fragment> identifier. A subset of URI
+ references share a common syntax for hierarchical namespaces. For
+ these, the scheme-specific part is further broken down into
+ I<authority>, I<path> and I<query> components. These URIs can also
+ take the form of relative URI references, where the scheme (and
+ usually also the authority) component is missing, but implied by the
+ context of the URI reference. The three forms of URI reference
+ syntax are summarized as follows:
+
+ <scheme>:<scheme-specific-part>#<fragment>
+ <scheme>://<authority><path>?<query>#<fragment>
+ <path>?<query>#<fragment>
+
+ The components into which a URI reference can be divided depend on the
+ I<scheme>. The C<URI> class provides methods to get and set the
+ individual components. The methods available for a specific
+ C<URI> object depend on the scheme.
+
+ =head1 CONSTRUCTORS
+
+ The following methods construct new C<URI> objects:
+
+ =over 4
+
+ =item $uri = URI->new( $str )
+
+ =item $uri = URI->new( $str, $scheme )
+
+ Constructs a new URI object. The string
+ representation of a URI is given as argument, together with an optional
+ scheme specification. Common URI wrappers like "" and <>, as well as
+ leading and trailing white space, are automatically removed from
+ the $str argument before it is processed further.
+
+ The constructor determines the scheme, maps this to an appropriate
+ URI subclass, constructs a new object of that class and returns it.
+
+ If the scheme isn't one of those that URI recognizes, you still get
+ an URI object back that you can access the generic methods on. The
+ C<< $uri->has_recognized_scheme >> method can be used to test for
+ this.
+
+ The $scheme argument is only used when $str is a
+ relative URI. It can be either a simple string that
+ denotes the scheme, a string containing an absolute URI reference, or
+ an absolute C<URI> object. If no $scheme is specified for a relative
+ URI $str, then $str is simply treated as a generic URI (no scheme-specific
+ methods available).
+
+ The set of characters available for building URI references is
+ restricted (see L<URI::Escape>). Characters outside this set are
+ automatically escaped by the URI constructor.
+
+ =item $uri = URI->new_abs( $str, $base_uri )
+
+ Constructs a new absolute URI object. The $str argument can
+ denote a relative or absolute URI. If relative, then it is
+ absolutized using $base_uri as base. The $base_uri must be an absolute
+ URI.
+
+ =item $uri = URI::file->new( $filename )
+
+ =item $uri = URI::file->new( $filename, $os )
+
+ Constructs a new I<file> URI from a file name. See L<URI::file>.
+
+ =item $uri = URI::file->new_abs( $filename )
+
+ =item $uri = URI::file->new_abs( $filename, $os )
+
+ Constructs a new absolute I<file> URI from a file name. See
+ L<URI::file>.
+
+ =item $uri = URI::file->cwd
+
+ Returns the current working directory as a I<file> URI. See
+ L<URI::file>.
+
+ =item $uri->clone
+
+ Returns a copy of the $uri.
+
+ =back
+
+ =head1 COMMON METHODS
+
+ The methods described in this section are available for all C<URI>
+ objects.
+
+ Methods that give access to components of a URI always return the
+ old value of the component. The value returned is C<undef> if the
+ component was not present. There is generally a difference between a
+ component that is empty (represented as C<"">) and a component that is
+ missing (represented as C<undef>). If an accessor method is given an
+ argument, it updates the corresponding component in addition to
+ returning the old value of the component. Passing an undefined
+ argument removes the component (if possible). The description of
+ each accessor method indicates whether the component is passed as
+ an escaped (percent-encoded) or an unescaped string. A component that can be further
+ divided into sub-parts are usually passed escaped, as unescaping might
+ change its semantics.
+
+ The common methods available for all URI are:
+
+ =over 4
+
+ =item $uri->scheme
+
+ =item $uri->scheme( $new_scheme )
+
+ Sets and returns the scheme part of the $uri. If the $uri is
+ relative, then $uri->scheme returns C<undef>. If called with an
+ argument, it updates the scheme of $uri, possibly changing the
+ class of $uri, and returns the old scheme value. The method croaks
+ if the new scheme name is illegal; a scheme name must begin with a
+ letter and must consist of only US-ASCII letters, numbers, and a few
+ special marks: ".", "+", "-". This restriction effectively means
+ that the scheme must be passed unescaped. Passing an undefined
+ argument to the scheme method makes the URI relative (if possible).
+
+ Letter case does not matter for scheme names. The string
+ returned by $uri->scheme is always lowercase. If you want the scheme
+ just as it was written in the URI in its original case,
+ you can use the $uri->_scheme method instead.
+
+ =item $uri->has_recognized_scheme
+
+ Returns TRUE if the URI scheme is one that URI recognizes.
+
+ It will also be TRUE for relative URLs where a recognized
+ scheme was provided to the constructor, even if C<< $uri->scheme >>
+ returns C<undef> for these.
+
+ =item $uri->opaque
+
+ =item $uri->opaque( $new_opaque )
+
+ Sets and returns the scheme-specific part of the $uri
+ (everything between the scheme and the fragment)
+ as an escaped string.
+
+ =item $uri->path
+
+ =item $uri->path( $new_path )
+
+ Sets and returns the same value as $uri->opaque unless the URI
+ supports the generic syntax for hierarchical namespaces.
+ In that case the generic method is overridden to set and return
+ the part of the URI between the I<host name> and the I<fragment>.
+
+ =item $uri->fragment
+
+ =item $uri->fragment( $new_frag )
+
+ Returns the fragment identifier of a URI reference
+ as an escaped string.
+
+ =item $uri->as_string
+
+ Returns a URI object to a plain ASCII string. URI objects are
+ also converted to plain strings automatically by overloading. This
+ means that $uri objects can be used as plain strings in most Perl
+ constructs.
+
+ =item $uri->as_iri
+
+ Returns a Unicode string representing the URI. Escaped UTF-8 sequences
+ representing non-ASCII characters are turned into their corresponding Unicode
+ code point.
+
+ =item $uri->canonical
+
+ Returns a normalized version of the URI. The rules
+ for normalization are scheme-dependent. They usually involve
+ lowercasing the scheme and Internet host name components,
+ removing the explicit port specification if it matches the default port,
+ uppercasing all escape sequences, and unescaping octets that can be
+ better represented as plain characters.
+
+ For efficiency reasons, if the $uri is already in normalized form,
+ then a reference to it is returned instead of a copy.
+
+ =item $uri->eq( $other_uri )
+
+ =item URI::eq( $first_uri, $other_uri )
+
+ Tests whether two URI references are equal. URI references
+ that normalize to the same string are considered equal. The method
+ can also be used as a plain function which can also test two string
+ arguments.
+
+ If you need to test whether two C<URI> object references denote the
+ same object, use the '==' operator.
+
+ =item $uri->abs( $base_uri )
+
+ Returns an absolute URI reference. If $uri is already
+ absolute, then a reference to it is simply returned. If the $uri
+ is relative, then a new absolute URI is constructed by combining the
+ $uri and the $base_uri, and returned.
+
+ =item $uri->rel( $base_uri )
+
+ Returns a relative URI reference if it is possible to
+ make one that denotes the same resource relative to $base_uri.
+ If not, then $uri is simply returned.
+
+ =item $uri->secure
+
+ Returns a TRUE value if the URI is considered to point to a resource on
+ a secure channel, such as an SSL or TLS encrypted one.
+
+ =back
+
+ =head1 GENERIC METHODS
+
+ The following methods are available to schemes that use the
+ common/generic syntax for hierarchical namespaces. The descriptions of
+ schemes below indicate which these are. Unrecognized schemes are
+ assumed to support the generic syntax, and therefore the following
+ methods:
+
+ =over 4
+
+ =item $uri->authority
+
+ =item $uri->authority( $new_authority )
+
+ Sets and returns the escaped authority component
+ of the $uri.
+
+ =item $uri->path
+
+ =item $uri->path( $new_path )
+
+ Sets and returns the escaped path component of
+ the $uri (the part between the host name and the query or fragment).
+ The path can never be undefined, but it can be the empty string.
+
+ =item $uri->path_query
+
+ =item $uri->path_query( $new_path_query )
+
+ Sets and returns the escaped path and query
+ components as a single entity. The path and the query are
+ separated by a "?" character, but the query can itself contain "?".
+
+ =item $uri->path_segments
+
+ =item $uri->path_segments( $segment, ... )
+
+ Sets and returns the path. In a scalar context, it returns
+ the same value as $uri->path. In a list context, it returns the
+ unescaped path segments that make up the path. Path segments that
+ have parameters are returned as an anonymous array. The first element
+ is the unescaped path segment proper; subsequent elements are escaped
+ parameter strings. Such an anonymous array uses overloading so it can
+ be treated as a string too, but this string does not include the
+ parameters.
+
+ Note that absolute paths have the empty string as their first
+ I<path_segment>, i.e. the I<path> C</foo/bar> have 3
+ I<path_segments>; "", "foo" and "bar".
+
+ =item $uri->query
+
+ =item $uri->query( $new_query )
+
+ Sets and returns the escaped query component of
+ the $uri.
+
+ =item $uri->query_form
+
+ =item $uri->query_form( $key1 => $val1, $key2 => $val2, ... )
+
+ =item $uri->query_form( $key1 => $val1, $key2 => $val2, ..., $delim )
+
+ =item $uri->query_form( \@key_value_pairs )
+
+ =item $uri->query_form( \@key_value_pairs, $delim )
+
+ =item $uri->query_form( \%hash )
+
+ =item $uri->query_form( \%hash, $delim )
+
+ Sets and returns query components that use the
+ I<application/x-www-form-urlencoded> format. Key/value pairs are
+ separated by "&", and the key is separated from the value by a "="
+ character.
+
+ The form can be set either by passing separate key/value pairs, or via
+ an array or hash reference. Passing an empty array or an empty hash
+ removes the query component, whereas passing no arguments at all leaves
+ the component unchanged. The order of keys is undefined if a hash
+ reference is passed. The old value is always returned as a list of
+ separate key/value pairs. Assigning this list to a hash is unwise as
+ the keys returned might repeat.
+
+ The values passed when setting the form can be plain strings or
+ references to arrays of strings. Passing an array of values has the
+ same effect as passing the key repeatedly with one value at a time.
+ All the following statements have the same effect:
+
+ $uri->query_form(foo => 1, foo => 2);
+ $uri->query_form(foo => [1, 2]);
+ $uri->query_form([ foo => 1, foo => 2 ]);
+ $uri->query_form([ foo => [1, 2] ]);
+ $uri->query_form({ foo => [1, 2] });
+
+ The $delim parameter can be passed as ";" to force the key/value pairs
+ to be delimited by ";" instead of "&" in the query string. This
+ practice is often recommended for URLs embedded in HTML or XML
+ documents as this avoids the trouble of escaping the "&" character.
+ You might also set the $URI::DEFAULT_QUERY_FORM_DELIMITER variable to
+ ";" for the same global effect.
+
+ The C<URI::QueryParam> module can be loaded to add further methods to
+ manipulate the form of a URI. See L<URI::QueryParam> for details.
+
+ =item $uri->query_keywords
+
+ =item $uri->query_keywords( $keywords, ... )
+
+ =item $uri->query_keywords( \@keywords )
+
+ Sets and returns query components that use the
+ keywords separated by "+" format.
+
+ The keywords can be set either by passing separate keywords directly
+ or by passing a reference to an array of keywords. Passing an empty
+ array removes the query component, whereas passing no arguments at
+ all leaves the component unchanged. The old value is always returned
+ as a list of separate words.
+
+ =back
+
+ =head1 SERVER METHODS
+
+ For schemes where the I<authority> component denotes an Internet host,
+ the following methods are available in addition to the generic
+ methods.
+
+ =over 4
+
+ =item $uri->userinfo
+
+ =item $uri->userinfo( $new_userinfo )
+
+ Sets and returns the escaped userinfo part of the
+ authority component.
+
+ For some schemes this is a user name and a password separated by
+ a colon. This practice is not recommended. Embedding passwords in
+ clear text (such as URI) has proven to be a security risk in almost
+ every case where it has been used.
+
+ =item $uri->host
+
+ =item $uri->host( $new_host )
+
+ Sets and returns the unescaped hostname.
+
+ If the $new_host string ends with a colon and a number, then this
+ number also sets the port.
+
+ For IPv6 addresses the brackets around the raw address is removed in the return
+ value from $uri->host. When setting the host attribute to an IPv6 address you
+ can use a raw address or one enclosed in brackets. The address needs to be
+ enclosed in brackets if you want to pass in a new port value as well.
+
+ =item $uri->ihost
+
+ Returns the host in Unicode form. Any IDNA A-labels are turned into U-labels.
+
+ =item $uri->port
+
+ =item $uri->port( $new_port )
+
+ Sets and returns the port. The port is a simple integer
+ that should be greater than 0.
+
+ If a port is not specified explicitly in the URI, then the URI scheme's default port
+ is returned. If you don't want the default port
+ substituted, then you can use the $uri->_port method instead.
+
+ =item $uri->host_port
+
+ =item $uri->host_port( $new_host_port )
+
+ Sets and returns the host and port as a single
+ unit. The returned value includes a port, even if it matches the
+ default port. The host part and the port part are separated by a
+ colon: ":".
+
+ For IPv6 addresses the bracketing is preserved; thus
+ URI->new("http://[::1]/")->host_port returns "[::1]:80". Contrast this with
+ $uri->host which will remove the brackets.
+
+ =item $uri->default_port
+
+ Returns the default port of the URI scheme to which $uri
+ belongs. For I<http> this is the number 80, for I<ftp> this
+ is the number 21, etc. The default port for a scheme can not be
+ changed.
+
+ =back
+
+ =head1 SCHEME-SPECIFIC SUPPORT
+
+ Scheme-specific support is provided for the following URI schemes. For C<URI>
+ objects that do not belong to one of these, you can only use the common and
+ generic methods.
+
+ =over 4
+
+ =item B<data>:
+
+ The I<data> URI scheme is specified in RFC 2397. It allows inclusion
+ of small data items as "immediate" data, as if it had been included
+ externally.
+
+ C<URI> objects belonging to the data scheme support the common methods
+ and two new methods to access their scheme-specific components:
+ $uri->media_type and $uri->data. See L<URI::data> for details.
+
+ =item B<file>:
+
+ An old specification of the I<file> URI scheme is found in RFC 1738.
+ A new RFC 2396 based specification in not available yet, but file URI
+ references are in common use.
+
+ C<URI> objects belonging to the file scheme support the common and
+ generic methods. In addition, they provide two methods for mapping file URIs
+ back to local file names; $uri->file and $uri->dir. See L<URI::file>
+ for details.
+
+ =item B<ftp>:
+
+ An old specification of the I<ftp> URI scheme is found in RFC 1738. A
+ new RFC 2396 based specification in not available yet, but ftp URI
+ references are in common use.
+
+ C<URI> objects belonging to the ftp scheme support the common,
+ generic and server methods. In addition, they provide two methods for
+ accessing the userinfo sub-components: $uri->user and $uri->password.
+
+ =item B<gopher>:
+
+ The I<gopher> URI scheme is specified in
+ <draft-murali-url-gopher-1996-12-04> and will hopefully be available
+ as a RFC 2396 based specification.
+
+ C<URI> objects belonging to the gopher scheme support the common,
+ generic and server methods. In addition, they support some methods for
+ accessing gopher-specific path components: $uri->gopher_type,
+ $uri->selector, $uri->search, $uri->string.
+
+ =item B<http>:
+
+ The I<http> URI scheme is specified in RFC 2616.
+ The scheme is used to reference resources hosted by HTTP servers.
+
+ C<URI> objects belonging to the http scheme support the common,
+ generic and server methods.
+
+ =item B<https>:
+
+ The I<https> URI scheme is a Netscape invention which is commonly
+ implemented. The scheme is used to reference HTTP servers through SSL
+ connections. Its syntax is the same as http, but the default
+ port is different.
+
+ =item B<ldap>:
+
+ The I<ldap> URI scheme is specified in RFC 2255. LDAP is the
+ Lightweight Directory Access Protocol. An ldap URI describes an LDAP
+ search operation to perform to retrieve information from an LDAP
+ directory.
+
+ C<URI> objects belonging to the ldap scheme support the common,
+ generic and server methods as well as ldap-specific methods: $uri->dn,
+ $uri->attributes, $uri->scope, $uri->filter, $uri->extensions. See
+ L<URI::ldap> for details.
+
+ =item B<ldapi>:
+
+ Like the I<ldap> URI scheme, but uses a UNIX domain socket. The
+ server methods are not supported, and the local socket path is
+ available as $uri->un_path. The I<ldapi> scheme is used by the
+ OpenLDAP package. There is no real specification for it, but it is
+ mentioned in various OpenLDAP manual pages.
+
+ =item B<ldaps>:
+
+ Like the I<ldap> URI scheme, but uses an SSL connection. This
+ scheme is deprecated, as the preferred way is to use the I<start_tls>
+ mechanism.
+
+ =item B<mailto>:
+
+ The I<mailto> URI scheme is specified in RFC 2368. The scheme was
+ originally used to designate the Internet mailing address of an
+ individual or service. It has (in RFC 2368) been extended to allow
+ setting of other mail header fields and the message body.
+
+ C<URI> objects belonging to the mailto scheme support the common
+ methods and the generic query methods. In addition, they support the
+ following mailto-specific methods: $uri->to, $uri->headers.
+
+ Note that the "foo@example.com" part of a mailto is I<not> the
+ C<userinfo> and C<host> but instead the C<path>. This allows a
+ mailto URI to contain multiple comma separated email addresses.
+
+ =item B<mms>:
+
+ The I<mms> URL specification can be found at L<http://sdp.ppona.com/>.
+ C<URI> objects belonging to the mms scheme support the common,
+ generic, and server methods, with the exception of userinfo and
+ query-related sub-components.
+
+ =item B<news>:
+
+ The I<news>, I<nntp> and I<snews> URI schemes are specified in
+ <draft-gilman-news-url-01> and will hopefully be available as an RFC
+ 2396 based specification soon.
+
+ C<URI> objects belonging to the news scheme support the common,
+ generic and server methods. In addition, they provide some methods to
+ access the path: $uri->group and $uri->message.
+
+ =item B<nntp>:
+
+ See I<news> scheme.
+
+ =item B<pop>:
+
+ The I<pop> URI scheme is specified in RFC 2384. The scheme is used to
+ reference a POP3 mailbox.
+
+ C<URI> objects belonging to the pop scheme support the common, generic
+ and server methods. In addition, they provide two methods to access the
+ userinfo components: $uri->user and $uri->auth
+
+ =item B<rlogin>:
+
+ An old specification of the I<rlogin> URI scheme is found in RFC
+ 1738. C<URI> objects belonging to the rlogin scheme support the
+ common, generic and server methods.
+
+ =item B<rtsp>:
+
+ The I<rtsp> URL specification can be found in section 3.2 of RFC 2326.
+ C<URI> objects belonging to the rtsp scheme support the common,
+ generic, and server methods, with the exception of userinfo and
+ query-related sub-components.
+
+ =item B<rtspu>:
+
+ The I<rtspu> URI scheme is used to talk to RTSP servers over UDP
+ instead of TCP. The syntax is the same as rtsp.
+
+ =item B<rsync>:
+
+ Information about rsync is available from L<http://rsync.samba.org/>.
+ C<URI> objects belonging to the rsync scheme support the common,
+ generic and server methods. In addition, they provide methods to
+ access the userinfo sub-components: $uri->user and $uri->password.
+
+ =item B<sip>:
+
+ The I<sip> URI specification is described in sections 19.1 and 25
+ of RFC 3261. C<URI> objects belonging to the sip scheme support the
+ common, generic, and server methods with the exception of path related
+ sub-components. In addition, they provide two methods to get and set
+ I<sip> parameters: $uri->params_form and $uri->params.
+
+ =item B<sips>:
+
+ See I<sip> scheme. Its syntax is the same as sip, but the default
+ port is different.
+
+ =item B<snews>:
+
+ See I<news> scheme. Its syntax is the same as news, but the default
+ port is different.
+
+ =item B<telnet>:
+
+ An old specification of the I<telnet> URI scheme is found in RFC
+ 1738. C<URI> objects belonging to the telnet scheme support the
+ common, generic and server methods.
+
+ =item B<tn3270>:
+
+ These URIs are used like I<telnet> URIs but for connections to IBM
+ mainframes. C<URI> objects belonging to the tn3270 scheme support the
+ common, generic and server methods.
+
+ =item B<ssh>:
+
+ Information about ssh is available at L<http://www.openssh.com/>.
+ C<URI> objects belonging to the ssh scheme support the common,
+ generic and server methods. In addition, they provide methods to
+ access the userinfo sub-components: $uri->user and $uri->password.
+
+ =item B<sftp>:
+
+ C<URI> objects belonging to the sftp scheme support the common,
+ generic and server methods. In addition, they provide methods to
+ access the userinfo sub-components: $uri->user and $uri->password.
+
+ =item B<urn>:
+
+ The syntax of Uniform Resource Names is specified in RFC 2141. C<URI>
+ objects belonging to the urn scheme provide the common methods, and also the
+ methods $uri->nid and $uri->nss, which return the Namespace Identifier
+ and the Namespace-Specific String respectively.
+
+ The Namespace Identifier basically works like the Scheme identifier of
+ URIs, and further divides the URN namespace. Namespace Identifier
+ assignments are maintained at
+ L<http://www.iana.org/assignments/urn-namespaces>.
+
+ Letter case is not significant for the Namespace Identifier. It is
+ always returned in lower case by the $uri->nid method. The $uri->_nid
+ method can be used if you want it in its original case.
+
+ =item B<urn>:B<isbn>:
+
+ The C<urn:isbn:> namespace contains International Standard Book
+ Numbers (ISBNs) and is described in RFC 3187. A C<URI> object belonging
+ to this namespace has the following extra methods (if the
+ Business::ISBN module is available): $uri->isbn,
+ $uri->isbn_publisher_code, $uri->isbn_group_code (formerly isbn_country_code,
+ which is still supported by issues a deprecation warning), $uri->isbn_as_ean.
+
+ =item B<urn>:B<oid>:
+
+ The C<urn:oid:> namespace contains Object Identifiers (OIDs) and is
+ described in RFC 3061. An object identifier consists of sequences of digits
+ separated by dots. A C<URI> object belonging to this namespace has an
+ additional method called $uri->oid that can be used to get/set the oid
+ value. In a list context, oid numbers are returned as separate elements.
+
+ =back
+
+ =head1 CONFIGURATION VARIABLES
+
+ The following configuration variables influence how the class and its
+ methods behave:
+
+ =over 4
+
+ =item $URI::ABS_ALLOW_RELATIVE_SCHEME
+
+ Some older parsers used to allow the scheme name to be present in the
+ relative URL if it was the same as the base URL scheme. RFC 2396 says
+ that this should be avoided, but you can enable this old behaviour by
+ setting the $URI::ABS_ALLOW_RELATIVE_SCHEME variable to a TRUE value.
+ The difference is demonstrated by the following examples:
+
+ URI->new("http:foo")->abs("http://host/a/b")
+ ==> "http:foo"
+
+ local $URI::ABS_ALLOW_RELATIVE_SCHEME = 1;
+ URI->new("http:foo")->abs("http://host/a/b")
+ ==> "http:/host/a/foo"
+
+
+ =item $URI::ABS_REMOTE_LEADING_DOTS
+
+ You can also have the abs() method ignore excess ".."
+ segments in the relative URI by setting $URI::ABS_REMOTE_LEADING_DOTS
+ to a TRUE value. The difference is demonstrated by the following
+ examples:
+
+ URI->new("../../../foo")->abs("http://host/a/b")
+ ==> "http://host/../../foo"
+
+ local $URI::ABS_REMOTE_LEADING_DOTS = 1;
+ URI->new("../../../foo")->abs("http://host/a/b")
+ ==> "http://host/foo"
+
+ =item $URI::DEFAULT_QUERY_FORM_DELIMITER
+
+ This value can be set to ";" to have the query form C<key=value> pairs
+ delimited by ";" instead of "&" which is the default.
+
+ =back
+
+ =head1 BUGS
+
+ There are some things that are not quite right:
+
+ =over
+
+ =item *
+
+ Using regexp variables like $1 directly as arguments to the URI accessor methods
+ does not work too well with current perl implementations. I would argue
+ that this is actually a bug in perl. The workaround is to quote
+ them. Example:
+
+ /(...)/ || die;
+ $u->query("$1");
+
+
+ =item *
+
+ The escaping (percent encoding) of chars in the 128 .. 255 range passed to the
+ URI constructor or when setting URI parts using the accessor methods depend on
+ the state of the internal UTF8 flag (see utf8::is_utf8) of the string passed.
+ If the UTF8 flag is set the UTF-8 encoded version of the character is percent
+ encoded. If the UTF8 flag isn't set the Latin-1 version (byte) of the
+ character is percent encoded. This basically exposes the internal encoding of
+ Perl strings.
+
+ =back
+
+ =head1 PARSING URIs WITH REGEXP
+
+ As an alternative to this module, the following (official) regular
+ expression can be used to decode a URI:
+
+ my($scheme, $authority, $path, $query, $fragment) =
+ $uri =~ m|(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?|;
+
+ The C<URI::Split> module provides the function uri_split() as a
+ readable alternative.
+
+ =head1 SEE ALSO
+
+ L<URI::file>, L<URI::WithBase>, L<URI::QueryParam>, L<URI::Escape>,
+ L<URI::Split>, L<URI::Heuristic>
+
+ RFC 2396: "Uniform Resource Identifiers (URI): Generic Syntax",
+ Berners-Lee, Fielding, Masinter, August 1998.
+
+ L<http://www.iana.org/assignments/uri-schemes>
+
+ L<http://www.iana.org/assignments/urn-namespaces>
+
+ L<http://www.w3.org/Addressing/>
+
+ =head1 COPYRIGHT
+
+ Copyright 1995-2009 Gisle Aas.
+
+ Copyright 1995 Martijn Koster.
+
+ This program is free software; you can redistribute it and/or modify
+ it under the same terms as Perl itself.
+
+ =head1 AUTHORS / ACKNOWLEDGMENTS
+
+ This module is based on the C<URI::URL> module, which in turn was
+ (distantly) based on the C<wwwurl.pl> code in the libwww-perl for
+ perl4 developed by Roy Fielding, as part of the Arcadia project at the
+ University of California, Irvine, with contributions from Brooks
+ Cutter.
+
+ C<URI::URL> was developed by Gisle Aas, Tim Bunce, Roy Fielding and
+ Martijn Koster with input from other people on the libwww-perl mailing
+ list.
+
+ C<URI> and related subclasses was developed by Gisle Aas.
=cut
+URI
+
+$fatpacked{"URI/Escape.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_ESCAPE';
+ package URI::Escape;
- package Types::Serialiser;
+ use strict;
+ use warnings;
- use common::sense; # required to suppress annoying warnings
+ =head1 NAME
- our $VERSION = '1.0';
+ URI::Escape - Percent-encode and percent-decode unsafe characters
- =head1 SIMPLE SCALAR CONSTANTS
+ =head1 SYNOPSIS
- Simple scalar constants are values that are overloaded to act like simple
- Perl values, but have (class) type to differentiate them from normal Perl
- scalars. This is necessary because these have different representations in
- the serialisation formats.
+ use URI::Escape;
+ $safe = uri_escape("10% is enough\n");
+ $verysafe = uri_escape("foo", "\0-\377");
+ $str = uri_unescape($safe);
- =head2 BOOLEANS (Types::Serialiser::Boolean class)
+ =head1 DESCRIPTION
+
+ This module provides functions to percent-encode and percent-decode URI strings as
+ defined by RFC 3986. Percent-encoding URI's is informally called "URI escaping".
+ This is the terminology used by this module, which predates the formalization of the
+ terms by the RFC by several years.
+
+ A URI consists of a restricted set of characters. The restricted set
+ of characters consists of digits, letters, and a few graphic symbols
+ chosen from those common to most of the character encodings and input
+ facilities available to Internet users. They are made up of the
+ "unreserved" and "reserved" character sets as defined in RFC 3986.
+
+ unreserved = ALPHA / DIGIT / "-" / "." / "_" / "~"
+ reserved = ":" / "/" / "?" / "#" / "[" / "]" / "@"
+ "!" / "$" / "&" / "'" / "(" / ")"
+ / "*" / "+" / "," / ";" / "="
+
+ In addition, any byte (octet) can be represented in a URI by an escape
+ sequence: a triplet consisting of the character "%" followed by two
+ hexadecimal digits. A byte can also be represented directly by a
+ character, using the US-ASCII character for that octet.
- This type has only two instances, true and false. A natural representation
- for these in Perl is C<1> and C<0>, but serialisation formats need to be
- able to differentiate between them and mere numbers.
+ Some of the characters are I<reserved> for use as delimiters or as
+ part of certain URI components. These must be escaped if they are to
+ be treated as ordinary data. Read RFC 3986 for further details.
+
+ The functions provided (and exported by default) from this module are:
=over 4
- =item $Types::Serialiser::true, Types::Serialiser::true
+ =item uri_escape( $string )
+
+ =item uri_escape( $string, $unsafe )
+
+ Replaces each unsafe character in the $string with the corresponding
+ escape sequence and returns the result. The $string argument should
+ be a string of bytes. The uri_escape() function will croak if given a
+ characters with code above 255. Use uri_escape_utf8() if you know you
+ have such chars or/and want chars in the 128 .. 255 range treated as
+ UTF-8.
+
+ The uri_escape() function takes an optional second argument that
+ overrides the set of characters that are to be escaped. The set is
+ specified as a string that can be used in a regular expression
+ character class (between [ ]). E.g.:
+
+ "\x00-\x1f\x7f-\xff" # all control and hi-bit characters
+ "a-z" # all lower case characters
+ "^A-Za-z" # everything not a letter
- This value represents the "true" value. In most contexts is acts like
- the number C<1>. It is up to you whether you use the variable form
- (C<$Types::Serialiser::true>) or the constant form (C<Types::Serialiser::true>).
+ The default set of characters to be escaped is all those which are
+ I<not> part of the C<unreserved> character class shown above as well
+ as the reserved characters. I.e. the default is:
- The constant is represented as a reference to a scalar containing C<1> -
- implementations are allowed to directly test for this.
+ "^A-Za-z0-9\-\._~"
- =item $Types::Serialiser::false, Types::Serialiser::false
+ =item uri_escape_utf8( $string )
- This value represents the "false" value. In most contexts is acts like
- the number C<0>. It is up to you whether you use the variable form
- (C<$Types::Serialiser::false>) or the constant form (C<Types::Serialiser::false>).
+ =item uri_escape_utf8( $string, $unsafe )
- The constant is represented as a reference to a scalar containing C<0> -
- implementations are allowed to directly test for this.
+ Works like uri_escape(), but will encode chars as UTF-8 before
+ escaping them. This makes this function able to deal with characters
+ with code above 255 in $string. Note that chars in the 128 .. 255
+ range will be escaped differently by this function compared to what
+ uri_escape() would. For chars in the 0 .. 127 range there is no
+ difference.
- =item $is_bool = Types::Serialiser::is_bool $value
+ Equivalent to:
- Returns true iff the C<$value> is either C<$Types::Serialiser::true> or
- C<$Types::Serialiser::false>.
+ utf8::encode($string);
+ my $uri = uri_escape($string);
- For example, you could differentiate between a perl true value and a
- C<Types::Serialiser::true> by using this:
+ Note: JavaScript has a function called escape() that produces the
+ sequence "%uXXXX" for chars in the 256 .. 65535 range. This function
+ has really nothing to do with URI escaping but some folks got confused
+ since it "does the right thing" in the 0 .. 255 range. Because of
+ this you sometimes see "URIs" with these kind of escapes. The
+ JavaScript encodeURIComponent() function is similar to uri_escape_utf8().
- $value && Types::Serialiser::is_bool $value
+ =item uri_unescape($string,...)
- =item $is_true = Types::Serialiser::is_true $value
+ Returns a string with each %XX sequence replaced with the actual byte
+ (octet).
- Returns true iff C<$value> is C<$Types::Serialiser::true>.
+ This does the same as:
- =item $is_false = Types::Serialiser::is_false $value
+ $string =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
- Returns false iff C<$value> is C<$Types::Serialiser::false>.
+ but does not modify the string in-place as this RE would. Using the
+ uri_unescape() function instead of the RE might make the code look
+ cleaner and is a few characters less to type.
+
+ In a simple benchmark test I did,
+ calling the function (instead of the inline RE above) if a few chars
+ were unescaped was something like 40% slower, and something like 700% slower if none were. If
+ you are going to unescape a lot of times it might be a good idea to
+ inline the RE.
+
+ If the uri_unescape() function is passed multiple strings, then each
+ one is returned unescaped.
=back
- =head2 ERROR (Types::Serialiser::Error class)
+ The module can also export the C<%escapes> hash, which contains the
+ mapping from all 256 bytes to the corresponding escape codes. Lookup
+ in this hash is faster than evaluating C<sprintf("%%%02X", ord($byte))>
+ each time.
+
+ =head1 SEE ALSO
+
+ L<URI>
+
+
+ =head1 COPYRIGHT
+
+ Copyright 1995-2004 Gisle Aas.
+
+ This program is free software; you can redistribute it and/or modify
+ it under the same terms as Perl itself.
+
+ =cut
+
+ use Exporter 5.57 'import';
+ our %escapes;
+ our @EXPORT = qw(uri_escape uri_unescape uri_escape_utf8);
+ our @EXPORT_OK = qw(%escapes);
+ our $VERSION = "3.31";
+
+ use Carp ();
+
+ # Build a char->hex map
+ for (0..255) {
+ $escapes{chr($_)} = sprintf("%%%02X", $_);
+ }
+
+ my %subst; # compiled patterns
+
+ my %Unsafe = (
+ RFC2732 => qr/[^A-Za-z0-9\-_.!~*'()]/,
+ RFC3986 => qr/[^A-Za-z0-9\-\._~]/,
+ );
- This class has only a single instance, C<error>. It is used to signal
- an encoding or decoding error. In CBOR for example, and object that
- couldn't be encoded will be represented by a CBOR undefined value, which
- is represented by the error value in Perl.
+ sub uri_escape {
+ my($text, $patn) = @_;
+ return undef unless defined $text;
+ if (defined $patn){
+ unless (exists $subst{$patn}) {
+ # Because we can't compile the regex we fake it with a cached sub
+ (my $tmp = $patn) =~ s,/,\\/,g;
+ eval "\$subst{\$patn} = sub {\$_[0] =~ s/([$tmp])/\$escapes{\$1} || _fail_hi(\$1)/ge; }";
+ Carp::croak("uri_escape: $@") if $@;
+ }
+ &{$subst{$patn}}($text);
+ } else {
+ $text =~ s/($Unsafe{RFC3986})/$escapes{$1} || _fail_hi($1)/ge;
+ }
+ $text;
+ }
+
+ sub _fail_hi {
+ my $chr = shift;
+ Carp::croak(sprintf "Can't escape \\x{%04X}, try uri_escape_utf8() instead", ord($chr));
+ }
+
+ sub uri_escape_utf8 {
+ my $text = shift;
+ return undef unless defined $text;
+ utf8::encode($text);
+ return uri_escape($text, @_);
+ }
+
+ sub uri_unescape {
+ # Note from RFC1630: "Sequences which start with a percent sign
+ # but are not followed by two hexadecimal characters are reserved
+ # for future extension"
+ my $str = shift;
+ if (@_ && wantarray) {
+ # not executed for the common case of a single argument
+ my @str = ($str, @_); # need to copy
+ for (@str) {
+ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
+ }
+ return @str;
+ }
+ $str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg if defined $str;
+ $str;
+ }
+
+ # XXX FIXME escape_char is buggy as it assigns meaning to the string's storage format.
+ sub escape_char {
+ # Old versions of utf8::is_utf8() didn't properly handle magical vars (e.g. $1).
+ # The following forces a fetch to occur beforehand.
+ my $dummy = substr($_[0], 0, 0);
+
+ if (utf8::is_utf8($_[0])) {
+ my $s = shift;
+ utf8::encode($s);
+ unshift(@_, $s);
+ }
+
+ return join '', @URI::Escape::escapes{split //, $_[0]};
+ }
+
+ 1;
+URI_ESCAPE
+
+$fatpacked{"URI/Heuristic.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_HEURISTIC';
+ package URI::Heuristic;
+
+ =head1 NAME
+
+ URI::Heuristic - Expand URI using heuristics
+
+ =head1 SYNOPSIS
+
+ use URI::Heuristic qw(uf_uristr);
+ $u = uf_uristr("perl"); # http://www.perl.com
+ $u = uf_uristr("www.sol.no/sol"); # http://www.sol.no/sol
+ $u = uf_uristr("aas"); # http://www.aas.no
+ $u = uf_uristr("ftp.funet.fi"); # ftp://ftp.funet.fi
+ $u = uf_uristr("/etc/passwd"); # file:/etc/passwd
+
+ =head1 DESCRIPTION
+
+ This module provides functions that expand strings into real absolute
+ URIs using some built-in heuristics. Strings that already represent
+ absolute URIs (i.e. that start with a C<scheme:> part) are never modified
+ and are returned unchanged. The main use of these functions is to
+ allow abbreviated URIs similar to what many web browsers allow for URIs
+ typed in by the user.
+
+ The following functions are provided:
=over 4
- =item $Types::Serialiser::error, Types::Serialiser::error
+ =item uf_uristr($str)
+
+ Tries to make the argument string
+ into a proper absolute URI string. The "uf_" prefix stands for "User
+ Friendly". Under MacOS, it assumes that any string with a common URL
+ scheme (http, ftp, etc.) is a URL rather than a local path. So don't name
+ your volumes after common URL schemes and expect uf_uristr() to construct
+ valid file: URL's on those volumes for you, because it won't.
+
+ =item uf_uri($str)
+
+ Works the same way as uf_uristr() but
+ returns a C<URI> object.
+
+ =back
+
+ =head1 ENVIRONMENT
+
+ If the hostname portion of a URI does not contain any dots, then
+ certain qualified guesses are made. These guesses are governed by
+ the following environment variables:
+
+ =over 10
- This value represents the "error" value. Accessing values of this type
- will throw an exception.
+ =item COUNTRY
- The constant is represented as a reference to a scalar containing C<undef>
- - implementations are allowed to directly test for this.
+ The two-letter country code (ISO 3166) for your location. If
+ the domain name of your host ends with two letters, then it is taken
+ to be the default country. See also L<Locale::Country>.
- =item $is_error = Types::Serialiser::is_error $value
+ =item HTTP_ACCEPT_LANGUAGE, LC_ALL, LANG
- Returns false iff C<$value> is C<$Types::Serialiser::error>.
+ If COUNTRY is not set, these standard environment variables are
+ examined and country (not language) information possibly found in them
+ is used as the default country.
+
+ =item URL_GUESS_PATTERN
+
+ Contains a space-separated list of URL patterns to try. The string
+ "ACME" is for some reason used as a placeholder for the host name in
+ the URL provided. Example:
+
+ URL_GUESS_PATTERN="www.ACME.no www.ACME.se www.ACME.com"
+ export URL_GUESS_PATTERN
+
+ Specifying URL_GUESS_PATTERN disables any guessing rules based on
+ country. An empty URL_GUESS_PATTERN disables any guessing that
+ involves host name lookups.
=back
+ =head1 COPYRIGHT
+
+ Copyright 1997-1998, Gisle Aas
+
+ This library is free software; you can redistribute it and/or
+ modify it under the same terms as Perl itself.
+
=cut
- BEGIN {
- # for historical reasons, and to avoid extra dependencies in JSON::PP,
- # we alias *Types::Serialiser::Boolean with JSON::PP::Boolean.
- package JSON::PP::Boolean;
+ use strict;
+ use warnings;
+
+ use Exporter 5.57 'import';
+ our @EXPORT_OK = qw(uf_uri uf_uristr uf_url uf_urlstr);
+ our $VERSION = "4.20";
+
+ our ($MY_COUNTRY, $DEBUG);
+
+ sub MY_COUNTRY() {
+ for ($MY_COUNTRY) {
+ return $_ if defined;
+
+ # First try the environment.
+ $_ = $ENV{COUNTRY};
+ return $_ if defined;
+
+ # Try the country part of LC_ALL and LANG from environment
+ my @srcs = ($ENV{LC_ALL}, $ENV{LANG});
+ # ...and HTTP_ACCEPT_LANGUAGE before those if present
+ if (my $httplang = $ENV{HTTP_ACCEPT_LANGUAGE}) {
+ # TODO: q-value processing/ordering
+ for $httplang (split(/\s*,\s*/, $httplang)) {
+ if ($httplang =~ /^\s*([a-zA-Z]+)[_-]([a-zA-Z]{2})\s*$/) {
+ unshift(@srcs, "${1}_${2}");
+ last;
+ }
+ }
+ }
+ for (@srcs) {
+ next unless defined;
+ return lc($1) if /^[a-zA-Z]+_([a-zA-Z]{2})(?:[.@]|$)/;
+ }
+
+ # Last bit of domain name. This may access the network.
+ require Net::Domain;
+ my $fqdn = Net::Domain::hostfqdn();
+ $_ = lc($1) if $fqdn =~ /\.([a-zA-Z]{2})$/;
+ return $_ if defined;
+
+ # Give up. Defined but false.
+ return ($_ = 0);
+ }
+ }
+
+ our %LOCAL_GUESSING =
+ (
+ 'us' => [qw(www.ACME.gov www.ACME.mil)],
+ 'gb' => [qw(www.ACME.co.uk www.ACME.org.uk www.ACME.ac.uk)],
+ 'au' => [qw(www.ACME.com.au www.ACME.org.au www.ACME.edu.au)],
+ 'il' => [qw(www.ACME.co.il www.ACME.org.il www.ACME.net.il)],
+ # send corrections and new entries to <gisle@aas.no>
+ );
+ # Backwards compatibility; uk != United Kingdom in ISO 3166
+ $LOCAL_GUESSING{uk} = $LOCAL_GUESSING{gb};
+
+
+ sub uf_uristr ($)
+ {
+ local($_) = @_;
+ print STDERR "uf_uristr: resolving $_\n" if $DEBUG;
+ return unless defined;
+
+ s/^\s+//;
+ s/\s+$//;
+
+ if (/^(www|web|home)[a-z0-9-]*(?:\.|$)/i) {
+ $_ = "http://$_";
+
+ } elsif (/^(ftp|gopher|news|wais|https|http)[a-z0-9-]*(?:\.|$)/i) {
+ $_ = lc($1) . "://$_";
+
+ } elsif ($^O ne "MacOS" &&
+ (m,^/, || # absolute file name
+ m,^\.\.?/, || # relative file name
+ m,^[a-zA-Z]:[/\\],) # dosish file name
+ )
+ {
+ $_ = "file:$_";
+
+ } elsif ($^O eq "MacOS" && m/:/) {
+ # potential MacOS file name
+ unless (m/^(ftp|gopher|news|wais|http|https|mailto):/) {
+ require URI::file;
+ my $a = URI::file->new($_)->as_string;
+ $_ = ($a =~ m/^file:/) ? $a : "file:$a";
+ }
+ } elsif (/^\w+([\.\-]\w+)*\@(\w+\.)+\w{2,3}$/) {
+ $_ = "mailto:$_";
+
+ } elsif (!/^[a-zA-Z][a-zA-Z0-9.+\-]*:/) { # no scheme specified
+ if (s/^([-\w]+(?:\.[-\w]+)*)([\/:\?\#]|$)/$2/) {
+ my $host = $1;
+
+ my $scheme = "http";
+ if (/^:(\d+)\b/) {
+ # Some more or less well known ports
+ if ($1 =~ /^[56789]?443$/) {
+ $scheme = "https";
+ } elsif ($1 eq "21") {
+ $scheme = "ftp";
+ }
+ }
+
+ if ($host !~ /\./ && $host ne "localhost") {
+ my @guess;
+ if (exists $ENV{URL_GUESS_PATTERN}) {
+ @guess = map { s/\bACME\b/$host/; $_ }
+ split(' ', $ENV{URL_GUESS_PATTERN});
+ } else {
+ if (MY_COUNTRY()) {
+ my $special = $LOCAL_GUESSING{MY_COUNTRY()};
+ if ($special) {
+ my @special = @$special;
+ push(@guess, map { s/\bACME\b/$host/; $_ }
+ @special);
+ } else {
+ push(@guess, "www.$host." . MY_COUNTRY());
+ }
+ }
+ push(@guess, map "www.$host.$_",
+ "com", "org", "net", "edu", "int");
+ }
- *Types::Serialiser::Boolean:: = *JSON::PP::Boolean::;
+
+ my $guess;
+ for $guess (@guess) {
+ print STDERR "uf_uristr: gethostbyname('$guess.')..."
+ if $DEBUG;
+ if (gethostbyname("$guess.")) {
+ print STDERR "yes\n" if $DEBUG;
+ $host = $guess;
+ last;
+ }
+ print STDERR "no\n" if $DEBUG;
+ }
+ }
+ $_ = "$scheme://$host$_";
+
+ } else {
+ # pure junk, just return it unchanged...
+
+ }
+ }
+ print STDERR "uf_uristr: ==> $_\n" if $DEBUG;
+
+ $_;
}
+ sub uf_uri ($)
{
- # this must done before blessing to work around bugs
- # in perl < 5.18 (it seems to be fixed in 5.18).
- package Types::Serialiser::BooleanBase;
+ require URI;
+ URI->new(uf_uristr($_[0]));
+ }
- use overload
- "0+" => sub { ${$_[0]} },
- "++" => sub { $_[0] = ${$_[0]} + 1 },
- "--" => sub { $_[0] = ${$_[0]} - 1 },
- fallback => 1;
+ # legacy
+ *uf_urlstr = \*uf_uristr;
- @Types::Serialiser::Boolean::ISA = Types::Serialiser::BooleanBase::;
+ sub uf_url ($)
+ {
+ require URI::URL;
+ URI::URL->new(uf_uristr($_[0]));
}
- our $true = do { bless \(my $dummy = 1), Types::Serialiser::Boolean:: };
- our $false = do { bless \(my $dummy = 0), Types::Serialiser::Boolean:: };
- our $error = do { bless \(my $dummy ), Types::Serialiser::Error:: };
+ 1;
+URI_HEURISTIC
+
+$fatpacked{"URI/IRI.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_IRI';
+ package URI::IRI;
- sub true () { $true }
- sub false () { $false }
- sub error () { $error }
+ # Experimental
- sub is_bool ($) { UNIVERSAL::isa $_[0], Types::Serialiser::Boolean:: }
- sub is_true ($) { $_[0] && UNIVERSAL::isa $_[0], Types::Serialiser::Boolean:: }
- sub is_false ($) { !$_[0] && UNIVERSAL::isa $_[0], Types::Serialiser::Boolean:: }
- sub is_error ($) { UNIVERSAL::isa $_[0], Types::Serialiser::Error:: }
+ use strict;
+ use warnings;
+ use URI ();
- package Types::Serialiser::Error;
+ use overload '""' => sub { shift->as_string };
- sub error {
- require Carp;
- Carp::croak ("caught attempt to use the Types::Serialiser::error value");
- };
+ our $VERSION = '1.76';
- use overload
- "0+" => \&error,
- "++" => \&error,
- "--" => \&error,
- fallback => 1;
+ sub new {
+ my($class, $uri, $scheme) = @_;
+ utf8::upgrade($uri);
+ return bless {
+ uri => URI->new($uri, $scheme),
+ }, $class;
+ }
+
+ sub clone {
+ my $self = shift;
+ return bless {
+ uri => $self->{uri}->clone,
+ }, ref($self);
+ }
+
+ sub as_string {
+ my $self = shift;
+ return $self->{uri}->as_iri;
+ }
+
+ our $AUTOLOAD;
+ sub AUTOLOAD
+ {
+ my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
+
+ # We create the function here so that it will not need to be
+ # autoloaded the next time.
+ no strict 'refs';
+ *$method = sub { shift->{uri}->$method(@_) };
+ goto &$method;
+ }
+
+ sub DESTROY {} # avoid AUTOLOADing it
+
+ 1;
+URI_IRI
+
+$fatpacked{"URI/QueryParam.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_QUERYPARAM';
+ package URI::QueryParam;
- =head1 NOTES FOR XS USERS
+ use strict;
+ use warnings;
- The recommended way to detect whether a scalar is one of these objects
- is to check whether the stash is the C<Types::Serialiser::Boolean> or
- C<Types::Serialiser::Error> stash, and then follow the scalar reference to
- see if it's C<1> (true), C<0> (false) or C<undef> (error).
+ our $VERSION = '1.76';
- While it is possible to use an isa test, directly comparing stash pointers
- is faster and guaranteed to work.
+ sub URI::_query::query_param {
+ my $self = shift;
+ my @old = $self->query_form;
- For historical reasons, the C<Types::Serialiser::Boolean> stash is
- just an alias for C<JSON::PP::Boolean>. When printed, the classname
- with usually be C<JSON::PP::Boolean>, but isa tests and stash pointer
- comparison will normally work correctly (i.e. Types::Serialiser::true ISA
- JSON::PP::Boolean, but also ISA Types::Serialiser::Boolean).
+ if (@_ == 0) {
+ # get keys
+ my (%seen, $i);
+ return grep !($i++ % 2 || $seen{$_}++), @old;
+ }
- =head1 A GENERIC OBJECT SERIALIATION PROTOCOL
+ my $key = shift;
+ my @i = grep $_ % 2 == 0 && $old[$_] eq $key, 0 .. $#old;
- This section explains the object serialisation protocol used by
- L<CBOR::XS>. It is meant to be generic enough to support any kind of
- generic object serialiser.
+ if (@_) {
+ my @new = @old;
+ my @new_i = @i;
+ my @vals = map { ref($_) eq 'ARRAY' ? @$_ : $_ } @_;
- This protocol is called "the Types::Serialiser object serialisation
- protocol".
+ while (@new_i > @vals) {
+ splice @new, pop @new_i, 2;
+ }
+ if (@vals > @new_i) {
+ my $i = @new_i ? $new_i[-1] + 2 : @new;
+ my @splice = splice @vals, @new_i, @vals - @new_i;
- =head2 ENCODING
+ splice @new, $i, 0, map { $key => $_ } @splice;
+ }
+ if (@vals) {
+ #print "SET $new_i[0]\n";
+ @new[ map $_ + 1, @new_i ] = @vals;
+ }
- When the encoder encounters an object that it cannot otherwise encode (for
- example, L<CBOR::XS> can encode a few special types itself, and will first
- attempt to use the special C<TO_CBOR> serialisation protocol), it will
- look up the C<FREEZE> method on the object.
+ $self->query_form(\@new);
+ }
- Note that the C<FREEZE> method will normally be called I<during> encoding,
- and I<MUST NOT> change the data structure that is being encoded in any
- way, or it might cause memory corruption or worse.
+ return wantarray ? @old[map $_+1, @i] : @i ? $old[$i[0]+1] : undef;
+ }
- If it exists, it will call it with two arguments: the object to serialise,
- and a constant string that indicates the name of the data model. For
- example L<CBOR::XS> uses C<CBOR>, and the L<JSON> and L<JSON::XS> modules
- (or any other JSON serialiser), would use C<JSON> as second argument.
+ sub URI::_query::query_param_append {
+ my $self = shift;
+ my $key = shift;
+ my @vals = map { ref $_ eq 'ARRAY' ? @$_ : $_ } @_;
+ $self->query_form($self->query_form, $key => \@vals); # XXX
+ return;
+ }
- The C<FREEZE> method can then return zero or more values to identify the
- object instance. The serialiser is then supposed to encode the class name
- and all of these return values (which must be encodable in the format)
- using the relevant form for Perl objects. In CBOR for example, there is a
- registered tag number for encoded perl objects.
+ sub URI::_query::query_param_delete {
+ my $self = shift;
+ my $key = shift;
+ my @old = $self->query_form;
+ my @vals;
- The values that C<FREEZE> returns must be serialisable with the serialiser
- that calls it. Therefore, it is recommended to use simple types such as
- strings and numbers, and maybe array references and hashes (basically, the
- JSON data model). You can always use a more complex format for a specific
- data model by checking the second argument, the data model.
+ for (my $i = @old - 2; $i >= 0; $i -= 2) {
+ next if $old[$i] ne $key;
+ push(@vals, (splice(@old, $i, 2))[1]);
+ }
+ $self->query_form(\@old) if @vals;
+ return wantarray ? reverse @vals : $vals[-1];
+ }
- The "data model" is not the same as the "data format" - the data model
- indicates what types and kinds of return values can be returned from
- C<FREEZE>. For example, in C<CBOR> it is permissible to return tagged CBOR
- values, while JSON does not support these at all, so C<JSON> would be a
- valid (but too limited) data model name for C<CBOR::XS>. similarly, a
- serialising format that supports more or less the same data model as JSON
- could use C<JSON> as data model without losing anything.
+ sub URI::_query::query_form_hash {
+ my $self = shift;
+ my @old = $self->query_form;
+ if (@_) {
+ $self->query_form(@_ == 1 ? %{shift(@_)} : @_);
+ }
+ my %hash;
+ while (my($k, $v) = splice(@old, 0, 2)) {
+ if (exists $hash{$k}) {
+ for ($hash{$k}) {
+ $_ = [$_] unless ref($_) eq "ARRAY";
+ push(@$_, $v);
+ }
+ }
+ else {
+ $hash{$k} = $v;
+ }
+ }
+ return \%hash;
+ }
- =head2 DECODING
+ 1;
- When the decoder then encounters such an encoded perl object, it should
- look up the C<THAW> method on the stored classname, and invoke it with the
- classname, the constant string to identify the data model/data format, and
- all the return values returned by C<FREEZE>.
+ __END__
- =head2 EXAMPLES
+ =head1 NAME
- See the C<OBJECT SERIALISATION> section in the L<CBOR::XS> manpage for
- more details, an example implementation, and code examples.
+ URI::QueryParam - Additional query methods for URIs
- Here is an example C<FREEZE>/C<THAW> method pair:
+ =head1 SYNOPSIS
- sub My::Object::FREEZE {
- my ($self, $model) = @_;
+ use URI;
+ use URI::QueryParam;
- ($self->{type}, $self->{id}, $self->{variant})
- }
+ $u = URI->new("", "http");
+ $u->query_param(foo => 1, 2, 3);
+ print $u->query; # prints foo=1&foo=2&foo=3
- sub My::Object::THAW {
- my ($class, $model, $type, $id, $variant) = @_;
+ for my $key ($u->query_param) {
+ print "$key: ", join(", ", $u->query_param($key)), "\n";
+ }
- $class->new (type => $type, id => $id, variant => $variant)
- }
+ =head1 DESCRIPTION
- =head1 BUGS
+ Loading the C<URI::QueryParam> module adds some extra methods to
+ URIs that support query methods. These methods provide an alternative
+ interface to the $u->query_form data.
- The use of L<overload> makes this module much heavier than it should be
- (on my system, this module: 4kB RSS, overload: 260kB RSS).
+ The query_param_* methods have deliberately been made identical to the
+ interface of the corresponding C<CGI.pm> methods.
+
+ The following additional methods are made available:
+
+ =over
+
+ =item @keys = $u->query_param
+
+ =item @values = $u->query_param( $key )
+
+ =item $first_value = $u->query_param( $key )
+
+ =item $u->query_param( $key, $value,... )
+
+ If $u->query_param is called with no arguments, it returns all the
+ distinct parameter keys of the URI. In a scalar context it returns the
+ number of distinct keys.
+
+ When a $key argument is given, the method returns the parameter values with the
+ given key. In a scalar context, only the first parameter value is
+ returned.
+
+ If additional arguments are given, they are used to update successive
+ parameters with the given key. If any of the values provided are
+ array references, then the array is dereferenced to get the actual
+ values.
+
+ Please note that you can supply multiple values to this method, but you cannot
+ supply multiple keys.
+
+ Do this:
+
+ $uri->query_param( widget_id => 1, 5, 9 );
+
+ Do NOT do this:
+
+ $uri->query_param( widget_id => 1, frobnicator_id => 99 );
+
+ =item $u->query_param_append($key, $value,...)
+
+ Adds new parameters with the given
+ key without touching any old parameters with the same key. It
+ can be explained as a more efficient version of:
+
+ $u->query_param($key,
+ $u->query_param($key),
+ $value,...);
+
+ One difference is that this expression would return the old values
+ of $key, whereas the query_param_append() method does not.
+
+ =item @values = $u->query_param_delete($key)
+
+ =item $first_value = $u->query_param_delete($key)
+
+ Deletes all key/value pairs with the given key.
+ The old values are returned. In a scalar context, only the first value
+ is returned.
+
+ Using the query_param_delete() method is slightly more efficient than
+ the equivalent:
+
+ $u->query_param($key, []);
+
+ =item $hashref = $u->query_form_hash
+
+ =item $u->query_form_hash( \%new_form )
+
+ Returns a reference to a hash that represents the
+ query form's key/value pairs. If a key occurs multiple times, then the hash
+ value becomes an array reference.
+
+ Note that sequence information is lost. This means that:
+
+ $u->query_form_hash($u->query_form_hash);
+
+ is not necessarily a no-op, as it may reorder the key/value pairs.
+ The values returned by the query_param() method should stay the same
+ though.
+
+ =back
=head1 SEE ALSO
- Currently, L<JSON::XS> and L<CBOR::XS> use these types.
+ L<URI>, L<CGI>
- =head1 AUTHOR
+ =head1 COPYRIGHT
+
+ Copyright 2002 Gisle Aas.
+
+ =cut
+URI_QUERYPARAM
+
+$fatpacked{"URI/Split.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_SPLIT';
+ package URI::Split;
+
+ use strict;
+ use warnings;
+
+ our $VERSION = '1.76';
+
+ use Exporter 5.57 'import';
+ our @EXPORT_OK = qw(uri_split uri_join);
+
+ use URI::Escape ();
+
+ sub uri_split {
+ return $_[0] =~ m,(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?,;
+ }
+
+ sub uri_join {
+ my($scheme, $auth, $path, $query, $frag) = @_;
+ my $uri = defined($scheme) ? "$scheme:" : "";
+ $path = "" unless defined $path;
+ if (defined $auth) {
+ $auth =~ s,([/?\#]), URI::Escape::escape_char($1),eg;
+ $uri .= "//$auth";
+ $path = "/$path" if length($path) && $path !~ m,^/,;
+ }
+ elsif ($path =~ m,^//,) {
+ $uri .= "//"; # XXX force empty auth
+ }
+ unless (length $uri) {
+ $path =~ s,(:), URI::Escape::escape_char($1),e while $path =~ m,^[^:/?\#]+:,;
+ }
+ $path =~ s,([?\#]), URI::Escape::escape_char($1),eg;
+ $uri .= $path;
+ if (defined $query) {
+ $query =~ s,(\#), URI::Escape::escape_char($1),eg;
+ $uri .= "?$query";
+ }
+ $uri .= "#$frag" if defined $frag;
+ $uri;
+ }
+
+ 1;
+
+ __END__
+
+ =head1 NAME
+
+ URI::Split - Parse and compose URI strings
+
+ =head1 SYNOPSIS
+
+ use URI::Split qw(uri_split uri_join);
+ ($scheme, $auth, $path, $query, $frag) = uri_split($uri);
+ $uri = uri_join($scheme, $auth, $path, $query, $frag);
+
+ =head1 DESCRIPTION
+
+ Provides functions to parse and compose URI
+ strings. The following functions are provided:
+
+ =over
+
+ =item ($scheme, $auth, $path, $query, $frag) = uri_split($uri)
+
+ Breaks up a URI string into its component
+ parts. An C<undef> value is returned for those parts that are not
+ present. The $path part is always present (but can be the empty
+ string) and is thus never returned as C<undef>.
+
+ No sensible value is returned if this function is called in a scalar
+ context.
+
+ =item $uri = uri_join($scheme, $auth, $path, $query, $frag)
+
+ Puts together a URI string from its parts.
+ Missing parts are signaled by passing C<undef> for the corresponding
+ argument.
+
+ Minimal escaping is applied to parts that contain reserved chars
+ that would confuse a parser. For instance, any occurrence of '?' or '#'
+ in $path is always escaped, as it would otherwise be parsed back
+ as a query or fragment.
+
+ =back
+
+ =head1 SEE ALSO
+
+ L<URI>, L<URI::Escape>
+
+ =head1 COPYRIGHT
+
+ Copyright 2003, Gisle Aas
- Marc Lehmann <schmorp@schmorp.de>
- http://home.schmorp.de/
+ This library is free software; you can redistribute it and/or
+ modify it under the same terms as Perl itself.
=cut
+URI_SPLIT
+
+$fatpacked{"URI/URL.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_URL';
+ package URI::URL;
+
+ use strict;
+ use warnings;
+
+ use parent 'URI::WithBase';
+
+ our $VERSION = "5.04";
+
+ # Provide as much as possible of the old URI::URL interface for backwards
+ # compatibility...
+
+ use Exporter 5.57 'import';
+ our @EXPORT = qw(url);
+
+ # Easy to use constructor
+ sub url ($;$) { URI::URL->new(@_); }
+
+ use URI::Escape qw(uri_unescape);
+
+ sub new
+ {
+ my $class = shift;
+ my $self = $class->SUPER::new(@_);
+ $self->[0] = $self->[0]->canonical;
+ $self;
+ }
+
+ sub newlocal
+ {
+ my $class = shift;
+ require URI::file;
+ bless [URI::file->new_abs(shift)], $class;
+ }
+
+ {package URI::_foreign;
+ sub _init # hope it is not defined
+ {
+ my $class = shift;
+ die "Unknown URI::URL scheme $_[1]:" if $URI::URL::STRICT;
+ $class->SUPER::_init(@_);
+ }
+ }
+
+ sub strict
+ {
+ my $old = $URI::URL::STRICT;
+ $URI::URL::STRICT = shift if @_;
+ $old;
+ }
- 1
+ sub print_on
+ {
+ my $self = shift;
+ require Data::Dumper;
+ print STDERR Data::Dumper::Dumper($self);
+ }
+
+ sub _try
+ {
+ my $self = shift;
+ my $method = shift;
+ scalar(eval { $self->$method(@_) });
+ }
+
+ sub crack
+ {
+ # should be overridden by subclasses
+ my $self = shift;
+ (scalar($self->scheme),
+ $self->_try("user"),
+ $self->_try("password"),
+ $self->_try("host"),
+ $self->_try("port"),
+ $self->_try("path"),
+ $self->_try("params"),
+ $self->_try("query"),
+ scalar($self->fragment),
+ )
+ }
+
+ sub full_path
+ {
+ my $self = shift;
+ my $path = $self->path_query;
+ $path = "/" unless length $path;
+ $path;
+ }
+
+ sub netloc
+ {
+ shift->authority(@_);
+ }
+
+ sub epath
+ {
+ my $path = shift->SUPER::path(@_);
+ $path =~ s/;.*//;
+ $path;
+ }
+
+ sub eparams
+ {
+ my $self = shift;
+ my @p = $self->path_segments;
+ return undef unless ref($p[-1]);
+ @p = @{$p[-1]};
+ shift @p;
+ join(";", @p);
+ }
+
+ sub params { shift->eparams(@_); }
+
+ sub path {
+ my $self = shift;
+ my $old = $self->epath(@_);
+ return unless defined wantarray;
+ return '/' if !defined($old) || !length($old);
+ Carp::croak("Path components contain '/' (you must call epath)")
+ if $old =~ /%2[fF]/ and !@_;
+ $old = "/$old" if $old !~ m|^/| && defined $self->netloc;
+ return uri_unescape($old);
+ }
+
+ sub path_components {
+ shift->path_segments(@_);
+ }
+
+ sub query {
+ my $self = shift;
+ my $old = $self->equery(@_);
+ if (defined(wantarray) && defined($old)) {
+ if ($old =~ /%(?:26|2[bB]|3[dD])/) { # contains escaped '=' '&' or '+'
+ my $mess;
+ for ($old) {
+ $mess = "Query contains both '+' and '%2B'"
+ if /\+/ && /%2[bB]/;
+ $mess = "Form query contains escaped '=' or '&'"
+ if /=/ && /%(?:3[dD]|26)/;
+ }
+ if ($mess) {
+ Carp::croak("$mess (you must call equery)");
+ }
+ }
+ # Now it should be safe to unescape the string without losing
+ # information
+ return uri_unescape($old);
+ }
+ undef;
+
+ }
+
+ sub abs
+ {
+ my $self = shift;
+ my $base = shift;
+ my $allow_scheme = shift;
+ $allow_scheme = $URI::URL::ABS_ALLOW_RELATIVE_SCHEME
+ unless defined $allow_scheme;
+ local $URI::ABS_ALLOW_RELATIVE_SCHEME = $allow_scheme;
+ local $URI::ABS_REMOTE_LEADING_DOTS = $URI::URL::ABS_REMOTE_LEADING_DOTS;
+ $self->SUPER::abs($base);
+ }
+
+ sub frag { shift->fragment(@_); }
+ sub keywords { shift->query_keywords(@_); }
+
+ # file:
+ sub local_path { shift->file; }
+ sub unix_path { shift->file("unix"); }
+ sub dos_path { shift->file("dos"); }
+ sub mac_path { shift->file("mac"); }
+ sub vms_path { shift->file("vms"); }
+
+ # mailto:
+ sub address { shift->to(@_); }
+ sub encoded822addr { shift->to(@_); }
+ sub URI::mailto::authority { shift->to(@_); } # make 'netloc' method work
+
+ # news:
+ sub groupart { shift->_group(@_); }
+ sub article { shift->message(@_); }
+
+ 1;
+
+ __END__
-TYPES_SERIALISER
+ =head1 NAME
+
+ URI::URL - Uniform Resource Locators
+
+ =head1 SYNOPSIS
+
+ $u1 = URI::URL->new($str, $base);
+ $u2 = $u1->abs;
+
+ =head1 DESCRIPTION
+
+ This module is provided for backwards compatibility with modules that
+ depend on the interface provided by the C<URI::URL> class that used to
+ be distributed with the libwww-perl library.
+
+ The following differences exist compared to the C<URI> class interface:
+
+ =over 3
+
+ =item *
+
+ The URI::URL module exports the url() function as an alternate
+ constructor interface.
+
+ =item *
+
+ The constructor takes an optional $base argument. The C<URI::URL>
+ class is a subclass of C<URI::WithBase>.
+
+ =item *
+
+ The URI::URL->newlocal class method is the same as URI::file->new_abs.
+
+ =item *
+
+ URI::URL::strict(1)
+
+ =item *
+
+ $url->print_on method
+
+ =item *
+
+ $url->crack method
+
+ =item *
+
+ $url->full_path: same as ($uri->abs_path || "/")
+
+ =item *
+
+ $url->netloc: same as $uri->authority
+
+ =item *
+
+ $url->epath, $url->equery: same as $uri->path, $uri->query
+
+ =item *
+
+ $url->path and $url->query pass unescaped strings.
+
+ =item *
+
+ $url->path_components: same as $uri->path_segments (if you don't
+ consider path segment parameters)
+
+ =item *
+
+ $url->params and $url->eparams methods
+
+ =item *
+
+ $url->base method. See L<URI::WithBase>.
+
+ =item *
+
+ $url->abs and $url->rel have an optional $base argument. See
+ L<URI::WithBase>.
+
+ =item *
+
+ $url->frag: same as $uri->fragment
+
+ =item *
+
+ $url->keywords: same as $uri->query_keywords
+
+ =item *
+
+ $url->localpath and friends map to $uri->file.
+
+ =item *
+
+ $url->address and $url->encoded822addr: same as $uri->to for mailto URI
+
+ =item *
+
+ $url->groupart method for news URI
+
+ =item *
+
+ $url->article: same as $uri->message
+
+ =back
+
+
+
+ =head1 SEE ALSO
+
+ L<URI>, L<URI::WithBase>
+
+ =head1 COPYRIGHT
+
+ Copyright 1998-2000 Gisle Aas.
+
+ =cut
+URI_URL
-$fatpacked{"Types/Serialiser/Error.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'TYPES_SERIALISER_ERROR';
+$fatpacked{"URI/WithBase.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_WITHBASE';
+ package URI::WithBase;
+
+ use strict;
+ use warnings;
+
+ use URI;
+ use Scalar::Util 'blessed';
+
+ our $VERSION = "2.20";
+
+ use overload '""' => "as_string", fallback => 1;
+
+ sub as_string; # help overload find it
+
+ sub new
+ {
+ my($class, $uri, $base) = @_;
+ my $ibase = $base;
+ if ($base && blessed($base) && $base->isa(__PACKAGE__)) {
+ $base = $base->abs;
+ $ibase = $base->[0];
+ }
+ bless [URI->new($uri, $ibase), $base], $class;
+ }
+
+ sub new_abs
+ {
+ my $class = shift;
+ my $self = $class->new(@_);
+ $self->abs;
+ }
+
+ sub _init
+ {
+ my $class = shift;
+ my($str, $scheme) = @_;
+ bless [URI->new($str, $scheme), undef], $class;
+ }
+
+ sub eq
+ {
+ my($self, $other) = @_;
+ $other = $other->[0] if blessed($other) and $other->isa(__PACKAGE__);
+ $self->[0]->eq($other);
+ }
+
+ our $AUTOLOAD;
+ sub AUTOLOAD
+ {
+ my $self = shift;
+ my $method = substr($AUTOLOAD, rindex($AUTOLOAD, '::')+2);
+ return if $method eq "DESTROY";
+ $self->[0]->$method(@_);
+ }
+
+ sub can { # override UNIVERSAL::can
+ my $self = shift;
+ $self->SUPER::can(@_) || (
+ ref($self)
+ ? $self->[0]->can(@_)
+ : undef
+ )
+ }
+
+ sub base {
+ my $self = shift;
+ my $base = $self->[1];
+
+ if (@_) { # set
+ my $new_base = shift;
+ # ensure absoluteness
+ $new_base = $new_base->abs if ref($new_base) && $new_base->isa(__PACKAGE__);
+ $self->[1] = $new_base;
+ }
+ return unless defined wantarray;
+
+ # The base attribute supports 'lazy' conversion from URL strings
+ # to URL objects. Strings may be stored but when a string is
+ # fetched it will automatically be converted to a URL object.
+ # The main benefit is to make it much cheaper to say:
+ # URI::WithBase->new($random_url_string, 'http:')
+ if (defined($base) && !ref($base)) {
+ $base = ref($self)->new($base);
+ $self->[1] = $base unless @_;
+ }
+ $base;
+ }
+
+ sub clone
+ {
+ my $self = shift;
+ my $base = $self->[1];
+ $base = $base->clone if ref($base);
+ bless [$self->[0]->clone, $base], ref($self);
+ }
+
+ sub abs
+ {
+ my $self = shift;
+ my $base = shift || $self->base || return $self->clone;
+ $base = $base->as_string if ref($base);
+ bless [$self->[0]->abs($base, @_), $base], ref($self);
+ }
+
+ sub rel
+ {
+ my $self = shift;
+ my $base = shift || $self->base || return $self->clone;
+ $base = $base->as_string if ref($base);
+ bless [$self->[0]->rel($base, @_), $base], ref($self);
+ }
+
+ 1;
+
+ __END__
+
=head1 NAME
- Types::Serialiser::Error - dummy module for Types::Serialiser
+ URI::WithBase - URIs which remember their base
=head1 SYNOPSIS
- # do not "use" yourself
+ $u1 = URI::WithBase->new($str, $base);
+ $u2 = $u1->abs;
+
+ $base = $u1->base;
+ $u1->base( $new_base )
=head1 DESCRIPTION
- This module exists only to provide overload resolution for Storable and
- similar modules that assume that class name equals module name. See
- L<Types::Serialiser> for more info about this class.
+ This module provides the C<URI::WithBase> class. Objects of this class
+ are like C<URI> objects, but can keep their base too. The base
+ represents the context where this URI was found and can be used to
+ absolutize or relativize the URI. All the methods described in L<URI>
+ are supported for C<URI::WithBase> objects.
+
+ The methods provided in addition to or modified from those of C<URI> are:
+
+ =over 4
+
+ =item $uri = URI::WithBase->new($str, [$base])
+
+ The constructor takes an optional base URI as the second argument.
+ If provided, this argument initializes the base attribute.
+
+ =item $uri->base( [$new_base] )
+
+ Can be used to get or set the value of the base attribute.
+ The return value, which is the old value, is a URI object or C<undef>.
+
+ =item $uri->abs( [$base_uri] )
+
+ The $base_uri argument is now made optional as the object carries its
+ base with it. A new object is returned even if $uri is already
+ absolute (while plain URI objects simply return themselves in
+ that case).
+
+ =item $uri->rel( [$base_uri] )
+
+ The $base_uri argument is now made optional as the object carries its
+ base with it. A new object is always returned.
+
+ =back
+
+
+ =head1 SEE ALSO
+
+ L<URI>
+
+ =head1 COPYRIGHT
+
+ Copyright 1998-2002 Gisle Aas.
=cut
+URI_WITHBASE
+
+$fatpacked{"URI/_foreign.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI__FOREIGN';
+ package URI::_foreign;
+
+ use strict;
+ use warnings;
+
+ use parent 'URI::_generic';
+
+ our $VERSION = '1.76';
+
+ 1;
+URI__FOREIGN
+
+$fatpacked{"URI/_generic.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI__GENERIC';
+ package URI::_generic;
+
+ use strict;
+ use warnings;
+
+ use parent qw(URI URI::_query);
+
+ use URI::Escape qw(uri_unescape);
+ use Carp ();
+
+ our $VERSION = '1.76';
+
+ my $ACHAR = $URI::uric; $ACHAR =~ s,\\[/?],,g;
+ my $PCHAR = $URI::uric; $PCHAR =~ s,\\[?],,g;
+
+ sub _no_scheme_ok { 1 }
+
+ sub authority
+ {
+ my $self = shift;
+ $$self =~ m,^((?:$URI::scheme_re:)?)(?://([^/?\#]*))?(.*)$,os or die;
+
+ if (@_) {
+ my $auth = shift;
+ $$self = $1;
+ my $rest = $3;
+ if (defined $auth) {
+ $auth =~ s/([^$ACHAR])/ URI::Escape::escape_char($1)/ego;
+ utf8::downgrade($auth);
+ $$self .= "//$auth";
+ }
+ _check_path($rest, $$self);
+ $$self .= $rest;
+ }
+ $2;
+ }
+
+ sub path
+ {
+ my $self = shift;
+ $$self =~ m,^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)([^?\#]*)(.*)$,s or die;
+
+ if (@_) {
+ $$self = $1;
+ my $rest = $3;
+ my $new_path = shift;
+ $new_path = "" unless defined $new_path;
+ $new_path =~ s/([^$PCHAR])/ URI::Escape::escape_char($1)/ego;
+ utf8::downgrade($new_path);
+ _check_path($new_path, $$self);
+ $$self .= $new_path . $rest;
+ }
+ $2;
+ }
+
+ sub path_query
+ {
+ my $self = shift;
+ $$self =~ m,^((?:[^:/?\#]+:)?(?://[^/?\#]*)?)([^\#]*)(.*)$,s or die;
+
+ if (@_) {
+ $$self = $1;
+ my $rest = $3;
+ my $new_path = shift;
+ $new_path = "" unless defined $new_path;
+ $new_path =~ s/([^$URI::uric])/ URI::Escape::escape_char($1)/ego;
+ utf8::downgrade($new_path);
+ _check_path($new_path, $$self);
+ $$self .= $new_path . $rest;
+ }
+ $2;
+ }
+
+ sub _check_path
+ {
+ my($path, $pre) = @_;
+ my $prefix;
+ if ($pre =~ m,/,) { # authority present
+ $prefix = "/" if length($path) && $path !~ m,^[/?\#],;
+ }
+ else {
+ if ($path =~ m,^//,) {
+ Carp::carp("Path starting with double slash is confusing")
+ if $^W;
+ }
+ elsif (!length($pre) && $path =~ m,^[^:/?\#]+:,) {
+ Carp::carp("Path might look like scheme, './' prepended")
+ if $^W;
+ $prefix = "./";
+ }
+ }
+ substr($_[0], 0, 0) = $prefix if defined $prefix;
+ }
+
+ sub path_segments
+ {
+ my $self = shift;
+ my $path = $self->path;
+ if (@_) {
+ my @arg = @_; # make a copy
+ for (@arg) {
+ if (ref($_)) {
+ my @seg = @$_;
+ $seg[0] =~ s/%/%25/g;
+ for (@seg) { s/;/%3B/g; }
+ $_ = join(";", @seg);
+ }
+ else {
+ s/%/%25/g; s/;/%3B/g;
+ }
+ s,/,%2F,g;
+ }
+ $self->path(join("/", @arg));
+ }
+ return $path unless wantarray;
+ map {/;/ ? $self->_split_segment($_)
+ : uri_unescape($_) }
+ split('/', $path, -1);
+ }
+
+
+ sub _split_segment
+ {
+ my $self = shift;
+ require URI::_segment;
+ URI::_segment->new(@_);
+ }
+
+
+ sub abs
+ {
+ my $self = shift;
+ my $base = shift || Carp::croak("Missing base argument");
+
+ if (my $scheme = $self->scheme) {
+ return $self unless $URI::ABS_ALLOW_RELATIVE_SCHEME;
+ $base = URI->new($base) unless ref $base;
+ return $self unless $scheme eq $base->scheme;
+ }
+
+ $base = URI->new($base) unless ref $base;
+ my $abs = $self->clone;
+ $abs->scheme($base->scheme);
+ return $abs if $$self =~ m,^(?:$URI::scheme_re:)?//,o;
+ $abs->authority($base->authority);
+
+ my $path = $self->path;
+ return $abs if $path =~ m,^/,;
+
+ if (!length($path)) {
+ my $abs = $base->clone;
+ my $query = $self->query;
+ $abs->query($query) if defined $query;
+ my $fragment = $self->fragment;
+ $abs->fragment($fragment) if defined $fragment;
+ return $abs;
+ }
+
+ my $p = $base->path;
+ $p =~ s,[^/]+$,,;
+ $p .= $path;
+ my @p = split('/', $p, -1);
+ shift(@p) if @p && !length($p[0]);
+ my $i = 1;
+ while ($i < @p) {
+ #print "$i ", join("/", @p), " ($p[$i])\n";
+ if ($p[$i-1] eq ".") {
+ splice(@p, $i-1, 1);
+ $i-- if $i > 1;
+ }
+ elsif ($p[$i] eq ".." && $p[$i-1] ne "..") {
+ splice(@p, $i-1, 2);
+ if ($i > 1) {
+ $i--;
+ push(@p, "") if $i == @p;
+ }
+ }
+ else {
+ $i++;
+ }
+ }
+ $p[-1] = "" if @p && $p[-1] eq "."; # trailing "/."
+ if ($URI::ABS_REMOTE_LEADING_DOTS) {
+ shift @p while @p && $p[0] =~ /^\.\.?$/;
+ }
+ $abs->path("/" . join("/", @p));
+ $abs;
+ }
+
+ # The opposite of $url->abs. Return a URI which is as relative as possible
+ sub rel {
+ my $self = shift;
+ my $base = shift || Carp::croak("Missing base argument");
+ my $rel = $self->clone;
+ $base = URI->new($base) unless ref $base;
+
+ #my($scheme, $auth, $path) = @{$rel}{qw(scheme authority path)};
+ my $scheme = $rel->scheme;
+ my $auth = $rel->canonical->authority;
+ my $path = $rel->path;
+
+ if (!defined($scheme) && !defined($auth)) {
+ # it is already relative
+ return $rel;
+ }
+
+ #my($bscheme, $bauth, $bpath) = @{$base}{qw(scheme authority path)};
+ my $bscheme = $base->scheme;
+ my $bauth = $base->canonical->authority;
+ my $bpath = $base->path;
+
+ for ($bscheme, $bauth, $auth) {
+ $_ = '' unless defined
+ }
+
+ unless ($scheme eq $bscheme && $auth eq $bauth) {
+ # different location, can't make it relative
+ return $rel;
+ }
+
+ for ($path, $bpath) { $_ = "/$_" unless m,^/,; }
+
+ # Make it relative by eliminating scheme and authority
+ $rel->scheme(undef);
+ $rel->authority(undef);
+
+ # This loop is based on code from Nicolai Langfeldt <janl@ifi.uio.no>.
+ # First we calculate common initial path components length ($li).
+ my $li = 1;
+ while (1) {
+ my $i = index($path, '/', $li);
+ last if $i < 0 ||
+ $i != index($bpath, '/', $li) ||
+ substr($path,$li,$i-$li) ne substr($bpath,$li,$i-$li);
+ $li=$i+1;
+ }
+ # then we nuke it from both paths
+ substr($path, 0,$li) = '';
+ substr($bpath,0,$li) = '';
+
+ if ($path eq $bpath &&
+ defined($rel->fragment) &&
+ !defined($rel->query)) {
+ $rel->path("");
+ }
+ else {
+ # Add one "../" for each path component left in the base path
+ $path = ('../' x $bpath =~ tr|/|/|) . $path;
+ $path = "./" if $path eq "";
+ $rel->path($path);
+ }
+
+ $rel;
+ }
+
+ 1;
+URI__GENERIC
+
+$fatpacked{"URI/_idna.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI__IDNA';
+ package URI::_idna;
+
+ # This module implements the RFCs 3490 (IDNA) and 3491 (Nameprep)
+ # based on Python-2.6.4/Lib/encodings/idna.py
+
+ use strict;
+ use warnings;
+
+ use URI::_punycode qw(encode_punycode decode_punycode);
+ use Carp qw(croak);
+
+ our $VERSION = '1.76';
+
+ BEGIN {
+ *URI::_idna::_ENV_::JOIN_LEAKS_UTF8_FLAGS = "$]" < 5.008_003
+ ? sub () { 1 }
+ : sub () { 0 }
+ ;
+ }
+
+ my $ASCII = qr/^[\x00-\x7F]*\z/;
+
+ sub encode {
+ my $idomain = shift;
+ my @labels = split(/\./, $idomain, -1);
+ my @last_empty;
+ push(@last_empty, pop @labels) if @labels > 1 && $labels[-1] eq "";
+ for (@labels) {
+ $_ = ToASCII($_);
+ }
- use Types::Serialiser ();
+ return eval 'join(".", @labels, @last_empty)' if URI::_idna::_ENV_::JOIN_LEAKS_UTF8_FLAGS;
+ return join(".", @labels, @last_empty);
+ }
+
+ sub decode {
+ my $domain = shift;
+ return join(".", map ToUnicode($_), split(/\./, $domain, -1))
+ }
+
+ sub nameprep { # XXX real implementation missing
+ my $label = shift;
+ $label = lc($label);
+ return $label;
+ }
+
+ sub check_size {
+ my $label = shift;
+ croak "Label empty" if $label eq "";
+ croak "Label too long" if length($label) > 63;
+ return $label;
+ }
+
+ sub ToASCII {
+ my $label = shift;
+ return check_size($label) if $label =~ $ASCII;
+
+ # Step 2: nameprep
+ $label = nameprep($label);
+ # Step 3: UseSTD3ASCIIRules is false
+ # Step 4: try ASCII again
+ return check_size($label) if $label =~ $ASCII;
+
+ # Step 5: Check ACE prefix
+ if ($label =~ /^xn--/) {
+ croak "Label starts with ACE prefix";
+ }
+
+ # Step 6: Encode with PUNYCODE
+ $label = encode_punycode($label);
+
+ # Step 7: Prepend ACE prefix
+ $label = "xn--$label";
+
+ # Step 8: Check size
+ return check_size($label);
+ }
+
+ sub ToUnicode {
+ my $label = shift;
+ $label = nameprep($label) unless $label =~ $ASCII;
+ return $label unless $label =~ /^xn--/;
+ my $result = decode_punycode(substr($label, 4));
+ my $label2 = ToASCII($result);
+ if (lc($label) ne $label2) {
+ croak "IDNA does not round-trip: '\L$label\E' vs '$label2'";
+ }
+ return $result;
+ }
+
+ 1;
+URI__IDNA
+
+$fatpacked{"URI/_ldap.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI__LDAP';
+ # Copyright (c) 1998 Graham Barr <gbarr@pobox.com>. All rights reserved.
+ # This program is free software; you can redistribute it and/or
+ # modify it under the same terms as Perl itself.
+
+ package URI::_ldap;
+
+ use strict;
+ use warnings;
+
+ our $VERSION = '1.76';
+
+ use URI::Escape qw(uri_unescape);
+
+ sub _ldap_elem {
+ my $self = shift;
+ my $elem = shift;
+ my $query = $self->query;
+ my @bits = (split(/\?/,defined($query) ? $query : ""),("")x4);
+ my $old = $bits[$elem];
+
+ if (@_) {
+ my $new = shift;
+ $new =~ s/\?/%3F/g;
+ $bits[$elem] = $new;
+ $query = join("?",@bits);
+ $query =~ s/\?+$//;
+ $query = undef unless length($query);
+ $self->query($query);
+ }
+
+ $old;
+ }
+
+ sub dn {
+ my $old = shift->path(@_);
+ $old =~ s:^/::;
+ uri_unescape($old);
+ }
+
+ sub attributes {
+ my $self = shift;
+ my $old = _ldap_elem($self,0, @_ ? join(",", map { my $tmp = $_; $tmp =~ s/,/%2C/g; $tmp } @_) : ());
+ return $old unless wantarray;
+ map { uri_unescape($_) } split(/,/,$old);
+ }
+
+ sub _scope {
+ my $self = shift;
+ my $old = _ldap_elem($self,1, @_);
+ return undef unless defined wantarray && defined $old;
+ uri_unescape($old);
+ }
+
+ sub scope {
+ my $old = &_scope;
+ $old = "base" unless length $old;
+ $old;
+ }
+
+ sub _filter {
+ my $self = shift;
+ my $old = _ldap_elem($self,2, @_);
+ return undef unless defined wantarray && defined $old;
+ uri_unescape($old); # || "(objectClass=*)";
+ }
+
+ sub filter {
+ my $old = &_filter;
+ $old = "(objectClass=*)" unless length $old;
+ $old;
+ }
+
+ sub extensions {
+ my $self = shift;
+ my @ext;
+ while (@_) {
+ my $key = shift;
+ my $value = shift;
+ push(@ext, join("=", map { $_="" unless defined; s/,/%2C/g; $_ } $key, $value));
+ }
+ @ext = join(",", @ext) if @ext;
+ my $old = _ldap_elem($self,3, @ext);
+ return $old unless wantarray;
+ map { uri_unescape($_) } map { /^([^=]+)=(.*)$/ } split(/,/,$old);
+ }
+
+ sub canonical
+ {
+ my $self = shift;
+ my $other = $self->_nonldap_canonical;
+
+ # The stuff below is not as efficient as one might hope...
+
+ $other = $other->clone if $other == $self;
+
+ $other->dn(_normalize_dn($other->dn));
+
+ # Should really know about mixed case "postalAddress", etc...
+ $other->attributes(map lc, $other->attributes);
+
+ # Lowercase scope, remove default
+ my $old_scope = $other->scope;
+ my $new_scope = lc($old_scope);
+ $new_scope = "" if $new_scope eq "base";
+ $other->scope($new_scope) if $new_scope ne $old_scope;
+
+ # Remove filter if default
+ my $old_filter = $other->filter;
+ $other->filter("") if lc($old_filter) eq "(objectclass=*)" ||
+ lc($old_filter) eq "objectclass=*";
+
+ # Lowercase extensions types and deal with known extension values
+ my @ext = $other->extensions;
+ for (my $i = 0; $i < @ext; $i += 2) {
+ my $etype = $ext[$i] = lc($ext[$i]);
+ if ($etype =~ /^!?bindname$/) {
+ $ext[$i+1] = _normalize_dn($ext[$i+1]);
+ }
+ }
+ $other->extensions(@ext) if @ext;
+
+ $other;
+ }
+
+ sub _normalize_dn # RFC 2253
+ {
+ my $dn = shift;
+
+ return $dn;
+ # The code below will fail if the "+" or "," is embedding in a quoted
+ # string or simply escaped...
+
+ my @dn = split(/([+,])/, $dn);
+ for (@dn) {
+ s/^([a-zA-Z]+=)/lc($1)/e;
+ }
+ join("", @dn);
+ }
+
+ 1;
+URI__LDAP
+
+$fatpacked{"URI/_login.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI__LOGIN';
+ package URI::_login;
+
+ use strict;
+ use warnings;
+
+ use parent qw(URI::_server URI::_userpass);
+
+ our $VERSION = '1.76';
+
+ # Generic terminal logins. This is used as a base class for 'telnet',
+ # 'tn3270', and 'rlogin' URL schemes.
+
+ 1;
+URI__LOGIN
+
+$fatpacked{"URI/_punycode.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI__PUNYCODE';
+ package URI::_punycode;
+
+ use strict;
+ use warnings;
+
+ our $VERSION = '1.76';
+
+ use Exporter 'import';
+ our @EXPORT = qw(encode_punycode decode_punycode);
+
+ use integer;
+
+ our $DEBUG = 0;
+
+ use constant BASE => 36;
+ use constant TMIN => 1;
+ use constant TMAX => 26;
+ use constant SKEW => 38;
+ use constant DAMP => 700;
+ use constant INITIAL_BIAS => 72;
+ use constant INITIAL_N => 128;
+
+ my $Delimiter = chr 0x2D;
+ my $BasicRE = qr/[\x00-\x7f]/;
+
+ sub _croak { require Carp; Carp::croak(@_); }
+
+ sub digit_value {
+ my $code = shift;
+ return ord($code) - ord("A") if $code =~ /[A-Z]/;
+ return ord($code) - ord("a") if $code =~ /[a-z]/;
+ return ord($code) - ord("0") + 26 if $code =~ /[0-9]/;
+ return;
+ }
+
+ sub code_point {
+ my $digit = shift;
+ return $digit + ord('a') if 0 <= $digit && $digit <= 25;
+ return $digit + ord('0') - 26 if 26 <= $digit && $digit <= 36;
+ die 'NOT COME HERE';
+ }
+
+ sub adapt {
+ my($delta, $numpoints, $firsttime) = @_;
+ $delta = $firsttime ? $delta / DAMP : $delta / 2;
+ $delta += $delta / $numpoints;
+ my $k = 0;
+ while ($delta > ((BASE - TMIN) * TMAX) / 2) {
+ $delta /= BASE - TMIN;
+ $k += BASE;
+ }
+ return $k + (((BASE - TMIN + 1) * $delta) / ($delta + SKEW));
+ }
+
+ sub decode_punycode {
+ my $code = shift;
+
+ my $n = INITIAL_N;
+ my $i = 0;
+ my $bias = INITIAL_BIAS;
+ my @output;
+
+ if ($code =~ s/(.*)$Delimiter//o) {
+ push @output, map ord, split //, $1;
+ return _croak('non-basic code point') unless $1 =~ /^$BasicRE*$/o;
+ }
+
+ while ($code) {
+ my $oldi = $i;
+ my $w = 1;
+ LOOP:
+ for (my $k = BASE; 1; $k += BASE) {
+ my $cp = substr($code, 0, 1, '');
+ my $digit = digit_value($cp);
+ defined $digit or return _croak("invalid punycode input");
+ $i += $digit * $w;
+ my $t = ($k <= $bias) ? TMIN
+ : ($k >= $bias + TMAX) ? TMAX : $k - $bias;
+ last LOOP if $digit < $t;
+ $w *= (BASE - $t);
+ }
+ $bias = adapt($i - $oldi, @output + 1, $oldi == 0);
+ warn "bias becomes $bias" if $DEBUG;
+ $n += $i / (@output + 1);
+ $i = $i % (@output + 1);
+ splice(@output, $i, 0, $n);
+ warn join " ", map sprintf('%04x', $_), @output if $DEBUG;
+ $i++;
+ }
+ return join '', map chr, @output;
+ }
+
+ sub encode_punycode {
+ my $input = shift;
+ my @input = split //, $input;
+
+ my $n = INITIAL_N;
+ my $delta = 0;
+ my $bias = INITIAL_BIAS;
+
+ my @output;
+ my @basic = grep /$BasicRE/, @input;
+ my $h = my $b = @basic;
+ push @output, @basic;
+ push @output, $Delimiter if $b && $h < @input;
+ warn "basic codepoints: (@output)" if $DEBUG;
+
+ while ($h < @input) {
+ my $m = min(grep { $_ >= $n } map ord, @input);
+ warn sprintf "next code point to insert is %04x", $m if $DEBUG;
+ $delta += ($m - $n) * ($h + 1);
+ $n = $m;
+ for my $i (@input) {
+ my $c = ord($i);
+ $delta++ if $c < $n;
+ if ($c == $n) {
+ my $q = $delta;
+ LOOP:
+ for (my $k = BASE; 1; $k += BASE) {
+ my $t = ($k <= $bias) ? TMIN :
+ ($k >= $bias + TMAX) ? TMAX : $k - $bias;
+ last LOOP if $q < $t;
+ my $cp = code_point($t + (($q - $t) % (BASE - $t)));
+ push @output, chr($cp);
+ $q = ($q - $t) / (BASE - $t);
+ }
+ push @output, chr(code_point($q));
+ $bias = adapt($delta, $h + 1, $h == $b);
+ warn "bias becomes $bias" if $DEBUG;
+ $delta = 0;
+ $h++;
+ }
+ }
+ $delta++;
+ $n++;
+ }
+ return join '', @output;
+ }
+
+ sub min {
+ my $min = shift;
+ for (@_) { $min = $_ if $_ <= $min }
+ return $min;
+ }
+
+ 1;
+ __END__
+
+ =encoding utf8
+
+ =head1 NAME
+
+ URI::_punycode - encodes Unicode string in Punycode
+
+ =head1 SYNOPSIS
+
+ use strict;
+ use warnings;
+ use utf8;
+
+ use URI::_punycode qw(encode_punycode decode_punycode);
+
+ # encode a unicode string
+ my $punycode = encode_punycode('http://☃.net'); # http://.net-xc8g
+ $punycode = encode_punycode('bücher'); # bcher-kva
+ $punycode = encode_punycode('他们为什么不说中文'); # ihqwcrb4cv8a8dqg056pqjye
+
+ # decode a punycode string back into a unicode string
+ my $unicode = decode_punycode('http://.net-xc8g'); # http://☃.net
+ $unicode = decode_punycode('bcher-kva'); # bücher
+ $unicode = decode_punycode('ihqwcrb4cv8a8dqg056pqjye'); # 他们为什么不说中文
+
+ =head1 DESCRIPTION
+
+ L<URI::_punycode> is a module to encode / decode Unicode strings into
+ L<Punycode|https://tools.ietf.org/html/rfc3492>, an efficient
+ encoding of Unicode for use with L<IDNA|https://tools.ietf.org/html/rfc5890>.
+
+ =head1 FUNCTIONS
+
+ All functions throw exceptions on failure. You can C<catch> them with
+ L<Syntax::Keyword::Try> or L<Try::Tiny>. The following functions are exported
+ by default.
+
+ =head2 encode_punycode
+
+ my $punycode = encode_punycode('http://☃.net'); # http://.net-xc8g
+ $punycode = encode_punycode('bücher'); # bcher-kva
+ $punycode = encode_punycode('他们为什么不说中文') # ihqwcrb4cv8a8dqg056pqjye
+
+ Takes a Unicode string (UTF8-flagged variable) and returns a Punycode
+ encoding for it.
+
+ =head2 decode_punycode
+
+ my $unicode = decode_punycode('http://.net-xc8g'); # http://☃.net
+ $unicode = decode_punycode('bcher-kva'); # bücher
+ $unicode = decode_punycode('ihqwcrb4cv8a8dqg056pqjye'); # 他们为什么不说中文
+
+ Takes a Punycode encoding and returns original Unicode string.
=head1 AUTHOR
- Marc Lehmann <schmorp@schmorp.de>
- http://home.schmorp.de/
+ Tatsuhiko Miyagawa <F<miyagawa@bulknews.net>> is the author of
+ L<IDNA::Punycode> which was the basis for this module.
+
+ =head1 SEE ALSO
+
+ L<IDNA::Punycode>, L<RFC 3492|https://tools.ietf.org/html/rfc3492>,
+ L<RFC 5891|https://tools.ietf.org/html/rfc5891>
+
+ =head1 COPYRIGHT AND LICENSE
+
+ This library is free software; you can redistribute it and/or modify
+ it under the same terms as Perl itself.
=cut
+URI__PUNYCODE
+
+$fatpacked{"URI/_query.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI__QUERY';
+ package URI::_query;
+
+ use strict;
+ use warnings;
+
+ use URI ();
+ use URI::Escape qw(uri_unescape);
+
+ our $VERSION = '1.76';
+
+ sub query
+ {
+ my $self = shift;
+ $$self =~ m,^([^?\#]*)(?:\?([^\#]*))?(.*)$,s or die;
+
+ if (@_) {
+ my $q = shift;
+ $$self = $1;
+ if (defined $q) {
+ $q =~ s/([^$URI::uric])/ URI::Escape::escape_char($1)/ego;
+ utf8::downgrade($q);
+ $$self .= "?$q";
+ }
+ $$self .= $3;
+ }
+ $2;
+ }
+
+ # Handle ...?foo=bar&bar=foo type of query
+ sub query_form {
+ my $self = shift;
+ my $old = $self->query;
+ if (@_) {
+ # Try to set query string
+ my $delim;
+ my $r = $_[0];
+ if (ref($r) eq "ARRAY") {
+ $delim = $_[1];
+ @_ = @$r;
+ }
+ elsif (ref($r) eq "HASH") {
+ $delim = $_[1];
+ @_ = map { $_ => $r->{$_} } sort keys %$r;
+ }
+ $delim = pop if @_ % 2;
+
+ my @query;
+ while (my($key,$vals) = splice(@_, 0, 2)) {
+ $key = '' unless defined $key;
+ $key =~ s/([;\/?:@&=+,\$\[\]%])/ URI::Escape::escape_char($1)/eg;
+ $key =~ s/ /+/g;
+ $vals = [ref($vals) eq "ARRAY" ? @$vals : $vals];
+ for my $val (@$vals) {
+ $val = '' unless defined $val;
+ $val =~ s/([;\/?:@&=+,\$\[\]%])/ URI::Escape::escape_char($1)/eg;
+ $val =~ s/ /+/g;
+ push(@query, "$key=$val");
+ }
+ }
+ if (@query) {
+ unless ($delim) {
+ $delim = $1 if $old && $old =~ /([&;])/;
+ $delim ||= $URI::DEFAULT_QUERY_FORM_DELIMITER || "&";
+ }
+ $self->query(join($delim, @query));
+ }
+ else {
+ $self->query(undef);
+ }
+ }
+ return if !defined($old) || !length($old) || !defined(wantarray);
+ return unless $old =~ /=/; # not a form
+ map { s/\+/ /g; uri_unescape($_) }
+ map { /=/ ? split(/=/, $_, 2) : ($_ => '')} split(/[&;]/, $old);
+ }
- 1
+ # Handle ...?dog+bones type of query
+ sub query_keywords
+ {
+ my $self = shift;
+ my $old = $self->query;
+ if (@_) {
+ # Try to set query string
+ my @copy = @_;
+ @copy = @{$copy[0]} if @copy == 1 && ref($copy[0]) eq "ARRAY";
+ for (@copy) { s/([;\/?:@&=+,\$\[\]%])/ URI::Escape::escape_char($1)/eg; }
+ $self->query(@copy ? join('+', @copy) : undef);
+ }
+ return if !defined($old) || !defined(wantarray);
+ return if $old =~ /=/; # not keywords, but a form
+ map { uri_unescape($_) } split(/\+/, $old, -1);
+ }
+
+ # Some URI::URL compatibility stuff
+ sub equery { goto &query }
-TYPES_SERIALISER_ERROR
+ 1;
+URI__QUERY
-$fatpacked{"x86_64-linux-gnu-thread-multi/JSON/XS.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'X86_64-LINUX-GNU-THREAD-MULTI_JSON_XS';
- =head1 NAME
+$fatpacked{"URI/_segment.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI__SEGMENT';
+ package URI::_segment;
- JSON::XS - JSON serialising/deserialising, done correctly and fast
+ # Represents a generic path_segment so that it can be treated as
+ # a string too.
- =encoding utf-8
+ use strict;
+ use warnings;
- JSON::XS - 正しくて高速な JSON シリアライザ/デシリアライザ
- (http://fleur.hio.jp/perldoc/mix/lib/JSON/XS.html)
+ use URI::Escape qw(uri_unescape);
- =head1 SYNOPSIS
+ use overload '""' => sub { $_[0]->[0] },
+ fallback => 1;
- use JSON::XS;
+ our $VERSION = '1.76';
- # exported functions, they croak on error
- # and expect/generate UTF-8
+ sub new
+ {
+ my $class = shift;
+ my @segment = split(';', shift, -1);
+ $segment[0] = uri_unescape($segment[0]);
+ bless \@segment, $class;
+ }
- $utf8_encoded_json_text = encode_json $perl_hash_or_arrayref;
- $perl_hash_or_arrayref = decode_json $utf8_encoded_json_text;
+ 1;
+URI__SEGMENT
+
+$fatpacked{"URI/_server.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI__SERVER';
+ package URI::_server;
- # OO-interface
+ use strict;
+ use warnings;
- $coder = JSON::XS->new->ascii->pretty->allow_nonref;
- $pretty_printed_unencoded = $coder->encode ($perl_scalar);
- $perl_scalar = $coder->decode ($unicode_json_text);
+ use parent 'URI::_generic';
- # Note that JSON version 2.0 and above will automatically use JSON::XS
- # if available, at virtually no speed overhead either, so you should
- # be able to just:
-
- use JSON;
+ use URI::Escape qw(uri_unescape);
- # and do the same things, except that you have a pure-perl fallback now.
+ our $VERSION = '1.76';
- =head1 DESCRIPTION
+ sub _uric_escape {
+ my($class, $str) = @_;
+ if ($str =~ m,^((?:$URI::scheme_re:)?)//([^/?\#]*)(.*)$,os) {
+ my($scheme, $host, $rest) = ($1, $2, $3);
+ my $ui = $host =~ s/(.*@)// ? $1 : "";
+ my $port = $host =~ s/(:\d+)\z// ? $1 : "";
+ if (_host_escape($host)) {
+ $str = "$scheme//$ui$host$port$rest";
+ }
+ }
+ return $class->SUPER::_uric_escape($str);
+ }
+
+ sub _host_escape {
+ return unless $_[0] =~ /[^$URI::uric]/;
+ eval {
+ require URI::_idna;
+ $_[0] = URI::_idna::encode($_[0]);
+ };
+ return 0 if $@;
+ return 1;
+ }
+
+ sub as_iri {
+ my $self = shift;
+ my $str = $self->SUPER::as_iri;
+ if ($str =~ /\bxn--/) {
+ if ($str =~ m,^((?:$URI::scheme_re:)?)//([^/?\#]*)(.*)$,os) {
+ my($scheme, $host, $rest) = ($1, $2, $3);
+ my $ui = $host =~ s/(.*@)// ? $1 : "";
+ my $port = $host =~ s/(:\d+)\z// ? $1 : "";
+ require URI::_idna;
+ $host = URI::_idna::decode($host);
+ $str = "$scheme//$ui$host$port$rest";
+ }
+ }
+ return $str;
+ }
- This module converts Perl data structures to JSON and vice versa. Its
- primary goal is to be I<correct> and its secondary goal is to be
- I<fast>. To reach the latter goal it was written in C.
+ sub userinfo
+ {
+ my $self = shift;
+ my $old = $self->authority;
- Beginning with version 2.0 of the JSON module, when both JSON and
- JSON::XS are installed, then JSON will fall back on JSON::XS (this can be
- overridden) with no overhead due to emulation (by inheriting constructor
- and methods). If JSON::XS is not available, it will fall back to the
- compatible JSON::PP module as backend, so using JSON instead of JSON::XS
- gives you a portable JSON API that can be fast when you need and doesn't
- require a C compiler when that is a problem.
+ if (@_) {
+ my $new = $old;
+ $new = "" unless defined $new;
+ $new =~ s/.*@//; # remove old stuff
+ my $ui = shift;
+ if (defined $ui) {
+ $ui =~ s/@/%40/g; # protect @
+ $new = "$ui\@$new";
+ }
+ $self->authority($new);
+ }
+ return undef if !defined($old) || $old !~ /(.*)@/;
+ return $1;
+ }
- As this is the n-th-something JSON module on CPAN, what was the reason
- to write yet another JSON module? While it seems there are many JSON
- modules, none of them correctly handle all corner cases, and in most cases
- their maintainers are unresponsive, gone missing, or not listening to bug
- reports for other reasons.
+ sub host
+ {
+ my $self = shift;
+ my $old = $self->authority;
+ if (@_) {
+ my $tmp = $old;
+ $tmp = "" unless defined $tmp;
+ my $ui = ($tmp =~ /(.*@)/) ? $1 : "";
+ my $port = ($tmp =~ /(:\d+)$/) ? $1 : "";
+ my $new = shift;
+ $new = "" unless defined $new;
+ if (length $new) {
+ $new =~ s/[@]/%40/g; # protect @
+ if ($new =~ /^[^:]*:\d*\z/ || $new =~ /]:\d*\z/) {
+ $new =~ s/(:\d*)\z// || die "Assert";
+ $port = $1;
+ }
+ $new = "[$new]" if $new =~ /:/ && $new !~ /^\[/; # IPv6 address
+ _host_escape($new);
+ }
+ $self->authority("$ui$new$port");
+ }
+ return undef unless defined $old;
+ $old =~ s/.*@//;
+ $old =~ s/:\d+$//; # remove the port
+ $old =~ s{^\[(.*)\]$}{$1}; # remove brackets around IPv6 (RFC 3986 3.2.2)
+ return uri_unescape($old);
+ }
- See MAPPING, below, on how JSON::XS maps perl values to JSON values and
- vice versa.
+ sub ihost
+ {
+ my $self = shift;
+ my $old = $self->host(@_);
+ if ($old =~ /(^|\.)xn--/) {
+ require URI::_idna;
+ $old = URI::_idna::decode($old);
+ }
+ return $old;
+ }
- =head2 FEATURES
+ sub _port
+ {
+ my $self = shift;
+ my $old = $self->authority;
+ if (@_) {
+ my $new = $old;
+ $new =~ s/:\d*$//;
+ my $port = shift;
+ $new .= ":$port" if defined $port;
+ $self->authority($new);
+ }
+ return $1 if defined($old) && $old =~ /:(\d*)$/;
+ return;
+ }
- =over 4
+ sub port
+ {
+ my $self = shift;
+ my $port = $self->_port(@_);
+ $port = $self->default_port if !defined($port) || $port eq "";
+ $port;
+ }
+
+ sub host_port
+ {
+ my $self = shift;
+ my $old = $self->authority;
+ $self->host(shift) if @_;
+ return undef unless defined $old;
+ $old =~ s/.*@//; # zap userinfo
+ $old =~ s/:$//; # empty port should be treated the same a no port
+ $old .= ":" . $self->port unless $old =~ /:\d+$/;
+ $old;
+ }
+
+
+ sub default_port { undef }
+
+ sub canonical
+ {
+ my $self = shift;
+ my $other = $self->SUPER::canonical;
+ my $host = $other->host || "";
+ my $port = $other->_port;
+ my $uc_host = $host =~ /[A-Z]/;
+ my $def_port = defined($port) && ($port eq "" ||
+ $port == $self->default_port);
+ if ($uc_host || $def_port) {
+ $other = $other->clone if $other == $self;
+ $other->host(lc $host) if $uc_host;
+ $other->port(undef) if $def_port;
+ }
+ $other;
+ }
- =item * correct Unicode handling
+ 1;
+URI__SERVER
+
+$fatpacked{"URI/_userpass.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI__USERPASS';
+ package URI::_userpass;
- This module knows how to handle Unicode, documents how and when it does
- so, and even documents what "correct" means.
+ use strict;
+ use warnings;
- =item * round-trip integrity
+ use URI::Escape qw(uri_unescape);
- 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<are> minor exceptions to this, read the
- MAPPING section below to learn about those.
+ our $VERSION = '1.76';
- =item * strict checking of JSON correctness
+ sub user
+ {
+ my $self = shift;
+ my $info = $self->userinfo;
+ if (@_) {
+ my $new = shift;
+ my $pass = defined($info) ? $info : "";
+ $pass =~ s/^[^:]*//;
- 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).
+ if (!defined($new) && !length($pass)) {
+ $self->userinfo(undef);
+ } else {
+ $new = "" unless defined($new);
+ $new =~ s/%/%25/g;
+ $new =~ s/:/%3A/g;
+ $self->userinfo("$new$pass");
+ }
+ }
+ return undef unless defined $info;
+ $info =~ s/:.*//;
+ uri_unescape($info);
+ }
- =item * fast
+ sub password
+ {
+ my $self = shift;
+ my $info = $self->userinfo;
+ if (@_) {
+ my $new = shift;
+ my $user = defined($info) ? $info : "";
+ $user =~ s/:.*//;
- Compared to other JSON modules and other serialisers such as Storable,
- this module usually compares favourably in terms of speed, too.
+ if (!defined($new) && !length($user)) {
+ $self->userinfo(undef);
+ } else {
+ $new = "" unless defined($new);
+ $new =~ s/%/%25/g;
+ $self->userinfo("$user:$new");
+ }
+ }
+ return undef unless defined $info;
+ return undef unless $info =~ s/^[^:]*://;
+ uri_unescape($info);
+ }
- =item * simple to use
+ 1;
+URI__USERPASS
+
+$fatpacked{"URI/data.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_DATA';
+ package URI::data; # RFC 2397
- This module has both a simple functional interface as well as an object
- oriented interface.
+ use strict;
+ use warnings;
+
+ use parent 'URI';
+
+ our $VERSION = '1.76';
+
+ use MIME::Base64 qw(encode_base64 decode_base64);
+ use URI::Escape qw(uri_unescape);
+
+ sub media_type
+ {
+ my $self = shift;
+ my $opaque = $self->opaque;
+ $opaque =~ /^([^,]*),?/ or die;
+ my $old = $1;
+ my $base64;
+ $base64 = $1 if $old =~ s/(;base64)$//i;
+ if (@_) {
+ my $new = shift;
+ $new = "" unless defined $new;
+ $new =~ s/%/%25/g;
+ $new =~ s/,/%2C/g;
+ $base64 = "" unless defined $base64;
+ $opaque =~ s/^[^,]*,?/$new$base64,/;
+ $self->opaque($opaque);
+ }
+ return uri_unescape($old) if $old; # media_type can't really be "0"
+ "text/plain;charset=US-ASCII"; # default type
+ }
- =item * reasonably versatile output formats
+ sub data
+ {
+ my $self = shift;
+ my($enc, $data) = split(",", $self->opaque, 2);
+ unless (defined $data) {
+ $data = "";
+ $enc = "" unless defined $enc;
+ }
+ my $base64 = ($enc =~ /;base64$/i);
+ if (@_) {
+ $enc =~ s/;base64$//i if $base64;
+ my $new = shift;
+ $new = "" unless defined $new;
+ my $uric_count = _uric_count($new);
+ my $urienc_len = $uric_count + (length($new) - $uric_count) * 3;
+ my $base64_len = int((length($new)+2) / 3) * 4;
+ $base64_len += 7; # because of ";base64" marker
+ if ($base64_len < $urienc_len || $_[0]) {
+ $enc .= ";base64";
+ $new = encode_base64($new, "");
+ } else {
+ $new =~ s/%/%25/g;
+ }
+ $self->opaque("$enc,$new");
+ }
+ return unless defined wantarray;
+ $data = uri_unescape($data);
+ return $base64 ? decode_base64($data) : $data;
+ }
- 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.
+ # I could not find a better way to interpolate the tr/// chars from
+ # a variable.
+ my $ENC = $URI::uric;
+ $ENC =~ s/%//;
+
+ eval <<EOT; die $@ if $@;
+ sub _uric_count
+ {
+ \$_[0] =~ tr/$ENC//;
+ }
+ EOT
+
+ 1;
+
+ __END__
+
+ =head1 NAME
+
+ URI::data - URI that contains immediate data
+
+ =head1 SYNOPSIS
+
+ use URI;
+
+ $u = URI->new("data:");
+ $u->media_type("image/gif");
+ $u->data(scalar(`cat camel.gif`));
+ print "$u\n";
+ open(XV, "|xv -") and print XV $u->data;
+
+ =head1 DESCRIPTION
+
+ The C<URI::data> class supports C<URI> objects belonging to the I<data>
+ URI scheme. The I<data> URI scheme is specified in RFC 2397. It
+ allows inclusion of small data items as "immediate" data, as if it had
+ been included externally. Examples:
+
+ data:,Perl%20is%20good
+
+ data:image/gif;base64,R0lGODdhIAAgAIAAAAAAAPj8+CwAAAAAI
+ AAgAAAClYyPqcu9AJyCjtIKc5w5xP14xgeO2tlY3nWcajmZZdeJcG
+ Kxrmimms1KMTa1Wg8UROx4MNUq1HrycMjHT9b6xKxaFLM6VRKzI+p
+ KS9XtXpcbdun6uWVxJXA8pNPkdkkxhxc21LZHFOgD2KMoQXa2KMWI
+ JtnE2KizVUkYJVZZ1nczBxXlFopZBtoJ2diXGdNUymmJdFMAADs=
+
+
+
+ C<URI> objects belonging to the data scheme support the common methods
+ (described in L<URI>) and the following two scheme-specific methods:
+
+ =over 4
+
+ =item $uri->media_type( [$new_media_type] )
+
+ Can be used to get or set the media type specified in the
+ URI. If no media type is specified, then the default
+ C<"text/plain;charset=US-ASCII"> is returned.
+
+ =item $uri->data( [$new_data] )
+
+ Can be used to get or set the data contained in the URI.
+ The data is passed unescaped (in binary form). The decision about
+ whether to base64 encode the data in the URI is taken automatically,
+ based on the encoding that produces the shorter URI string.
=back
+ =head1 SEE ALSO
+
+ L<URI>
+
+ =head1 COPYRIGHT
+
+ Copyright 1995-1998 Gisle Aas.
+
+ This library is free software; you can redistribute it and/or
+ modify it under the same terms as Perl itself.
+
=cut
+URI_DATA
+
+$fatpacked{"URI/file.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_FILE';
+ package URI::file;
- package JSON::XS;
+ use strict;
+ use warnings;
- use common::sense;
+ use parent 'URI::_generic';
+ our $VERSION = "4.21";
- our $VERSION = 3.03;
- our @ISA = qw(Exporter);
+ use URI::Escape qw(uri_unescape);
- our @EXPORT = qw(encode_json decode_json);
+ our $DEFAULT_AUTHORITY = "";
- use Exporter;
- use XSLoader;
+ # Map from $^O values to implementation classes. The Unix
+ # class is the default.
+ our %OS_CLASS = (
+ os2 => "OS2",
+ mac => "Mac",
+ MacOS => "Mac",
+ MSWin32 => "Win32",
+ win32 => "Win32",
+ msdos => "FAT",
+ dos => "FAT",
+ qnx => "QNX",
+ );
- use Types::Serialiser ();
+ sub os_class
+ {
+ my($OS) = shift || $^O;
- =head1 FUNCTIONAL INTERFACE
+ my $class = "URI::file::" . ($OS_CLASS{$OS} || "Unix");
+ no strict 'refs';
+ unless (%{"$class\::"}) {
+ eval "require $class";
+ die $@ if $@;
+ }
+ $class;
+ }
+
+ sub host { uri_unescape(shift->authority(@_)) }
- The following convenience methods are provided by this module. They are
- exported by default:
+ sub new
+ {
+ my($class, $path, $os) = @_;
+ os_class($os)->new($path);
+ }
+
+ sub new_abs
+ {
+ my $class = shift;
+ my $file = $class->new(@_);
+ return $file->abs($class->cwd) unless $$file =~ /^file:/;
+ $file;
+ }
+
+ sub cwd
+ {
+ my $class = shift;
+ require Cwd;
+ my $cwd = Cwd::cwd();
+ $cwd = VMS::Filespec::unixpath($cwd) if $^O eq 'VMS';
+ $cwd = $class->new($cwd);
+ $cwd .= "/" unless substr($cwd, -1, 1) eq "/";
+ $cwd;
+ }
+
+ sub canonical {
+ my $self = shift;
+ my $other = $self->SUPER::canonical;
+
+ my $scheme = $other->scheme;
+ my $auth = $other->authority;
+ return $other if !defined($scheme) && !defined($auth); # relative
+
+ if (!defined($auth) ||
+ $auth eq "" ||
+ lc($auth) eq "localhost" ||
+ (defined($DEFAULT_AUTHORITY) && lc($auth) eq lc($DEFAULT_AUTHORITY))
+ )
+ {
+ # avoid cloning if $auth already match
+ if ((defined($auth) || defined($DEFAULT_AUTHORITY)) &&
+ (!defined($auth) || !defined($DEFAULT_AUTHORITY) || $auth ne $DEFAULT_AUTHORITY)
+ )
+ {
+ $other = $other->clone if $self == $other;
+ $other->authority($DEFAULT_AUTHORITY);
+ }
+ }
+
+ $other;
+ }
+
+ sub file
+ {
+ my($self, $os) = @_;
+ os_class($os)->file($self);
+ }
+
+ sub dir
+ {
+ my($self, $os) = @_;
+ os_class($os)->dir($self);
+ }
+
+ 1;
+
+ __END__
+
+ =head1 NAME
+
+ URI::file - URI that maps to local file names
+
+ =head1 SYNOPSIS
+
+ use URI::file;
+
+ $u1 = URI->new("file:/foo/bar");
+ $u2 = URI->new("foo/bar", "file");
+
+ $u3 = URI::file->new($path);
+ $u4 = URI::file->new("c:\\windows\\", "win32");
+
+ $u1->file;
+ $u1->file("mac");
+
+ =head1 DESCRIPTION
+
+ The C<URI::file> class supports C<URI> objects belonging to the I<file>
+ URI scheme. This scheme allows us to map the conventional file names
+ found on various computer systems to the URI name space. An old
+ specification of the I<file> URI scheme is found in RFC 1738. Some
+ older background information is also in RFC 1630. There are no newer
+ specifications as far as I know.
+
+ If you simply want to construct I<file> URI objects from URI strings,
+ use the normal C<URI> constructor. If you want to construct I<file>
+ URI objects from the actual file names used by various systems, then
+ use one of the following C<URI::file> constructors:
=over 4
- =item $json_text = encode_json $perl_scalar
+ =item $u = URI::file->new( $filename, [$os] )
- Converts the given Perl data structure to a UTF-8 encoded, binary string
- (that is, the string contains octets only). Croaks on error.
+ Maps a file name to the I<file:> URI name space, creates a URI object
+ and returns it. The $filename is interpreted as belonging to the
+ indicated operating system ($os), which defaults to the value of the
+ $^O variable. The $filename can be either absolute or relative, and
+ the corresponding type of URI object for $os is returned.
- This function call is functionally identical to:
+ =item $u = URI::file->new_abs( $filename, [$os] )
- $json_text = JSON::XS->new->utf8->encode ($perl_scalar)
+ Same as URI::file->new, but makes sure that the URI returned
+ represents an absolute file name. If the $filename argument is
+ relative, then the name is resolved relative to the current directory,
+ i.e. this constructor is really the same as:
- Except being faster.
+ URI::file->new($filename)->abs(URI::file->cwd);
- =item $perl_scalar = decode_json $json_text
+ =item $u = URI::file->cwd
- The opposite of C<encode_json>: expects an UTF-8 (binary) string and tries
- to parse that as an UTF-8 encoded JSON text, returning the resulting
- reference. Croaks on error.
+ Returns a I<file> URI that represents the current working directory.
+ See L<Cwd>.
- This function call is functionally identical to:
+ =back
- $perl_scalar = JSON::XS->new->utf8->decode ($json_text)
+ The following methods are supported for I<file> URI (in addition to
+ the common and generic methods described in L<URI>):
- Except being faster.
+ =over 4
+
+ =item $u->file( [$os] )
+
+ Returns a file name. It maps from the URI name space
+ to the file name space of the indicated operating system.
+
+ It might return C<undef> if the name can not be represented in the
+ indicated file system.
+
+ =item $u->dir( [$os] )
+
+ Some systems use a different form for names of directories than for plain
+ files. Use this method if you know you want to use the name for
+ a directory.
=back
+ The C<URI::file> module can be used to map generic file names to names
+ suitable for the current system. As such, it can work as a nice
+ replacement for the C<File::Spec> module. For instance, the following
+ code translates the UNIX-style file name F<Foo/Bar.pm> to a name
+ suitable for the local system:
+
+ $file = URI::file->new("Foo/Bar.pm", "unix")->file;
+ die "Can't map filename Foo/Bar.pm for $^O" unless defined $file;
+ open(FILE, $file) || die "Can't open '$file': $!";
+ # do something with FILE
+
+ =head1 MAPPING NOTES
+
+ Most computer systems today have hierarchically organized file systems.
+ Mapping the names used in these systems to the generic URI syntax
+ allows us to work with relative file URIs that behave as they should
+ when resolved using the generic algorithm for URIs (specified in RFC
+ 2396). Mapping a file name to the generic URI syntax involves mapping
+ the path separator character to "/" and encoding any reserved
+ characters that appear in the path segments of the file name. If
+ path segments consisting of the strings "." or ".." have a
+ different meaning than what is specified for generic URIs, then these
+ must be encoded as well.
+
+ If the file system has device, volume or drive specifications as
+ the root of the name space, then it makes sense to map them to the
+ authority field of the generic URI syntax. This makes sure that
+ relative URIs can not be resolved "above" them, i.e. generally how
+ relative file names work in those systems.
+
+ Another common use of the authority field is to encode the host on which
+ this file name is valid. The host name "localhost" is special and
+ generally has the same meaning as a missing or empty authority
+ field. This use is in conflict with using it as a device
+ specification, but can often be resolved for device specifications
+ having characters not legal in plain host names.
+
+ File name to URI mapping in normally not one-to-one. There are
+ usually many URIs that map to any given file name. For instance, an
+ authority of "localhost" maps the same as a URI with a missing or empty
+ authority.
+
+ Example 1: The Mac classic (Mac OS 9 and earlier) used ":" as path separator,
+ but not in the same way as a generic URI. ":foo" was a relative name. "foo:bar"
+ was an absolute name. Also, path segments could contain the "/" character as well
+ as the literal "." or "..". So the mapping looks like this:
+
+ Mac classic URI
+ ---------- -------------------
+ :foo:bar <==> foo/bar
+ : <==> ./
+ ::foo:bar <==> ../foo/bar
+ ::: <==> ../../
+ foo:bar <==> file:/foo/bar
+ foo:bar: <==> file:/foo/bar/
+ .. <==> %2E%2E
+ <undef> <== /
+ foo/ <== file:/foo%2F
+ ./foo.txt <== file:/.%2Ffoo.txt
+
+ Note that if you want a relative URL, you *must* begin the path with a :. Any
+ path that begins with [^:] is treated as absolute.
+
+ Example 2: The UNIX file system is easy to map, as it uses the same path
+ separator as URIs, has a single root, and segments of "." and ".."
+ have the same meaning. URIs that have the character "\0" or "/" as
+ part of any path segment can not be turned into valid UNIX file names.
+
+ UNIX URI
+ ---------- ------------------
+ foo/bar <==> foo/bar
+ /foo/bar <==> file:/foo/bar
+ /foo/bar <== file://localhost/foo/bar
+ file: ==> ./file:
+ <undef> <== file:/fo%00/bar
+ / <==> file:/
- =head1 A FEW NOTES ON UNICODE AND PERL
+ =cut
- Since this often leads to confusion, here are a few very clear words on
- how Unicode works in Perl, modulo bugs.
- =over 4
+ RFC 1630
- =item 1. Perl strings can store characters with ordinal values > 255.
+ [...]
- This enables you to store Unicode characters as single characters in a
- Perl string - very natural.
+ There is clearly a danger of confusion that a link made to a local
+ file should be followed by someone on a different system, with
+ unexpected and possibly harmful results. Therefore, the convention
+ is that even a "file" URL is provided with a host part. This allows
+ a client on another system to know that it cannot access the file
+ system, or perhaps to use some other local mechanism to access the
+ file.
- =item 2. Perl does I<not> associate an encoding with your strings.
+ The special value "localhost" is used in the host field to indicate
+ that the filename should really be used on whatever host one is.
+ This for example allows links to be made to files which are
+ distributed on many machines, or to "your unix local password file"
+ subject of course to consistency across the users of the data.
- ... until you force it to, e.g. when matching it against a regex, or
- printing the scalar to a file, in which case Perl either interprets your
- string as locale-encoded text, octets/binary, or as Unicode, depending
- on various settings. In no case is an encoding stored together with your
- data, it is I<use> that decides encoding, not any magical meta data.
+ A void host field is equivalent to "localhost".
- =item 3. The internal utf-8 flag has no meaning with regards to the
- encoding of your string.
+ =head1 CONFIGURATION VARIABLES
- Just ignore that flag unless you debug a Perl bug, a module written in
- XS or want to dive into the internals of perl. Otherwise it will only
- confuse you, as, despite the name, it says nothing about how your string
- is encoded. You can have Unicode strings with that flag set, with that
- flag clear, and you can have binary data with that flag set and that flag
- clear. Other possibilities exist, too.
+ The following configuration variables influence how the class and its
+ methods behave:
- If you didn't know about that flag, just the better, pretend it doesn't
- exist.
+ =over
+
+ =item %URI::file::OS_CLASS
+
+ This hash maps OS identifiers to implementation classes. You might
+ want to add or modify this if you want to plug in your own file
+ handler class. Normally the keys should match the $^O values in use.
- =item 4. A "Unicode String" is simply a string where each character can be
- validly interpreted as a Unicode code point.
+ If there is no mapping then the "Unix" implementation is used.
- If you have UTF-8 encoded data, it is no longer a Unicode string, but a
- Unicode string encoded in UTF-8, giving you a binary string.
+ =item $URI::file::DEFAULT_AUTHORITY
- =item 5. A string containing "high" (> 255) character values is I<not> a UTF-8 string.
+ This determine what "authority" string to include in absolute file
+ URIs. It defaults to "". If you prefer verbose URIs you might set it
+ to be "localhost".
- It's a fact. Learn to live with it.
+ Setting this value to C<undef> force behaviour compatible to URI v1.31
+ and earlier. In this mode host names in UNC paths and drive letters
+ are mapped to the authority component on Windows, while we produce
+ authority-less URIs on Unix.
=back
- I hope this helps :)
+ =head1 SEE ALSO
- =head1 OBJECT-ORIENTED INTERFACE
+ L<URI>, L<File::Spec>, L<perlport>
- The object oriented interface lets you configure your own encoding or
- decoding style, within the limits of supported formats.
+ =head1 COPYRIGHT
- =over 4
+ Copyright 1995-1998,2004 Gisle Aas.
- =item $json = new JSON::XS
+ This library is free software; you can redistribute it and/or
+ modify it under the same terms as Perl itself.
- Creates a new JSON::XS object that can be used to de/encode JSON
- strings. All boolean flags described below are by default I<disabled>.
+ =cut
+URI_FILE
+
+$fatpacked{"URI/file/Base.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_FILE_BASE';
+ package URI::file::Base;
- The mutators for flags all return the JSON object again and thus calls can
- be chained:
+ use strict;
+ use warnings;
- my $json = JSON::XS->new->utf8->space_after->encode ({a => [1,2]})
- => {"a": [1, 2]}
+ use URI::Escape qw();
- =item $json = $json->ascii ([$enable])
+ our $VERSION = '1.76';
- =item $enabled = $json->get_ascii
+ sub new
+ {
+ my $class = shift;
+ my $path = shift;
+ $path = "" unless defined $path;
- If C<$enable> is true (or missing), then the C<encode> method will not
- generate characters outside the code range C<0..127> (which is ASCII). Any
- Unicode characters outside that range will be escaped using either a
- single \uXXXX (BMP characters) or a double \uHHHH\uLLLLL escape sequence,
- as per RFC4627. The resulting encoded JSON text can be treated as a native
- Unicode string, an ascii-encoded, latin1-encoded or UTF-8 encoded string,
- or any other superset of ASCII.
+ my($auth, $escaped_auth, $escaped_path);
- If C<$enable> is false, then the C<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.
+ ($auth, $escaped_auth) = $class->_file_extract_authority($path);
+ ($path, $escaped_path) = $class->_file_extract_path($path);
- See also the section I<ENCODING/CODESET FLAG NOTES> later in this
- document.
+ if (defined $auth) {
+ $auth =~ s,%,%25,g unless $escaped_auth;
+ $auth =~ s,([/?\#]), URI::Escape::escape_char($1),eg;
+ $auth = "//$auth";
+ if (defined $path) {
+ $path = "/$path" unless substr($path, 0, 1) eq "/";
+ } else {
+ $path = "";
+ }
+ } else {
+ return undef unless defined $path;
+ $auth = "";
+ }
- The main use for this flag is to produce JSON texts that can be
- transmitted over a 7-bit channel, as the encoded JSON texts will not
- contain any 8 bit characters.
+ $path =~ s,([%;?]), URI::Escape::escape_char($1),eg unless $escaped_path;
+ $path =~ s/\#/%23/g;
- JSON::XS->new->ascii (1)->encode ([chr 0x10401])
- => ["\ud801\udc01"]
+ my $uri = $auth . $path;
+ $uri = "file:$uri" if substr($uri, 0, 1) eq "/";
- =item $json = $json->latin1 ([$enable])
+ URI->new($uri, "file");
+ }
- =item $enabled = $json->get_latin1
+ sub _file_extract_authority
+ {
+ my($class, $path) = @_;
+ return undef unless $class->_file_is_absolute($path);
+ return $URI::file::DEFAULT_AUTHORITY;
+ }
- If C<$enable> is true (or missing), then the C<encode> method will encode
- the resulting JSON text as latin1 (or iso-8859-1), escaping any characters
- outside the code range C<0..255>. The resulting string can be treated as a
- latin1-encoded JSON text or a native Unicode string. The C<decode> method
- will not be affected in any way by this flag, as C<decode> by default
- expects Unicode, which is a strict superset of latin1.
+ sub _file_extract_path
+ {
+ return undef;
+ }
- If C<$enable> is false, then the C<encode> method will not escape Unicode
- characters unless required by the JSON syntax or other flags.
+ sub _file_is_absolute
+ {
+ return 0;
+ }
- See also the section I<ENCODING/CODESET FLAG NOTES> later in this
- document.
+ sub _file_is_localhost
+ {
+ shift; # class
+ my $host = lc(shift);
+ return 1 if $host eq "localhost";
+ eval {
+ require Net::Domain;
+ lc(Net::Domain::hostfqdn() || '') eq $host ||
+ lc(Net::Domain::hostname() || '') eq $host;
+ };
+ }
- The main use for this flag is efficiently encoding binary data as JSON
- text, as most octets will not be escaped, resulting in a smaller encoded
- size. The disadvantage is that the resulting JSON text is encoded
- in latin1 (and must correctly be treated as such when storing and
- transferring), a rare encoding for JSON. It is therefore most useful when
- you want to store data structures known to contain binary data efficiently
- in files or databases, not when talking to other JSON encoders/decoders.
+ sub file
+ {
+ undef;
+ }
- JSON::XS->new->latin1->encode (["\x{89}\x{abc}"]
- => ["\x{89}\\u0abc"] # (perl syntax, U+abc escaped, U+89 not)
+ sub dir
+ {
+ my $self = shift;
+ $self->file(@_);
+ }
- =item $json = $json->utf8 ([$enable])
+ 1;
+URI_FILE_BASE
+
+$fatpacked{"URI/file/FAT.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_FILE_FAT';
+ package URI::file::FAT;
- =item $enabled = $json->get_utf8
+ use strict;
+ use warnings;
- If C<$enable> is true (or missing), then the C<encode> method will encode
- the JSON result into UTF-8, as required by many protocols, while the
- C<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 C<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.
+ use parent 'URI::file::Win32';
- If C<$enable> is false, then the C<encode> method will return the JSON
- string as a (non-encoded) Unicode string, while C<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.
+ our $VERSION = '1.76';
- See also the section I<ENCODING/CODESET FLAG NOTES> later in this
- document.
+ sub fix_path
+ {
+ shift; # class
+ for (@_) {
+ # turn it into 8.3 names
+ my @p = map uc, split(/\./, $_, -1);
+ return if @p > 2; # more than 1 dot is not allowed
+ @p = ("") unless @p; # split bug? (returns nothing when splitting "")
+ $_ = substr($p[0], 0, 8);
+ if (@p > 1) {
+ my $ext = substr($p[1], 0, 3);
+ $_ .= ".$ext" if length $ext;
+ }
+ }
+ 1; # ok
+ }
- Example, output UTF-16BE-encoded JSON:
+ 1;
+URI_FILE_FAT
+
+$fatpacked{"URI/file/Mac.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_FILE_MAC';
+ package URI::file::Mac;
- use Encode;
- $jsontext = encode "UTF-16BE", JSON::XS->new->encode ($object);
+ use strict;
+ use warnings;
- Example, decode UTF-32LE-encoded JSON:
+ use parent 'URI::file::Base';
- use Encode;
- $object = JSON::XS->new->decode (decode "UTF-32LE", $jsontext);
+ use URI::Escape qw(uri_unescape);
- =item $json = $json->pretty ([$enable])
+ our $VERSION = '1.76';
- This enables (or disables) all of the C<indent>, C<space_before> and
- C<space_after> (and in the future possibly more) flags in one call to
- generate the most readable (or most compact) form possible.
+ sub _file_extract_path
+ {
+ my $class = shift;
+ my $path = shift;
- Example, pretty-print some simple structure:
+ my @pre;
+ if ($path =~ s/^(:+)//) {
+ if (length($1) == 1) {
+ @pre = (".") unless length($path);
+ } else {
+ @pre = ("..") x (length($1) - 1);
+ }
+ } else { #absolute
+ $pre[0] = "";
+ }
- my $json = JSON::XS->new->pretty(1)->encode ({a => [1,2]})
- =>
- {
- "a" : [
- 1,
- 2
- ]
- }
+ my $isdir = ($path =~ s/:$//);
+ $path =~ s,([%/;]), URI::Escape::escape_char($1),eg;
- =item $json = $json->indent ([$enable])
+ my @path = split(/:/, $path, -1);
+ for (@path) {
+ if ($_ eq "." || $_ eq "..") {
+ $_ = "%2E" x length($_);
+ }
+ $_ = ".." unless length($_);
+ }
+ push (@path,"") if $isdir;
+ (join("/", @pre, @path), 1);
+ }
- =item $enabled = $json->get_indent
- If C<$enable> is true (or missing), then the C<encode> method will use a multiline
- format as output, putting every array member or object/hash key-value pair
- into its own line, indenting them properly.
+ sub file
+ {
+ my $class = shift;
+ my $uri = shift;
+ my @path;
+
+ my $auth = $uri->authority;
+ if (defined $auth) {
+ if (lc($auth) ne "localhost" && $auth ne "") {
+ my $u_auth = uri_unescape($auth);
+ if (!$class->_file_is_localhost($u_auth)) {
+ # some other host (use it as volume name)
+ @path = ("", $auth);
+ # XXX or just return to make it illegal;
+ }
+ }
+ }
+ my @ps = split("/", $uri->path, -1);
+ shift @ps if @path;
+ push(@path, @ps);
+
+ my $pre = "";
+ if (!@path) {
+ return; # empty path; XXX return ":" instead?
+ } elsif ($path[0] eq "") {
+ # absolute
+ shift(@path);
+ if (@path == 1) {
+ return if $path[0] eq ""; # not root directory
+ push(@path, ""); # volume only, effectively append ":"
+ }
+ @ps = @path;
+ @path = ();
+ my $part;
+ for (@ps) { #fix up "." and "..", including interior, in relatives
+ next if $_ eq ".";
+ $part = $_ eq ".." ? "" : $_;
+ push(@path,$part);
+ }
+ if ($ps[-1] eq "..") { #if this happens, we need another :
+ push(@path,"");
+ }
+
+ } else {
+ $pre = ":";
+ @ps = @path;
+ @path = ();
+ my $part;
+ for (@ps) { #fix up "." and "..", including interior, in relatives
+ next if $_ eq ".";
+ $part = $_ eq ".." ? "" : $_;
+ push(@path,$part);
+ }
+ if ($ps[-1] eq "..") { #if this happens, we need another :
+ push(@path,"");
+ }
+
+ }
+ return unless $pre || @path;
+ for (@path) {
+ s/;.*//; # get rid of parameters
+ #return unless length; # XXX
+ $_ = uri_unescape($_);
+ return if /\0/;
+ return if /:/; # Should we?
+ }
+ $pre . join(":", @path);
+ }
- If C<$enable> is false, no newlines or indenting will be produced, and the
- resulting JSON text is guaranteed not to contain any C<newlines>.
+ sub dir
+ {
+ my $class = shift;
+ my $path = $class->file(@_);
+ return unless defined $path;
+ $path .= ":" unless $path =~ /:$/;
+ $path;
+ }
- This setting has no effect when decoding JSON texts.
+ 1;
+URI_FILE_MAC
+
+$fatpacked{"URI/file/OS2.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_FILE_OS2';
+ package URI::file::OS2;
- =item $json = $json->space_before ([$enable])
+ use strict;
+ use warnings;
- =item $enabled = $json->get_space_before
+ use parent 'URI::file::Win32';
- If C<$enable> is true (or missing), then the C<encode> method will add an extra
- optional space before the C<:> separating keys from values in JSON objects.
+ our $VERSION = '1.76';
- If C<$enable> is false, then the C<encode> method will not add any extra
- space at those places.
+ # The Win32 version translates k:/foo to file://k:/foo (?!)
+ # We add an empty host
- This setting has no effect when decoding JSON texts. You will also
- most likely combine this setting with C<space_after>.
+ sub _file_extract_authority
+ {
+ my $class = shift;
+ return $1 if $_[0] =~ s,^\\\\([^\\]+),,; # UNC
+ return $1 if $_[0] =~ s,^//([^/]+),,; # UNC too?
- Example, space_before enabled, space_after and indent disabled:
+ if ($_[0] =~ m#^[a-zA-Z]{1,2}:#) { # allow for ab: drives
+ return "";
+ }
+ return;
+ }
- {"key" :"value"}
+ sub file {
+ my $p = &URI::file::Win32::file;
+ return unless defined $p;
+ $p =~ s,\\,/,g;
+ $p;
+ }
- =item $json = $json->space_after ([$enable])
+ 1;
+URI_FILE_OS2
+
+$fatpacked{"URI/file/QNX.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_FILE_QNX';
+ package URI::file::QNX;
- =item $enabled = $json->get_space_after
+ use strict;
+ use warnings;
- If C<$enable> is true (or missing), then the C<encode> 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.
+ use parent 'URI::file::Unix';
- If C<$enable> is false, then the C<encode> method will not add any extra
- space at those places.
+ our $VERSION = '1.76';
- This setting has no effect when decoding JSON texts.
+ sub _file_extract_path
+ {
+ my($class, $path) = @_;
+ # tidy path
+ $path =~ s,(.)//+,$1/,g; # ^// is correct
+ $path =~ s,(/\.)+/,/,g;
+ $path = "./$path" if $path =~ m,^[^:/]+:,,; # look like "scheme:"
+ $path;
+ }
- Example, space_before and indent disabled, space_after enabled:
+ 1;
+URI_FILE_QNX
+
+$fatpacked{"URI/file/Unix.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_FILE_UNIX';
+ package URI::file::Unix;
- {"key": "value"}
+ use strict;
+ use warnings;
- =item $json = $json->relaxed ([$enable])
+ use parent 'URI::file::Base';
- =item $enabled = $json->get_relaxed
+ use URI::Escape qw(uri_unescape);
- If C<$enable> is true (or missing), then C<decode> will accept some
- extensions to normal JSON syntax (see below). C<encode> will not be
- affected in anyway. I<Be aware that this option makes you accept invalid
- JSON texts as if they were valid!>. I suggest only to use this option to
- parse application-specific files written by humans (configuration files,
- resource files etc.)
+ our $VERSION = '1.76';
- If C<$enable> is false (the default), then C<decode> will only accept
- valid JSON texts.
+ sub _file_extract_path
+ {
+ my($class, $path) = @_;
- Currently accepted extensions are:
+ # tidy path
+ $path =~ s,//+,/,g;
+ $path =~ s,(/\.)+/,/,g;
+ $path = "./$path" if $path =~ m,^[^:/]+:,,; # look like "scheme:"
+
+ return $path;
+ }
+
+ sub _file_is_absolute {
+ my($class, $path) = @_;
+ return $path =~ m,^/,;
+ }
+
+ sub file
+ {
+ my $class = shift;
+ my $uri = shift;
+ my @path;
+
+ my $auth = $uri->authority;
+ if (defined($auth)) {
+ if (lc($auth) ne "localhost" && $auth ne "") {
+ $auth = uri_unescape($auth);
+ unless ($class->_file_is_localhost($auth)) {
+ push(@path, "", "", $auth);
+ }
+ }
+ }
+
+ my @ps = $uri->path_segments;
+ shift @ps if @path;
+ push(@path, @ps);
+
+ for (@path) {
+ # Unix file/directory names are not allowed to contain '\0' or '/'
+ return undef if /\0/;
+ return undef if /\//; # should we really?
+ }
+
+ return join("/", @path);
+ }
+
+ 1;
+URI_FILE_UNIX
+
+$fatpacked{"URI/file/Win32.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_FILE_WIN32';
+ package URI::file::Win32;
+
+ use strict;
+ use warnings;
+
+ use parent 'URI::file::Base';
+
+ use URI::Escape qw(uri_unescape);
+
+ our $VERSION = '1.76';
+
+ sub _file_extract_authority
+ {
+ my $class = shift;
+
+ return $class->SUPER::_file_extract_authority($_[0])
+ if defined $URI::file::DEFAULT_AUTHORITY;
+
+ return $1 if $_[0] =~ s,^\\\\([^\\]+),,; # UNC
+ return $1 if $_[0] =~ s,^//([^/]+),,; # UNC too?
+
+ if ($_[0] =~ s,^([a-zA-Z]:),,) {
+ my $auth = $1;
+ $auth .= "relative" if $_[0] !~ m,^[\\/],;
+ return $auth;
+ }
+ return undef;
+ }
+
+ sub _file_extract_path
+ {
+ my($class, $path) = @_;
+ $path =~ s,\\,/,g;
+ #$path =~ s,//+,/,g;
+ $path =~ s,(/\.)+/,/,g;
+
+ if (defined $URI::file::DEFAULT_AUTHORITY) {
+ $path =~ s,^([a-zA-Z]:),/$1,;
+ }
+
+ return $path;
+ }
+
+ sub _file_is_absolute {
+ my($class, $path) = @_;
+ return $path =~ m,^[a-zA-Z]:, || $path =~ m,^[/\\],;
+ }
+
+ sub file
+ {
+ my $class = shift;
+ my $uri = shift;
+ my $auth = $uri->authority;
+ my $rel; # is filename relative to drive specified in authority
+ if (defined $auth) {
+ $auth = uri_unescape($auth);
+ if ($auth =~ /^([a-zA-Z])[:|](relative)?/) {
+ $auth = uc($1) . ":";
+ $rel++ if $2;
+ } elsif (lc($auth) eq "localhost") {
+ $auth = "";
+ } elsif (length $auth) {
+ $auth = "\\\\" . $auth; # UNC
+ }
+ } else {
+ $auth = "";
+ }
+
+ my @path = $uri->path_segments;
+ for (@path) {
+ return undef if /\0/;
+ return undef if /\//;
+ #return undef if /\\/; # URLs with "\" is not uncommon
+ }
+ return undef unless $class->fix_path(@path);
+
+ my $path = join("\\", @path);
+ $path =~ s/^\\// if $rel;
+ $path = $auth . $path;
+ $path =~ s,^\\([a-zA-Z])[:|],\u$1:,;
+
+ return $path;
+ }
+
+ sub fix_path { 1; }
+
+ 1;
+URI_FILE_WIN32
+
+$fatpacked{"URI/ftp.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_FTP';
+ package URI::ftp;
+
+ use strict;
+ use warnings;
+
+ our $VERSION = '1.76';
+
+ use parent qw(URI::_server URI::_userpass);
+
+ sub default_port { 21 }
+
+ sub path { shift->path_query(@_) } # XXX
+
+ sub _user { shift->SUPER::user(@_); }
+ sub _password { shift->SUPER::password(@_); }
+
+ sub user
+ {
+ my $self = shift;
+ my $user = $self->_user(@_);
+ $user = "anonymous" unless defined $user;
+ $user;
+ }
+
+ sub password
+ {
+ my $self = shift;
+ my $pass = $self->_password(@_);
+ unless (defined $pass) {
+ my $user = $self->user;
+ if ($user eq 'anonymous' || $user eq 'ftp') {
+ # anonymous ftp login password
+ # If there is no ftp anonymous password specified
+ # then we'll just use 'anonymous@'
+ # We don't try to send the read e-mail address because:
+ # - We want to remain anonymous
+ # - We want to stop SPAM
+ # - We don't want to let ftp sites to discriminate by the user,
+ # host, country or ftp client being used.
+ $pass = 'anonymous@';
+ }
+ }
+ $pass;
+ }
+
+ 1;
+URI_FTP
+
+$fatpacked{"URI/gopher.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_GOPHER';
+ package URI::gopher; # <draft-murali-url-gopher>, Dec 4, 1996
+
+ use strict;
+ use warnings;
+
+ our $VERSION = '1.76';
+
+ use parent 'URI::_server';
+
+ use URI::Escape qw(uri_unescape);
+
+ # A Gopher URL follows the common internet scheme syntax as defined in
+ # section 4.3 of [RFC-URL-SYNTAX]:
+ #
+ # gopher://<host>[:<port>]/<gopher-path>
+ #
+ # where
+ #
+ # <gopher-path> := <gopher-type><selector> |
+ # <gopher-type><selector>%09<search> |
+ # <gopher-type><selector>%09<search>%09<gopher+_string>
+ #
+ # <gopher-type> := '0' | '1' | '2' | '3' | '4' | '5' | '6' | '7'
+ # '8' | '9' | '+' | 'I' | 'g' | 'T'
+ #
+ # <selector> := *pchar Refer to RFC 1808 [4]
+ # <search> := *pchar
+ # <gopher+_string> := *uchar Refer to RFC 1738 [3]
+ #
+ # If the optional port is omitted, the port defaults to 70.
+
+ sub default_port { 70 }
+
+ sub _gopher_type
+ {
+ my $self = shift;
+ my $path = $self->path_query;
+ $path =~ s,^/,,;
+ my $gtype = $1 if $path =~ s/^(.)//s;
+ if (@_) {
+ my $new_type = shift;
+ if (defined($new_type)) {
+ Carp::croak("Bad gopher type '$new_type'")
+ unless length($new_type) == 1;
+ substr($path, 0, 0) = $new_type;
+ $self->path_query($path);
+ } else {
+ Carp::croak("Can't delete gopher type when selector is present")
+ if length($path);
+ $self->path_query(undef);
+ }
+ }
+ return $gtype;
+ }
+
+ sub gopher_type
+ {
+ my $self = shift;
+ my $gtype = $self->_gopher_type(@_);
+ $gtype = "1" unless defined $gtype;
+ $gtype;
+ }
+
+ sub gtype { goto &gopher_type } # URI::URL compatibility
+
+ sub selector { shift->_gfield(0, @_) }
+ sub search { shift->_gfield(1, @_) }
+ sub string { shift->_gfield(2, @_) }
+
+ sub _gfield
+ {
+ my $self = shift;
+ my $fno = shift;
+ my $path = $self->path_query;
+
+ # not according to spec., but many popular browsers accept
+ # gopher URLs with a '?' before the search string.
+ $path =~ s/\?/\t/;
+ $path = uri_unescape($path);
+ $path =~ s,^/,,;
+ my $gtype = $1 if $path =~ s,^(.),,s;
+ my @path = split(/\t/, $path, 3);
+ if (@_) {
+ # modify
+ my $new = shift;
+ $path[$fno] = $new;
+ pop(@path) while @path && !defined($path[-1]);
+ for (@path) { $_="" unless defined }
+ $path = $gtype;
+ $path = "1" unless defined $path;
+ $path .= join("\t", @path);
+ $self->path_query($path);
+ }
+ $path[$fno];
+ }
+
+ 1;
+URI_GOPHER
+
+$fatpacked{"URI/http.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_HTTP';
+ package URI::http;
+
+ use strict;
+ use warnings;
+
+ our $VERSION = '1.76';
+
+ use parent 'URI::_server';
+
+ sub default_port { 80 }
+
+ sub canonical
+ {
+ my $self = shift;
+ my $other = $self->SUPER::canonical;
+
+ my $slash_path = defined($other->authority) &&
+ !length($other->path) && !defined($other->query);
+
+ if ($slash_path) {
+ $other = $other->clone if $other == $self;
+ $other->path("/");
+ }
+ $other;
+ }
+
+ 1;
+URI_HTTP
+
+$fatpacked{"URI/https.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_HTTPS';
+ package URI::https;
+
+ use strict;
+ use warnings;
+
+ our $VERSION = '1.76';
+
+ use parent 'URI::http';
+
+ sub default_port { 443 }
+
+ sub secure { 1 }
+
+ 1;
+URI_HTTPS
+
+$fatpacked{"URI/ldap.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_LDAP';
+ # Copyright (c) 1998 Graham Barr <gbarr@pobox.com>. All rights reserved.
+ # This program is free software; you can redistribute it and/or
+ # modify it under the same terms as Perl itself.
+
+ package URI::ldap;
+
+ use strict;
+ use warnings;
+
+ our $VERSION = '1.76';
+
+ use parent qw(URI::_ldap URI::_server);
+
+ sub default_port { 389 }
+
+ sub _nonldap_canonical {
+ my $self = shift;
+ $self->URI::_server::canonical(@_);
+ }
+
+ 1;
+
+ __END__
+
+ =head1 NAME
+
+ URI::ldap - LDAP Uniform Resource Locators
+
+ =head1 SYNOPSIS
+
+ use URI;
+
+ $uri = URI->new("ldap:$uri_string");
+ $dn = $uri->dn;
+ $filter = $uri->filter;
+ @attr = $uri->attributes;
+ $scope = $uri->scope;
+ %extn = $uri->extensions;
+
+ $uri = URI->new("ldap:"); # start empty
+ $uri->host("ldap.itd.umich.edu");
+ $uri->dn("o=University of Michigan,c=US");
+ $uri->attributes(qw(postalAddress));
+ $uri->scope('sub');
+ $uri->filter('(cn=Babs Jensen)');
+ print $uri->as_string,"\n";
+
+ =head1 DESCRIPTION
+
+ C<URI::ldap> provides an interface to parse an LDAP URI into its
+ constituent parts and also to build a URI as described in
+ RFC 2255.
+
+ =head1 METHODS
+
+ C<URI::ldap> supports all the generic and server methods defined by
+ L<URI>, plus the following.
+
+ Each of the following methods can be used to set or get the value in
+ the URI. The values are passed in unescaped form. None of these
+ return undefined values, but elements without a default can be empty.
+ If arguments are given, then a new value is set for the given part
+ of the URI.
=over 4
- =item * list items can have an end-comma
+ =item $uri->dn( [$new_dn] )
- JSON I<separates> 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:
+ Sets or gets the I<Distinguished Name> part of the URI. The DN
+ identifies the base object of the LDAP search.
- [
- 1,
- 2, <- this comma not normally allowed
- ]
- {
- "k1": "v1",
- "k2": "v2", <- this comma not normally allowed
- }
+ =item $uri->attributes( [@new_attrs] )
- =item * shell-style '#'-comments
+ Sets or gets the list of attribute names which are
+ returned by the search.
- 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.
+ =item $uri->scope( [$new_scope] )
- [
- 1, # this comment not allowed in JSON
- # neither this one...
- ]
+ Sets or gets the scope to be used by the search. The value can be one of
+ C<"base">, C<"one"> or C<"sub">. If none is given in the URI then the
+ return value defaults to C<"base">.
- =item * literal ASCII TAB characters in strings
+ =item $uri->_scope( [$new_scope] )
- Literal ASCII TAB characters are now allowed in strings (and treated as
- C<\t>).
+ Same as scope(), but does not default to anything.
- [
- "Hello\tWorld",
- "Hello<TAB>World", # literal <TAB> would not normally be allowed
- ]
+ =item $uri->filter( [$new_filter] )
+
+ Sets or gets the filter to be used by the search. If none is given in
+ the URI then the return value defaults to C<"(objectClass=*)">.
+
+ =item $uri->_filter( [$new_filter] )
+
+ Same as filter(), but does not default to anything.
+
+ =item $uri->extensions( [$etype => $evalue,...] )
+
+ Sets or gets the extensions used for the search. The list passed should
+ be in the form etype1 => evalue1, etype2 => evalue2,... This is also
+ the form of list that is returned.
=back
- =item $json = $json->canonical ([$enable])
+ =head1 SEE ALSO
- =item $enabled = $json->get_canonical
+ L<http://tools.ietf.org/html/rfc2255>
- If C<$enable> is true (or missing), then the C<encode> method will output JSON objects
- by sorting their keys. This is adding a comparatively high overhead.
+ =head1 AUTHOR
- If C<$enable> is false, then the C<encode> method will output key-value
- pairs in the order Perl stores them (which will likely change between runs
- of the same script, and can change even within the same run from 5.18
- onwards).
+ Graham Barr E<lt>F<gbarr@pobox.com>E<gt>
- 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.
+ Slightly modified by Gisle Aas to fit into the URI distribution.
- This setting has no effect when decoding JSON texts.
+ =head1 COPYRIGHT
- This setting has currently no effect on tied hashes.
+ Copyright (c) 1998 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.
- =item $json = $json->allow_nonref ([$enable])
+ =cut
+URI_LDAP
+
+$fatpacked{"URI/ldapi.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_LDAPI';
+ package URI::ldapi;
- =item $enabled = $json->get_allow_nonref
+ use strict;
+ use warnings;
- If C<$enable> is true (or missing), then the C<encode> method can convert a
- non-reference into its corresponding string, number or null JSON value,
- which is an extension to RFC4627. Likewise, C<decode> will accept those JSON
- values instead of croaking.
+ our $VERSION = '1.76';
- If C<$enable> is false, then the C<encode> method will croak if it isn't
- passed an arrayref or hashref, as JSON texts must either be an object
- or array. Likewise, C<decode> will croak if given something that is not a
- JSON object or array.
+ use parent qw(URI::_ldap URI::_generic);
- Example, encode a Perl scalar as JSON value with enabled C<allow_nonref>,
- resulting in an invalid JSON text:
+ require URI::Escape;
- JSON::XS->new->allow_nonref->encode ("Hello, World!")
- => "Hello, World!"
+ sub un_path {
+ my $self = shift;
+ my $old = URI::Escape::uri_unescape($self->authority);
+ if (@_) {
+ my $p = shift;
+ $p =~ s/:/%3A/g;
+ $p =~ s/\@/%40/g;
+ $self->authority($p);
+ }
+ return $old;
+ }
- =item $json = $json->allow_unknown ([$enable])
+ sub _nonldap_canonical {
+ my $self = shift;
+ $self->URI::_generic::canonical(@_);
+ }
- =item $enabled = $json->get_allow_unknown
+ 1;
+URI_LDAPI
+
+$fatpacked{"URI/ldaps.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_LDAPS';
+ package URI::ldaps;
- If C<$enable> is true (or missing), then C<encode> will I<not> throw an
- exception when it encounters values it cannot represent in JSON (for
- example, filehandles) but instead will encode a JSON C<null> value. Note
- that blessed objects are not included here and are handled separately by
- c<allow_nonref>.
+ use strict;
+ use warnings;
- If C<$enable> is false (the default), then C<encode> will throw an
- exception when it encounters anything it cannot encode as JSON.
+ our $VERSION = '1.76';
- This option does not affect C<decode> in any way, and it is recommended to
- leave it off unless you know your communications partner.
+ use parent 'URI::ldap';
- =item $json = $json->allow_blessed ([$enable])
+ sub default_port { 636 }
- =item $enabled = $json->get_allow_blessed
+ sub secure { 1 }
- See L<OBJECT SERIALISATION> for details.
+ 1;
+URI_LDAPS
+
+$fatpacked{"URI/mailto.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_MAILTO';
+ package URI::mailto; # RFC 2368
- If C<$enable> is true (or missing), then the C<encode> method will not
- barf when it encounters a blessed reference that it cannot convert
- otherwise. Instead, a JSON C<null> value is encoded instead of the object.
+ use strict;
+ use warnings;
- If C<$enable> is false (the default), then C<encode> will throw an
- exception when it encounters a blessed object that it cannot convert
- otherwise.
+ our $VERSION = '1.76';
- This setting has no effect on C<decode>.
+ use parent qw(URI URI::_query);
- =item $json = $json->convert_blessed ([$enable])
+ sub to
+ {
+ my $self = shift;
+ my @old = $self->headers;
+ if (@_) {
+ my @new = @old;
+ # get rid of any other to: fields
+ for (my $i = 0; $i < @new; $i += 2) {
+ if (lc($new[$i] || '') eq "to") {
+ splice(@new, $i, 2);
+ redo;
+ }
+ }
- =item $enabled = $json->get_convert_blessed
+ my $to = shift;
+ $to = "" unless defined $to;
+ unshift(@new, "to" => $to);
+ $self->headers(@new);
+ }
+ return unless defined wantarray;
- See L<OBJECT SERIALISATION> for details.
+ my @to;
+ while (@old) {
+ my $h = shift @old;
+ my $v = shift @old;
+ push(@to, $v) if lc($h) eq "to";
+ }
+ join(",", @to);
+ }
- If C<$enable> is true (or missing), then C<encode>, upon encountering a
- blessed object, will check for the availability of the C<TO_JSON> 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.
- The C<TO_JSON> method may safely call die if it wants. If C<TO_JSON>
- returns other blessed objects, those will be handled in the same
- way. C<TO_JSON> must take care of not causing an endless recursion cycle
- (== crash) in this case. The name of C<TO_JSON> 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 any C<to_json>
- function or method.
+ sub headers
+ {
+ my $self = shift;
- If C<$enable> is false (the default), then C<encode> will not consider
- this type of conversion.
+ # The trick is to just treat everything as the query string...
+ my $opaque = "to=" . $self->opaque;
+ $opaque =~ s/\?/&/;
- This setting has no effect on C<decode>.
+ if (@_) {
+ my @new = @_;
+
+ # strip out any "to" fields
+ my @to;
+ for (my $i=0; $i < @new; $i += 2) {
+ if (lc($new[$i] || '') eq "to") {
+ push(@to, (splice(@new, $i, 2))[1]); # remove header
+ redo;
+ }
+ }
- =item $json = $json->allow_tags ([$enable])
+ my $new = join(",",@to);
+ $new =~ s/%/%25/g;
+ $new =~ s/\?/%3F/g;
+ $self->opaque($new);
+ $self->query_form(@new) if @new;
+ }
+ return unless defined wantarray;
- =item $enabled = $json->allow_tags
+ # I am lazy today...
+ URI->new("mailto:?$opaque")->query_form;
+ }
- See L<OBJECT SERIALISATION> for details.
+ 1;
+URI_MAILTO
+
+$fatpacked{"URI/mms.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_MMS';
+ package URI::mms;
- If C<$enable> is true (or missing), then C<encode>, upon encountering a
- blessed object, will check for the availability of the C<FREEZE> method on
- the object's class. If found, it will be used to serialise the object into
- a nonstandard tagged JSON value (that JSON decoders cannot decode).
+ use strict;
+ use warnings;
- It also causes C<decode> to parse such tagged JSON values and deserialise
- them via a call to the C<THAW> method.
+ our $VERSION = '1.76';
- If C<$enable> is false (the default), then C<encode> will not consider
- this type of conversion, and tagged JSON values will cause a parse error
- in C<decode>, as if tags were not part of the grammar.
+ use parent 'URI::http';
- =item $json = $json->filter_json_object ([$coderef->($hashref)])
+ sub default_port { 1755 }
- When C<$coderef> is specified, it will be called from C<decode> each
- time it decodes a JSON object. The only argument 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<not> C<undef>, which is a valid scalar), the
- original deserialised hash will be inserted. This setting can slow down
- decoding considerably.
+ 1;
+URI_MMS
+
+$fatpacked{"URI/news.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_NEWS';
+ package URI::news; # draft-gilman-news-url-01
- When C<$coderef> is omitted or undefined, any existing callback will
- be removed and C<decode> will not change the deserialised hash in any
- way.
+ use strict;
+ use warnings;
- Example, convert all JSON objects into the integer 5:
+ our $VERSION = '1.76';
- my $js = JSON::XS->new->filter_json_object (sub { 5 });
- # returns [5]
- $js->decode ('[{}]')
- # throw an exception because allow_nonref is not enabled
- # so a lone 5 is not allowed.
- $js->decode ('{"a":1, "b":2}');
+ use parent 'URI::_server';
- =item $json = $json->filter_json_single_key_object ($key [=> $coderef->($value)])
+ use URI::Escape qw(uri_unescape);
+ use Carp ();
- Works remotely similar to C<filter_json_object>, but is only called for
- JSON objects having a single key named C<$key>.
+ sub default_port { 119 }
- This C<$coderef> is called before the one specified via
- C<filter_json_object>, 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<undef> but the empty list),
- the callback from C<filter_json_object> will be called next, as if no
- single-key callback were specified.
+ # newsURL = scheme ":" [ news-server ] [ refbygroup | message ]
+ # scheme = "news" | "snews" | "nntp"
+ # news-server = "//" server "/"
+ # refbygroup = group [ "/" messageno [ "-" messageno ] ]
+ # message = local-part "@" domain
- If C<$coderef> is omitted or undefined, the corresponding callback will be
- disabled. There can only ever be one callback for a given key.
+ sub _group
+ {
+ my $self = shift;
+ my $old = $self->path;
+ if (@_) {
+ my($group,$from,$to) = @_;
+ if ($group =~ /\@/) {
+ $group =~ s/^<(.*)>$/$1/; # "<" and ">" should not be part of it
+ }
+ $group =~ s,%,%25,g;
+ $group =~ s,/,%2F,g;
+ my $path = $group;
+ if (defined $from) {
+ $path .= "/$from";
+ $path .= "-$to" if defined $to;
+ }
+ $self->path($path);
+ }
- As this callback gets called less often then the C<filter_json_object>
- 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.
+ $old =~ s,^/,,;
+ if ($old !~ /\@/ && $old =~ s,/(.*),, && wantarray) {
+ my $extra = $1;
+ return (uri_unescape($old), split(/-/, $extra));
+ }
+ uri_unescape($old);
+ }
- 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__" => <id> } >>
- into the corresponding C<< $WIDGET{<id>} >> object:
+ sub group
+ {
+ my $self = shift;
+ if (@_) {
+ Carp::croak("Group name can't contain '\@'") if $_[0] =~ /\@/;
+ }
+ my @old = $self->_group(@_);
+ return if $old[0] =~ /\@/;
+ wantarray ? @old : $old[0];
+ }
- # return whatever is in $WIDGET{5}:
- JSON::XS
- ->new
- ->filter_json_single_key_object (__widget__ => sub {
- $WIDGET{ $_[0] }
- })
- ->decode ('{"__widget__": 5')
+ sub message
+ {
+ my $self = shift;
+ if (@_) {
+ Carp::croak("Message must contain '\@'") unless $_[0] =~ /\@/;
+ }
+ my $old = $self->_group(@_);
+ return undef unless $old =~ /\@/;
+ return $old;
+ }
- # this can be used with a TO_JSON method in some "widget" class
- # for serialisation to json:
- sub WidgetBase::TO_JSON {
- my ($self) = @_;
+ 1;
+URI_NEWS
+
+$fatpacked{"URI/nntp.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_NNTP';
+ package URI::nntp; # draft-gilman-news-url-01
- unless ($self->{id}) {
- $self->{id} = ..get..some..id..;
- $WIDGET{$self->{id}} = $self;
- }
+ use strict;
+ use warnings;
- { __widget__ => $self->{id} }
- }
+ our $VERSION = '1.76';
- =item $json = $json->shrink ([$enable])
+ use parent 'URI::news';
- =item $enabled = $json->get_shrink
+ 1;
+URI_NNTP
+
+$fatpacked{"URI/pop.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_POP';
+ package URI::pop; # RFC 2384
- Perl usually over-allocates memory a bit when allocating space for
- strings. This flag optionally resizes strings generated by either
- C<encode> or C<decode> 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).
+ use strict;
+ use warnings;
- The actual definition of what shrink does might change in future versions,
- but it will always try to save space at the expense of time.
+ our $VERSION = '1.76';
- If C<$enable> is true (or missing), the string returned by C<encode> will
- be shrunk-to-fit, while all strings generated by C<decode> will also be
- shrunk-to-fit.
+ use parent 'URI::_server';
- If C<$enable> is false, then the normal perl allocation algorithms are used.
- If you work with your data, then this is likely to be faster.
+ use URI::Escape qw(uri_unescape);
- In the future, this setting might control other things, such as converting
- strings that look like integers or floats into integers or floats
- internally (there is no difference on the Perl level), saving space.
+ sub default_port { 110 }
- =item $json = $json->max_depth ([$maximum_nesting_depth])
+ #pop://<user>;auth=<auth>@<host>:<port>
- =item $max_depth = $json->get_max_depth
+ sub user
+ {
+ my $self = shift;
+ my $old = $self->userinfo;
- 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.
+ if (@_) {
+ my $new_info = $old;
+ $new_info = "" unless defined $new_info;
+ $new_info =~ s/^[^;]*//;
- 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.
+ my $new = shift;
+ if (!defined($new) && !length($new_info)) {
+ $self->userinfo(undef);
+ } else {
+ $new = "" unless defined $new;
+ $new =~ s/%/%25/g;
+ $new =~ s/;/%3B/g;
+ $self->userinfo("$new$new_info");
+ }
+ }
- Setting the maximum depth to one disallows any nesting, so that ensures
- that the object is only a single hash/object or array.
+ return undef unless defined $old;
+ $old =~ s/;.*//;
+ return uri_unescape($old);
+ }
- If no argument is given, the highest possible setting will be used, which
- is rarely useful.
+ sub auth
+ {
+ my $self = shift;
+ my $old = $self->userinfo;
- 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.
+ if (@_) {
+ my $new = $old;
+ $new = "" unless defined $new;
+ $new =~ s/(^[^;]*)//;
+ my $user = $1;
+ $new =~ s/;auth=[^;]*//i;
+
+
+ my $auth = shift;
+ if (defined $auth) {
+ $auth =~ s/%/%25/g;
+ $auth =~ s/;/%3B/g;
+ $new = ";AUTH=$auth$new";
+ }
+ $self->userinfo("$user$new");
+
+ }
- See SECURITY CONSIDERATIONS, below, for more info on why this is useful.
+ return undef unless defined $old;
+ $old =~ s/^[^;]*//;
+ return uri_unescape($1) if $old =~ /;auth=(.*)/i;
+ return;
+ }
- =item $json = $json->max_size ([$maximum_string_size])
+ 1;
+URI_POP
+
+$fatpacked{"URI/rlogin.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_RLOGIN';
+ package URI::rlogin;
- =item $max_size = $json->get_max_size
+ use strict;
+ use warnings;
- 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<decode>
- 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<encode> (yet).
+ our $VERSION = '1.76';
- If no argument is given, the limit check will be deactivated (same as when
- C<0> is specified).
+ use parent 'URI::_login';
- See SECURITY CONSIDERATIONS, below, for more info on why this is useful.
+ sub default_port { 513 }
- =item $json_text = $json->encode ($perl_scalar)
+ 1;
+URI_RLOGIN
+
+$fatpacked{"URI/rsync.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_RSYNC';
+ package URI::rsync; # http://rsync.samba.org/
- Converts the given Perl value or data structure to its JSON
- representation. Croaks on error.
+ # rsync://[USER@]HOST[:PORT]/SRC
- =item $perl_scalar = $json->decode ($json_text)
+ use strict;
+ use warnings;
- The opposite of C<encode>: expects a JSON text and tries to parse it,
- returning the resulting simple scalar or reference. Croaks on error.
+ our $VERSION = '1.76';
- =item ($perl_scalar, $characters) = $json->decode_prefix ($json_text)
+ use parent qw(URI::_server URI::_userpass);
- This works like the C<decode> 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.
+ sub default_port { 873 }
- This is useful if your JSON texts are not delimited by an outer protocol
- and you need to know where the JSON text ends.
+ 1;
+URI_RSYNC
+
+$fatpacked{"URI/rtsp.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_RTSP';
+ package URI::rtsp;
- JSON::XS->new->decode_prefix ("[1] the tail")
- => ([1], 3)
+ use strict;
+ use warnings;
- =back
+ our $VERSION = '1.76';
+ use parent 'URI::http';
- =head1 INCREMENTAL PARSING
+ sub default_port { 554 }
- In some cases, there is the need for incremental parsing of JSON
- texts. While this module always has to keep both JSON text and resulting
- Perl data structure in memory at one time, it 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<decode_prefix> to see if a full JSON object is available, but
- is much more efficient (and can be implemented with a minimum of method
- calls).
+ 1;
+URI_RTSP
+
+$fatpacked{"URI/rtspu.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_RTSPU';
+ package URI::rtspu;
- JSON::XS 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 mismatched
- parentheses. 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<max_size>) to ensure the parser will stop
- parsing in the presence if syntax errors.
+ use strict;
+ use warnings;
- The following methods implement this incremental parser.
+ our $VERSION = '1.76';
- =over 4
+ use parent 'URI::rtsp';
- =item [void, scalar or list context] = $json->incr_parse ([$string])
+ sub default_port { 554 }
- 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).
+ 1;
+URI_RTSPU
+
+$fatpacked{"URI/sftp.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_SFTP';
+ package URI::sftp;
- If C<$string> is given, then this string is appended to the already
- existing JSON fragment stored in the C<$json> object.
+ use strict;
+ use warnings;
- 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.
+ use parent 'URI::ssh';
- If the method is called in scalar context, then it will try to extract
- exactly I<one> JSON object. If that is successful, it will return this
- object, otherwise it will return C<undef>. If there is a parse error,
- this method will croak just as C<decode> would do (one can then use
- C<incr_skip> to skip the erroneous part). This is the most common way of
- using the method.
+ our $VERSION = '1.76';
- 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 (other than
- whitespace) 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.
+ 1;
+URI_SFTP
+
+$fatpacked{"URI/sip.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_SIP';
+ #
+ # Written by Ryan Kereliuk <ryker@ryker.org>. This file may be
+ # distributed under the same terms as Perl itself.
+ #
+ # The RFC 3261 sip URI is <scheme>:<authority>;<params>?<query>.
+ #
- Example: Parse some JSON arrays/objects in a given string and return
- them.
+ package URI::sip;
- my @objs = JSON::XS->new->incr_parse ("[5][7][1,2]");
+ use strict;
+ use warnings;
- =item $lvalue_string = $json->incr_text
+ use parent qw(URI::_server URI::_userpass);
- This method returns the currently stored JSON fragment as an lvalue, that
- is, you can manipulate it. This I<only> works when a preceding call to
- C<incr_parse> in I<scalar context> 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<will> fail under
- real world conditions). As a special exception, you can also call this
- method before having parsed anything.
+ use URI::Escape qw(uri_unescape);
- That means you can only use this function to look at or manipulate text
- before or after complete JSON objects, not while the parser is in the
- middle of parsing a JSON object.
+ our $VERSION = '1.76';
- 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).
+ sub default_port { 5060 }
- =item $json->incr_skip
+ sub authority
+ {
+ my $self = shift;
+ $$self =~ m,^($URI::scheme_re:)?([^;?]*)(.*)$,os or die;
+ my $old = $2;
- This will reset the state of the incremental parser and will remove
- the parsed text from the input buffer so far. This is useful after
- C<incr_parse> 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.
+ if (@_) {
+ my $auth = shift;
+ $$self = defined($1) ? $1 : "";
+ my $rest = $3;
+ if (defined $auth) {
+ $auth =~ s/([^$URI::uric])/ URI::Escape::escape_char($1)/ego;
+ $$self .= "$auth";
+ }
+ $$self .= $rest;
+ }
+ $old;
+ }
- The difference to C<incr_reset> is that only text until the parse error
- occurred is removed.
+ sub params_form
+ {
+ my $self = shift;
+ $$self =~ m,^((?:$URI::scheme_re:)?)(?:([^;?]*))?(;[^?]*)?(.*)$,os or die;
+ my $paramstr = $3;
- =item $json->incr_reset
+ if (@_) {
+ my @args = @_;
+ $$self = $1 . $2;
+ my $rest = $4;
+ my @new;
+ for (my $i=0; $i < @args; $i += 2) {
+ push(@new, "$args[$i]=$args[$i+1]");
+ }
+ $paramstr = join(";", @new);
+ $$self .= ";" . $paramstr . $rest;
+ }
+ $paramstr =~ s/^;//o;
+ return split(/[;=]/, $paramstr);
+ }
- This completely resets the incremental parser, that is, after this call,
- it will be as if the parser had never parsed anything.
+ sub params
+ {
+ my $self = shift;
+ $$self =~ m,^((?:$URI::scheme_re:)?)(?:([^;?]*))?(;[^?]*)?(.*)$,os or die;
+ my $paramstr = $3;
- 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.
+ if (@_) {
+ my $new = shift;
+ $$self = $1 . $2;
+ my $rest = $4;
+ $$self .= $paramstr . $rest;
+ }
+ $paramstr =~ s/^;//o;
+ return $paramstr;
+ }
+
+ # Inherited methods that make no sense for a SIP URI.
+ sub path {}
+ sub path_query {}
+ sub path_segments {}
+ sub abs { shift }
+ sub rel { shift }
+ sub query_keywords {}
+
+ 1;
+URI_SIP
+
+$fatpacked{"URI/sips.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_SIPS';
+ package URI::sips;
+
+ use strict;
+ use warnings;
+
+ our $VERSION = '1.76';
+
+ use parent 'URI::sip';
+
+ sub default_port { 5061 }
+
+ sub secure { 1 }
+
+ 1;
+URI_SIPS
+
+$fatpacked{"URI/snews.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_SNEWS';
+ package URI::snews; # draft-gilman-news-url-01
+
+ use strict;
+ use warnings;
+
+ our $VERSION = '1.76';
+
+ use parent 'URI::news';
+
+ sub default_port { 563 }
+
+ sub secure { 1 }
+
+ 1;
+URI_SNEWS
+
+$fatpacked{"URI/ssh.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_SSH';
+ package URI::ssh;
+
+ use strict;
+ use warnings;
+
+ our $VERSION = '1.76';
+
+ use parent 'URI::_login';
+
+ # ssh://[USER@]HOST[:PORT]/SRC
+
+ sub default_port { 22 }
+
+ sub secure { 1 }
+
+ 1;
+URI_SSH
+
+$fatpacked{"URI/telnet.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_TELNET';
+ package URI::telnet;
+
+ use strict;
+ use warnings;
+
+ our $VERSION = '1.76';
+
+ use parent 'URI::_login';
+
+ sub default_port { 23 }
+
+ 1;
+URI_TELNET
+
+$fatpacked{"URI/tn3270.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_TN3270';
+ package URI::tn3270;
+
+ use strict;
+ use warnings;
+
+ our $VERSION = '1.76';
+
+ use parent 'URI::_login';
+
+ sub default_port { 23 }
+
+ 1;
+URI_TN3270
+
+$fatpacked{"URI/urn.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_URN';
+ package URI::urn; # RFC 2141
+
+ use strict;
+ use warnings;
+
+ our $VERSION = '1.76';
+
+ use parent 'URI';
+
+ use Carp qw(carp);
+
+ my %implementor;
+ my %require_attempted;
+
+ sub _init {
+ my $class = shift;
+ my $self = $class->SUPER::_init(@_);
+ my $nid = $self->nid;
+
+ my $impclass = $implementor{$nid};
+ return $impclass->_urn_init($self, $nid) if $impclass;
+
+ $impclass = "URI::urn";
+ if ($nid =~ /^[A-Za-z\d][A-Za-z\d\-]*\z/) {
+ my $id = $nid;
+ # make it a legal perl identifier
+ $id =~ s/-/_/g;
+ $id = "_$id" if $id =~ /^\d/;
+
+ $impclass = "URI::urn::$id";
+ no strict 'refs';
+ unless (@{"${impclass}::ISA"}) {
+ if (not exists $require_attempted{$impclass}) {
+ # Try to load it
+ my $_old_error = $@;
+ eval "require $impclass";
+ die $@ if $@ && $@ !~ /Can\'t locate.*in \@INC/;
+ $@ = $_old_error;
+ }
+ $impclass = "URI::urn" unless @{"${impclass}::ISA"};
+ }
+ }
+ else {
+ carp("Illegal namespace identifier '$nid' for URN '$self'") if $^W;
+ }
+ $implementor{$nid} = $impclass;
+
+ return $impclass->_urn_init($self, $nid);
+ }
+
+ sub _urn_init {
+ my($class, $self, $nid) = @_;
+ bless $self, $class;
+ }
+
+ sub _nid {
+ my $self = shift;
+ my $opaque = $self->opaque;
+ if (@_) {
+ my $v = $opaque;
+ my $new = shift;
+ $v =~ s/[^:]*/$new/;
+ $self->opaque($v);
+ # XXX possible rebless
+ }
+ $opaque =~ s/:.*//s;
+ return $opaque;
+ }
+
+ sub nid { # namespace identifier
+ my $self = shift;
+ my $nid = $self->_nid(@_);
+ $nid = lc($nid) if defined($nid);
+ return $nid;
+ }
+
+ sub nss { # namespace specific string
+ my $self = shift;
+ my $opaque = $self->opaque;
+ if (@_) {
+ my $v = $opaque;
+ my $new = shift;
+ if (defined $new) {
+ $v =~ s/(:|\z).*/:$new/;
+ }
+ else {
+ $v =~ s/:.*//s;
+ }
+ $self->opaque($v);
+ }
+ return undef unless $opaque =~ s/^[^:]*://;
+ return $opaque;
+ }
+
+ sub canonical {
+ my $self = shift;
+ my $nid = $self->_nid;
+ my $new = $self->SUPER::canonical;
+ return $new if $nid !~ /[A-Z]/ || $nid =~ /%/;
+ $new = $new->clone if $new == $self;
+ $new->nid(lc($nid));
+ return $new;
+ }
+
+ 1;
+URI_URN
+
+$fatpacked{"URI/urn/isbn.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_URN_ISBN';
+ package URI::urn::isbn; # RFC 3187
+
+ use strict;
+ use warnings;
+
+ our $VERSION = '1.76';
+
+ use parent 'URI::urn';
+
+ use Carp qw(carp);
+
+ BEGIN {
+ require Business::ISBN;
+
+ local $^W = 0; # don't warn about dev versions, perl5.004 style
+ warn "Using Business::ISBN version " . Business::ISBN->VERSION .
+ " which is deprecated.\nUpgrade to Business::ISBN version 2\n"
+ if Business::ISBN->VERSION < 2;
+ }
+
+ sub _isbn {
+ my $nss = shift;
+ $nss = $nss->nss if ref($nss);
+ my $isbn = Business::ISBN->new($nss);
+ $isbn = undef if $isbn && !$isbn->is_valid;
+ return $isbn;
+ }
+
+ sub _nss_isbn {
+ my $self = shift;
+ my $nss = $self->nss(@_);
+ my $isbn = _isbn($nss);
+ $isbn = $isbn->as_string if $isbn;
+ return($nss, $isbn);
+ }
+
+ sub isbn {
+ my $self = shift;
+ my $isbn;
+ (undef, $isbn) = $self->_nss_isbn(@_);
+ return $isbn;
+ }
+
+ sub isbn_publisher_code {
+ my $isbn = shift->_isbn || return undef;
+ return $isbn->publisher_code;
+ }
+
+ BEGIN {
+ my $group_method = do {
+ local $^W = 0; # don't warn about dev versions, perl5.004 style
+ Business::ISBN->VERSION >= 2 ? 'group_code' : 'country_code';
+ };
+
+ sub isbn_group_code {
+ my $isbn = shift->_isbn || return undef;
+ return $isbn->$group_method;
+ }
+ }
+
+ sub isbn_country_code {
+ my $name = (caller(0))[3]; $name =~ s/.*:://;
+ carp "$name is DEPRECATED. Use isbn_group_code instead";
+
+ no strict 'refs';
+ &isbn_group_code;
+ }
+
+ BEGIN {
+ my $isbn13_method = do {
+ local $^W = 0; # don't warn about dev versions, perl5.004 style
+ Business::ISBN->VERSION >= 2 ? 'as_isbn13' : 'as_ean';
+ };
+
+ sub isbn13 {
+ my $isbn = shift->_isbn || return undef;
+
+ # Business::ISBN 1.x didn't put hyphens in the EAN, and it was just a string
+ # Business::ISBN 2.0 doesn't do EAN, but it does ISBN-13 objects
+ # and it uses the hyphens, so call as_string with an empty anon array
+ # or, adjust the test and features to say that it comes out with hyphens.
+ my $thingy = $isbn->$isbn13_method;
+ return eval { $thingy->can( 'as_string' ) } ? $thingy->as_string([]) : $thingy;
+ }
+ }
+
+ sub isbn_as_ean {
+ my $name = (caller(0))[3]; $name =~ s/.*:://;
+ carp "$name is DEPRECATED. Use isbn13 instead";
+
+ no strict 'refs';
+ &isbn13;
+ }
+
+ sub canonical {
+ my $self = shift;
+ my($nss, $isbn) = $self->_nss_isbn;
+ my $new = $self->SUPER::canonical;
+ return $new unless $nss && $isbn && $nss ne $isbn;
+ $new = $new->clone if $new == $self;
+ $new->nss($isbn);
+ return $new;
+ }
+
+ 1;
+URI_URN_ISBN
+
+$fatpacked{"URI/urn/oid.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'URI_URN_OID';
+ package URI::urn::oid; # RFC 2061
+
+ use strict;
+ use warnings;
+
+ our $VERSION = '1.76';
+
+ use parent 'URI::urn';
+
+ sub oid {
+ my $self = shift;
+ my $old = $self->nss;
+ if (@_) {
+ $self->nss(join(".", @_));
+ }
+ return split(/\./, $old) if wantarray;
+ return $old;
+ }
+
+ 1;
+URI_URN_OID
+
+$fatpacked{"Win32/ShellQuote.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'WIN32_SHELLQUOTE';
+ package Win32::ShellQuote;
+ use strict;
+ use warnings FATAL => 'all';
+ use base 'Exporter';
+ use Carp;
+
+ our $VERSION = '0.003001';
+ $VERSION = eval $VERSION;
+
+ our @EXPORT_OK = qw(
+ quote_native
+ quote_cmd
+ quote_system_list
+ quote_system_string
+ quote_system
+ quote_system_cmd
+ quote_literal
+ cmd_escape
+ unquote_native
+ cmd_unescape
+ );
+ our %EXPORT_TAGS = (all => [@EXPORT_OK]);
+
+ sub quote_native {
+ return join q{ }, quote_system_list(@_);
+ }
+
+ sub quote_cmd {
+ return cmd_escape(quote_native(@_));
+ }
+
+ sub quote_system_list {
+ # have to force quoting, or perl might try to use cmd anyway
+ return map { quote_literal($_, 1) } @_;
+ }
+
+ sub quote_system_string {
+ my $args = quote_native(@_);
+
+ if (_has_shell_metachars($args)) {
+ $args = cmd_escape($args);
+ }
+ return $args;
+ }
+
+ sub quote_system {
+ if (@_ > 1) {
+ return quote_system_list(@_);
+ }
+ else {
+ return quote_system_string(@_);
+ }
+ }
+
+ sub quote_system_cmd {
+ # force cmd, even when running through system
+ my $args = quote_native(@_);
+
+ if (! _has_shell_metachars($args)) {
+ # IT BURNS LOOK AWAY
+ return '%PATH:~0,0%' . cmd_escape($args);
+ }
+ return cmd_escape($args);
+ }
+
+
+ sub cmd_escape {
+ my $string = shift;
+ if ($string =~ /[\r\n\0]/) {
+ croak "can't quote newlines to pass through cmd.exe";
+ }
+ $string =~ s/([()%!^"<>&|])/^$1/g;
+ return $string;
+ }
+
+ sub quote_literal {
+ my ($text, $force) = @_;
+
+ # basic argument quoting. uses backslashes and quotes to escape
+ # everything.
+ if (!$force && $text ne '' && $text !~ /[ \t\n\x0b"]/) {
+ # no quoting needed
+ }
+ else {
+ $text =~ s{(\\*)(?="|\z)}{$1$1}g;
+ $text =~ s{"}{\\"}g;
+ $text = qq{"$text"};
+ }
+
+ return $text;
+ }
+
+ # derived from rules in code in win32.c
+ sub _has_shell_metachars {
+ my $string = shift;
+
+ return 1
+ if $string =~ /%/;
+ $string =~ s/(['"]).*?(\1|\z)//sg;
+ return $string =~ /[<>|]/;
+ }
+
+ sub unquote_native {
+ local ($_) = @_;
+ my @argv;
+
+ my $length = length
+ or return @argv;
+
+ m/\G\s*/gc;
+
+ ARGS: until ( pos == $length ) {
+ my $quote_mode;
+ my $arg = '';
+ CHARS: until ( pos == $length ) {
+ if ( m/\G((?:\\\\)+)(?=\\?(")?)/gc ) {
+ if (defined $2) {
+ $arg .= '\\' x (length($1) / 2);
+ }
+ else {
+ $arg .= $1;
+ }
+ }
+ elsif ( m/\G\\"/gc ) {
+ $arg .= '"';
+ }
+ elsif ( m/\G"/gc ) {
+ if ( $quote_mode && m/\G"/gc ) {
+ $arg .= '"';
+ }
+ $quote_mode = !$quote_mode;
+ }
+ elsif ( !$quote_mode && m/\G\s+/gc ) {
+ last;
+ }
+ elsif ( m/\G(.)/sgc ) {
+ $arg .= $1;
+ }
+ }
+ push @argv, $arg;
+ }
+
+ return @argv;
+ }
+
+ sub cmd_unescape {
+ my ($string) = @_;
+
+ no warnings 'uninitialized';
+ $string =~ s/\^(.?)|([^^"]+)|("[^"]*(?:"|\z))/$1$2$3/gs;
+
+ return $string;
+ }
+
+ 1;
+
+ __END__
+
+ =head1 NAME
+
+ Win32::ShellQuote - Quote argument lists for Win32
+
+ =head1 SYNOPSIS
+
+ use Win32::ShellQuote qw(:all);
+
+ system quote_system('program.exe', '--switch', 'argument with spaces or other special characters');
+
+ =head1 DESCRIPTION
+
+ Quotes argument lists to be used in Win32 in several different
+ situations.
+
+ Windows passes its arguments as a single string instead of an array
+ as other platforms do. In almost all cases, the standard Win32
+ L<CommandLineToArgvW|http://msdn.microsoft.com/en-us/library/ms647232.aspx>
+ function is used to parse this string. F<cmd.exe> has different
+ rules for handling quoting, so extra work has to be done if it is
+ involved. It isn't possible to consistantly create a single string
+ that will be handled the same by F<cmd.exe> and the stardard parsing
+ rules.
+
+ Perl will try to detect if you need the shell by detecting shell
+ metacharacters. The routine that checks that uses different quoting
+ rules from both F<cmd.exe> and the native Win32 parsing. Extra
+ work must therefore be done to protect against this autodetection.
+
+ =head1 SUBROUTINES
+
+ =head2 quote_native
+
+ Quotes as a string to pass directly to a program using native methods
+ like L<Win32::Spawn()|Win32>. This is the safest option to use if
+ possible.
+
+ =head2 quote_cmd
+
+ Quotes as a string to be run through F<cmd.exe>, such as in a batch file.
+
+ =head2 quote_system_list
+
+ Quotes as a list to be passed to L<system|perlfunc/system> or
+ L<exec|perlfunc/exec>. This is equally as safe as L</quote_native>,
+ but you must ensure you have more than one item being quoted for
+ the list to be usable with system.
+
+ =head2 quote_system_string
+
+ Like L</quote_system_list>, but returns a single string. Some
+ argument lists cannot be properly quoted using this function.
+
+ =head2 quote_system
+
+ Switches between L</quote_system_list> and L</quote_system_string>
+ based on the number of items quoted.
+
+ =head2 quote_system_cmd
+
+ Quotes as a single string that will always be run with F<cmd.exe>.
+
+ =head2 quote_literal
+
+ Quotes a single parameter in native form.
+
+ =head2 cmd_escape
+
+ Escapes a string to be passed untouched by F<cmd.exe>.
+
+ =head1 CAVEATS
+
+ =over
+
+ =item *
+
+ Newlines (\n or \r) and null (\0) can't be properly quoted when
+ running through F<cmd.exe>.
+
+ =item *
+
+ This module re-implements some under-specified part of the perl
+ internals to accurately perform its work.
=back
- =head2 LIMITATIONS
+ =head1 AUTHOR
- All options that affect decoding are supported, except
- C<allow_nonref>. The reason for this is that it cannot be made to work
- sensibly: JSON objects and arrays are self-delimited, i.e. you can
- concatenate them back to back and still decode them perfectly. This does
- not hold true for JSON numbers, however.
+ haarg - Graham Knop (cpan:HAARG) <haarg@haarg.org>
- For example, is the string C<1> a single JSON number, or is it simply the
- start of C<12>? Or is C<12> a single JSON number, or the concatenation
- of C<1> and C<2>? In neither case you can tell, and this is why JSON::XS
- takes the conservative route and disallows this case.
+ =head1 CONTRIBUTORS
- =head2 EXAMPLES
+ =over 8
- Some examples will make all this clearer. First, a simple example that
- works similarly to C<decode_prefix>: We want to decode the JSON object at
- the start of a string and identify the portion after the JSON object:
+ =item * Mithaldu - Christian Walde (cpan:MITHALDU) <walde.christian@googlemail.com>
- my $text = "[1,2,3] hello";
+ =back
- my $json = new JSON::XS;
+ =head1 COPYRIGHT AND LICENSE
- my $obj = $json->incr_parse ($text)
- or die "expected JSON object or array at beginning of string";
+ Copyright (c) 2012 the L</AUTHOR> and L</CONTRIBUTORS>
+ as listed above.
- my $tail = $json->incr_text;
- # $tail now contains " hello"
+ This is free software; you can redistribute it and/or modify it
+ under the same terms as the Perl 5 programming language system
+ itself.
- Easy, isn't it?
+ =cut
+WIN32_SHELLQUOTE
+
+$fatpacked{"lib/core/only.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LIB_CORE_ONLY';
+ package lib::core::only;
- Now for a more complicated example: Imagine a hypothetical protocol where
- you read some requests from a TCP stream, and each request is a JSON
- array, without any separation between them (in fact, it is often useful to
- use newlines as "separators", as these get interpreted as whitespace at
- the start of the JSON text, which makes it possible to test said protocol
- with C<telnet>...).
+ use strict;
+ use warnings FATAL => 'all';
+ use Config;
- Here is how you'd do it (it is trivial to write this in an event-based
- manner):
+ sub import {
+ @INC = @Config{qw(privlibexp archlibexp)};
+ return
+ }
- my $json = new JSON::XS;
+ =head1 NAME
- # read some data from the socket
- while (sysread $socket, my $buf, 4096) {
+ lib::core::only - Remove all non-core paths from @INC to avoid site/vendor dirs
- # split and decode as many requests as possible
- for my $request ($json->incr_parse ($buf)) {
- # act on the $request
- }
- }
+ =head1 SYNOPSIS
- Another complicated example: Assume you have a string with JSON objects
- or arrays, all separated by (optional) comma characters (e.g. C<[1],[2],
- [3]>). To parse them, we have to skip the commas between the JSON texts,
- and here is where the lvalue-ness of C<incr_text> comes in useful:
+ use lib::core::only; # now @INC contains only the two core directories
- my $text = "[1],[2], [3]";
- my $json = new JSON::XS;
+ To get only the core directories plus the ones for the local::lib in scope:
- # void context, so no parsing done
- $json->incr_parse ($text);
+ $ perl -mlocal::lib -Mlib::core::only -Mlocal::lib=~/perl5 myscript.pl
- # now extract as many objects as possible. note the
- # use of scalar context so incr_text can be called.
- while (my $obj = $json->incr_parse) {
- # do something with $obj
+ To attempt to do a self-contained build (but note this will not reliably
+ propagate into subprocesses, see the CAVEATS below):
- # now skip the optional comma
- $json->incr_text =~ s/^ \s* , //x;
- }
+ $ PERL5OPT='-mlocal::lib -Mlib::core::only -Mlocal::lib=~/perl5' cpan
- Now lets go for a very complex example: Assume that you have a gigantic
- JSON array-of-objects, many gigabytes in size, and you want to parse it,
- but you cannot load it into memory fully (this has actually happened in
- the real world :).
-
- Well, you lost, you have to implement your own JSON parser. But JSON::XS
- can still help you: You implement a (very simple) array parser and let
- JSON decode the array elements, which are all full JSON objects on their
- own (this wouldn't work if the array elements could be JSON numbers, for
- example):
-
- my $json = new JSON::XS;
-
- # open the monster
- open my $fh, "<bigfile.json"
- or die "bigfile: $!";
-
- # first parse the initial "["
- for (;;) {
- sysread $fh, my $buf, 65536
- or die "read error: $!";
- $json->incr_parse ($buf); # void context, so no parsing
-
- # Exit the loop once we found and removed(!) the initial "[".
- # In essence, we are (ab-)using the $json object as a simple scalar
- # we append data to.
- last if $json->incr_text =~ s/^ \s* \[ //x;
- }
+ Please note that it is necessary to use C<local::lib> twice for this to work.
+ First so that C<lib::core::only> doesn't prevent C<local::lib> from loading
+ (it's not currently in core) and then again after C<lib::core::only> so that
+ the local paths are not removed.
- # now we have the skipped the initial "[", so continue
- # parsing all the elements.
- for (;;) {
- # in this loop we read data until we got a single JSON object
- for (;;) {
- if (my $obj = $json->incr_parse) {
- # do something with $obj
- last;
- }
+ =head1 DESCRIPTION
- # add more data
- sysread $fh, my $buf, 65536
- or die "read error: $!";
- $json->incr_parse ($buf); # void context, so no parsing
- }
+ 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".
- # in this loop we read data until we either found and parsed the
- # separating "," between elements, or the final "]"
- for (;;) {
- # first skip whitespace
- $json->incr_text =~ s/^\s*//;
+ You might want to do this to ensure a local::lib contains only the code you
+ need, or to test an L<App::FatPacker|App::FatPacker> tree, or to avoid known
+ bad vendor packages.
- # if we find "]", we are done
- if ($json->incr_text =~ s/^\]//) {
- print "finished.\n";
- exit;
- }
+ 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</CAVEATS>).
- # if we find ",", we can continue with the next element
- if ($json->incr_text =~ s/^,//) {
- last;
- }
+ This module was extracted from L<local::lib|local::lib>'s --self-contained
+ feature, and contains the only part that ever worked. I apologise to anybody
+ who thought anything else did.
- # if we find anything else, we have a parse error!
- if (length $json->incr_text) {
- die "parse error near ", $json->incr_text;
- }
+ =head1 CAVEATS
- # else add more data
- sysread $fh, my $buf, 65536
- or die "read error: $!";
- $json->incr_parse ($buf); # void context, so no parsing
- }
+ This does B<not> propagate properly across perl invocations like local::lib's
+ stuff does. It can't. It's only a module import, so it B<only affects the
+ specific perl VM instance in which you load and import() it>.
- This is a complex example, but most of the complexity comes from the fact
- that we are trying to be correct (bear with me if I am wrong, I never ran
- the above example :).
+ 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
- =head1 MAPPING
+ is unlike to do what you want - it's exactly equivalent to:
- This section describes how JSON::XS maps Perl values to JSON values and
- vice versa. These mappings are designed to "do the right thing" in most
- circumstances automatically, preserving round-tripping characteristics
- (what you put in comes out as something equivalent).
+ perl -Mlib::core::only
- For the more enlightened: note that in the following descriptions,
- lowercase I<perl> refers to the Perl interpreter, while uppercase I<Perl>
- refers to the abstract Perl language itself.
+ 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<lib|lib> module:
+ perl -Mlib::core::only -Mlib=lib
- =head2 JSON -> PERL
+ # or if you're trying to test compiled code:
- =over 4
+ perl -Mlib::core::only -Mblib
- =item object
+ For more information on the impossibility of sanely propagating this across
+ module builds without help from the build program, see
+ L<http://www.shadowcat.co.uk/blog/matt-s-trout/tainted-love> - and for ways
+ to achieve the old --self-contained feature's results, look at
+ L<App::FatPacker|App::FatPacker>'s tree function, and at
+ L<App::cpanminus|cpanm>'s --local-lib-contained feature.
- A JSON object becomes a reference to a hash in Perl. No ordering of object
- keys is preserved (JSON does not preserve object key ordering itself).
+ =head1 AUTHOR
- =item array
+ Matt S. Trout <mst@shadowcat.co.uk>
- A JSON array becomes a reference to an array in Perl.
+ =head1 LICENSE
- =item string
+ This library is free software under the same terms as perl itself.
- 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.
+ =head1 COPYRIGHT
- =item number
+ (c) 2010 the lib::core::only L</AUTHOR> as specified above.
- 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.
+ =cut
- If the number consists of digits only, JSON::XS 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).
+ 1;
+LIB_CORE_ONLY
+
+$fatpacked{"local/lib.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOCAL_LIB';
+ package local::lib;
+ use 5.006;
+ BEGIN {
+ if ($ENV{RELEASE_TESTING}) {
+ require strict;
+ strict->import;
+ require warnings;
+ warnings->import;
+ }
+ }
+ use Config ();
- 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).
+ our $VERSION = '2.000024';
+ $VERSION = eval $VERSION;
- Note that precision is not accuracy - binary floating point values cannot
- represent most decimal fractions exactly, and when converting from and to
- floating point, JSON::XS only guarantees precision up to but not including
- the least significant bit.
+ 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};
+ }
+ my $_archname = $Config::Config{archname};
+ my $_version = $Config::Config{version};
+ my @_inc_version_list = reverse split / /, $Config::Config{inc_version_list};
+ my $_path_sep = $Config::Config{path_sep};
+
+ 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 _perl {
+ if (!$_PERL) {
+ # untaint and validate
+ ($_PERL, my $exe) = $^X =~ /((?:.*$_DIR_SPLIT)?(.+))/;
+ $_PERL = 'perl'
+ if $exe !~ /perl/;
+ if (_is_abs($_PERL)) {
+ }
+ elsif (-x $Config::Config{perlpath}) {
+ $_PERL = $Config::Config{perlpath};
+ }
+ elsif ($_PERL =~ $_DIR_SPLIT && -x $_PERL) {
+ $_PERL = _rel2abs($_PERL);
+ }
+ else {
+ ($_PERL) =
+ map { /(.*)/ }
+ grep { -x $_ }
+ map { ($_, _WIN32 ? ("$_.exe") : ()) }
+ map { join($_DIR_JOIN, $_, $_PERL) }
+ split /\Q$_path_sep\E/, $ENV{PATH};
+ }
+ }
+ $_PERL;
+ }
- =item true, false
+ sub _cwd {
+ if (my $cwd
+ = defined &Cwd::sys_cwd ? \&Cwd::sys_cwd
+ : defined &Cwd::cwd ? \&Cwd::cwd
+ : undef
+ ) {
+ no warnings 'redefine';
+ *_cwd = $cwd;
+ goto &$cwd;
+ }
+ my $drive = shift;
+ return Win32::Cwd()
+ if _WIN32 && defined &Win32::Cwd && !$drive;
+ local @ENV{qw(PATH IFS CDPATH ENV BASH_ENV)};
+ my $cmd = $drive ? "eval { Cwd::getdcwd(q($drive)) }"
+ : 'getcwd';
+ my $perl = _perl;
+ 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;
+ }
+ }
- These JSON atoms become C<Types::Serialiser::true> and
- C<Types::Serialiser::false>, 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<Types::Serialiser::is_bool>
- function (after C<use Types::Serialier>, of course).
+ sub _is_abs {
+ if (_USE_FSPEC) {
+ require File::Spec;
+ File::Spec->file_name_is_absolute($_[0]);
+ }
+ else {
+ $_[0] =~ $_ROOT;
+ }
+ }
- =item null
+ sub _rel2abs {
+ my ($dir, $base) = @_;
+ return $dir
+ if _is_abs($dir);
- A JSON null atom becomes C<undef> in Perl.
+ $base = _WIN32 && $dir =~ s/^([A-Za-z]:)// ? _cwd("$1")
+ : $base ? _rel2abs($base)
+ : _cwd;
+ return _catdir($base, $dir);
+ }
- =item shell-style comments (C<< # I<text> >>)
+ our $_DEVNULL;
+ sub _devnull {
+ return $_DEVNULL ||=
+ _USE_FSPEC ? (require File::Spec, File::Spec->devnull)
+ : _WIN32 ? 'nul'
+ : $^O eq 'os2' ? '/dev/nul'
+ : '/dev/null';
+ }
- As a nonstandard extension to the JSON syntax that is enabled by the
- C<relaxed> setting, shell-style comments are allowed. They can start
- anywhere outside strings and go till the end of the line.
+ sub import {
+ my ($class, @args) = @_;
+ if ($0 eq '-') {
+ push @args, @ARGV;
+ require Cwd;
+ }
- =item tagged values (C<< (I<tag>)I<value> >>).
+ my @steps;
+ my %opts;
+ my %attr;
+ 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/) {
+ 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 eq '--quiet' ) {
+ $attr{quiet} = 1;
+ }
+ elsif ( $arg =~ /^--/ ) {
+ die "Unknown import argument: $arg";
+ }
+ else {
+ push @steps, ['activate', $arg, \%opts];
+ }
+ }
+ if (!@steps) {
+ push @steps, ['activate', undef, \%opts];
+ }
- Another nonstandard extension to the JSON syntax, enabled with the
- C<allow_tags> setting, are tagged values. In this implementation, the
- I<tag> must be a perl package/class name encoded as a JSON string, and the
- I<value> must be a JSON array encoding optional constructor arguments.
+ my $self = $class->new(%attr);
- See L<OBJECT SERIALISATION>, below, for details.
+ 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 quiet { $_[0]->{quiet} }
+
+ 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],
+ (map [$_], @_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, $opts) = @_;
+ $opts ||= {};
+ $self = $self->new unless ref $self;
+ $path = $self->resolve_path($path);
+ $self->ensure_dir_structure_for($path, { quiet => $self->quiet })
+ unless $opts->{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 ($opts->{always} || !@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], { always => 1 });
+ $self->build_environment_vars;
+ }
+ sub build_activate_environment_vars_for {
+ my $self = $_[0]->new->activate($_[1], { always => 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], { always => 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}', qr/["\$]/, '"\\%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', qr/["\$]/, '`%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};
+ }
+
+ # fish has special handling for PATH, CDPATH, and MANPATH. They are always
+ # treated as arrays, and joined with ; when storing the environment. Other
+ # env vars can be arrays, but will be joined without a separator. We only
+ # really care about PATH, but might as well make this routine more general.
+ if ($name =~ /^(?:CD|MAN)?PATH$/) {
+ $value =~ s/$_path_sep/ /g;
+ my $silent = $name =~ /^(?:CD)?PATH$/ ? " ^"._devnull : '';
+ return qq{set -x $name $value$silent;\n};
+ }
+
+ my $out = '';
+ my $value_without = $value;
+ if ($value_without =~ s/(?:^|$_path_sep)\$$name(?:$_path_sep|$)//g) {
+ $out .= qq{set -q $name; and set -x $name $value;\n};
+ $out .= qq{set -q $name; or };
+ }
+ $out .= qq{set -x $name $value_without;\n};
+ $out;
+ }
+
+ 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, $opts) = @_;
+ $opts ||= {};
+ my @dirs;
+ foreach my $dir (
+ $class->lib_paths_for($path),
+ $class->install_base_bin_path($path),
+ ) {
+ my $d = $dir;
+ while (!-d $d) {
+ push @dirs, $d;
+ require File::Basename;
+ $d = File::Basename::dirname($d);
+ }
+ }
+
+ warn "Attempting to create directory ${path}\n"
+ if !$opts->{quiet} && @dirs;
+
+ my %seen;
+ foreach my $dir (reverse @dirs) {
+ next
+ if $seen{$dir}++;
+
+ mkdir $dir
+ or -d $dir
+ or die "Unable to create $dir: $!"
+ }
+ return;
+ }
+
+ sub guess_shelltype {
+ my $shellbin
+ = defined $ENV{SHELL} && length $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 F<.bash_profile> or F<.bashrc> file -
+
+ 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</Differences when using this module under Win32>.
+
+ =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 '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 '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<source ~/.cshrc>.
=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 ...
+
+ If you use F<.bashrc> to activate a local::lib automatically, the local::lib
+ will be re-enabled in any sub-shells used, overriding adjustments you may have
+ made in the parent shell. To avoid this, you can initialize the local::lib in
+ F<.bash_profile> rather than F<.bashrc>, or protect the local::lib invocation
+ with a C<$SHLVL> check:
+
+ [ $SHLVL -eq 1 ] && eval "$(perl -I$HOME/perl5/lib/perl5 -Mlocal::lib)"
+
+ If you are working with several C<local::lib> 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<activated most recently> 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<local::lib> 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 >>:
- =head2 PERL -> JSON
+ 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
- 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.
+ 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<CMD.exe>, 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<App::local::lib::Win32Helper>.
+
+ 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<Invoke-Expression> 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<SHELL>
+ 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 hash references
+ =item PERL_MB_OPT
- 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. JSON::XS can optionally sort the hash keys
- (determined by the I<canonical> 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 PERL_MM_OPT
- =item array references
+ =item PERL5LIB
- Perl array references become JSON arrays.
+ =item PATH
- =item other references
+ =item PERL_LOCAL_LIB_ROOT
- 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<false> and C<true> atoms in JSON.
+ =back
- Since C<JSON::XS> uses the boolean model from L<Types::Serialiser>, you
- can also C<use Types::Serialiser> and then use C<Types::Serialiser::false>
- and C<Types::Serialiser::true> to improve readability.
+ When possible, these will be appended to instead of overwritten entirely.
- use Types::Serialiser;
- encode_json [\0, Types::Serialiser::true] # yields [false,true]
+ These values are then available for reference by any code after import.
- =item Types::Serialiser::true, Types::Serialiser::false
+ =head1 CREATING A SELF-CONTAINED SET OF MODULES
- These special values from the L<Types::Serialiser> module become JSON true
- and JSON false values, respectively. You can also use C<\1> and C<\0>
- directly if you want.
+ See L<lib::core::only> 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).
- =item blessed objects
+ =head1 IMPORT OPTIONS
- Blessed objects are not directly representable in JSON, but C<JSON::XS>
- allows various ways of handling objects. See L<OBJECT SERIALISATION>,
- below, for details.
+ Options are values that can be passed to the C<local::lib> import besides the
+ directory to use. They are specified as C<use local::lib '--option'[, path];>
+ or C<perl -Mlocal::lib=--option[,path]>.
- =item simple scalars
+ =head2 --deactivate
- Simple Perl scalars (any scalar that is not a reference) are the most
- difficult objects to encode: JSON::XS will encode undefined scalars as
- JSON C<null> values, scalars that have last been used in a string context
- before encoding as JSON strings, and anything else as number value:
+ Remove the chosen path (or the default path) from the module search paths if it
+ was added by C<local::lib>, instead of adding it.
- # dump as number
- encode_json [2] # yields [2]
- encode_json [-3.0e17] # yields [-3e+17]
- my $value = 5; encode_json [$value] # yields [5]
+ =head2 --deactivate-all
- # used as string, so dump as string
- print $value;
- encode_json [$value] # yields ["5"]
+ Remove all directories that were added to search paths by C<local::lib> from the
+ search paths.
- # undef becomes null
- encode_json [undef] # yields [null]
+ =head2 --shelltype
- You can force the type to be a JSON string by stringifying it:
+ Specify the shell type to use for output. By default, the shell will be
+ detected based on the environment. Should be one of: C<bourne>, C<csh>,
+ C<cmd>, or C<powershell>.
- 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
+ =head2 --no-create
- You can force the type to be a JSON number by numifying it:
+ Prevents C<local::lib> from creating directories when activating dirs. This is
+ likely to cause issues on Win32 systems.
- 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.
+ =head1 CLASS METHODS
- You can not currently force the type in other, less obscure, ways. Tell me
- if you need this capability (but don't forget to explain why it's needed
- :).
+ =head2 ensure_dir_structure_for
- 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.
+ =over 4
+
+ =item Arguments: $path
+
+ =item Return value: None
=back
- =head2 OBJECT SERIALISATION
+ Attempts to create a local::lib directory, including subdirectories and all
+ required parent directories. Throws an exception on failure.
- As JSON cannot directly represent Perl objects, you have to choose between
- a pure JSON representation (without the ability to deserialise the object
- automatically again), and a nonstandard extension to the JSON syntax,
- tagged values.
+ =head2 print_environment_vars_for
- =head3 SERIALISATION
+ =over 4
+
+ =item Arguments: $path
- What happens when C<JSON::XS> encounters a Perl object depends on the
- C<allow_blessed>, C<convert_blessed> and C<allow_tags> settings, which are
- used in this order:
+ =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 1. C<allow_tags> is enabled and the object has a C<FREEZE> method.
+ =item Arguments: $path
- In this case, C<JSON::XS> uses the L<Types::Serialiser> object
- serialisation protocol to create a tagged JSON value, using a nonstandard
- extension to the JSON syntax.
+ =item Return value: %environment_vars
- This works by invoking the C<FREEZE> method on the object, with the first
- argument being the object to serialise, and the second argument being the
- constant string C<JSON> to distinguish it from other serialisers.
+ =back
- The C<FREEZE> method can return any number of values (i.e. zero or
- more). These values and the paclkage/classname of the object will then be
- encoded as a tagged JSON value in the following format:
+ Returns a hash with the variables listed above, properly set to use the
+ given path as the base directory.
- ("classname")[FREEZE return values...]
+ =head2 setup_env_hash_for
- e.g.:
+ =over 4
- ("URI")["http://www.google.com/"]
- ("MyDate")[2013,10,29]
- ("ImageData::JPEG")["Z3...VlCg=="]
+ =item Arguments: $path
- For example, the hypothetical C<My::Object> C<FREEZE> method might use the
- objects C<type> and C<id> members to encode the object:
+ =item Return value: None
- sub My::Object::FREEZE {
- my ($self, $serialiser) = @_;
+ =back
- ($self->{type}, $self->{id})
- }
+ Constructs the C<%ENV> keys for the given path, by calling
+ L</build_environment_vars_for>.
- =item 2. C<convert_blessed> is enabled and the object has a C<TO_JSON> method.
+ =head2 active_paths
- In this case, the C<TO_JSON> method of the object is invoked in scalar
- context. It must return a single scalar that can be directly encoded into
- JSON. This scalar replaces the object in the JSON text.
+ =over 4
- For example, the following C<TO_JSON> method will convert all L<URI>
- objects to JSON strings when serialised. The fatc that these values
- originally were L<URI> objects is lost.
+ =item Arguments: None
- sub URI::TO_JSON {
- my ($uri) = @_;
- $uri->as_string
- }
+ =item Return value: @paths
- =item 3. C<allow_blessed> is enabled.
+ =back
- The object will be serialised as a JSON null value.
+ Returns a list of active C<local::lib> paths, according to the
+ C<PERL_LOCAL_LIB_ROOT> environment variable and verified against
+ what is really in C<@INC>.
- =item 4. none of the above
+ =head2 install_base_perl_path
- If none of the settings are enabled or the respective methods are missing,
- C<JSON::XS> throws an exception.
+ =over 4
+
+ =item Arguments: $path
+
+ =item Return value: $install_base_perl_path
=back
- =head3 DESERIALISATION
+ Returns a path describing where to install the Perl modules for this local
+ library installation. Appends the directories C<lib> and C<perl5> to the given
+ path.
- For deserialisation there are only two cases to consider: either
- nonstandard tagging was used, in which case C<allow_tags> decides,
- or objects cannot be automatically be deserialised, in which
- case you can use postprocessing or the C<filter_json_object> or
- C<filter_json_single_key_object> callbacks to get some real objects our of
- your JSON.
+ =head2 lib_paths_for
- This section only considers the tagged value case: I a tagged JSON object
- is encountered during decoding and C<allow_tags> is disabled, a parse
- error will result (as if tagged values were not part of the grammar).
+ =over 4
- If C<allow_tags> is enabled, C<JSON::XS> will look up the C<THAW> method
- of the package/classname used during serialisation (it will not attempt
- to load the package as a Perl module). If there is no such method, the
- decoding will fail with an error.
+ =item Arguments: $path
- Otherwise, the C<THAW> method is invoked with the classname as first
- argument, the constant string C<JSON> as second argument, and all the
- values from the JSON array (the values originally returned by the
- C<FREEZE> method) as remaining arguments.
+ =item Return value: @lib_paths
- The method must then return the object. While technically you can return
- any Perl scalar, you might have to enable the C<enable_nonref> setting to
- make that work in all cases, so better return an actual blessed reference.
+ =back
- As an example, let's implement a C<THAW> function that regenerates the
- C<My::Object> from the C<FREEZE> example earlier:
+ 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.
- sub My::Object::THAW {
- my ($class, $serialiser, $type, $id) = @_;
+ =head2 install_base_bin_path
- $class->new (type => $type, id => $id)
- }
+ =over 4
+ =item Arguments: $path
- =head1 ENCODING/CODESET FLAG NOTES
+ =item Return value: $install_base_bin_path
- The interested reader might have seen a number of flags that signify
- encodings or codesets - C<utf8>, C<latin1> and C<ascii>. There seems to be
- some confusion on what these do, so here is a short comparison:
+ =back
- C<utf8> controls whether the JSON text created by C<encode> (and expected
- by C<decode>) is UTF-8 encoded or not, while C<latin1> and C<ascii> only
- control whether C<encode> escapes character values outside their respective
- codeset range. Neither of these flags conflict with each other, although
- some combinations make less sense than others.
+ Returns a path describing where to install the executable programs for this
+ local library installation. Appends the directory C<bin> to the given path.
- Care has been taken to make all flags symmetrical with respect to
- C<encode> and C<decode>, that is, texts encoded with any combination of
- these flag values will be correctly decoded when the same flags are used
- - in general, if you use different flag settings while encoding vs. when
- decoding you likely have a bug somewhere.
+ =head2 installer_options_for
- Below comes a verbose discussion of these flags. Note that a "codeset" is
- simply an abstract set of character-codepoint pairs, while an encoding
- takes those codepoint numbers and I<encodes> them, in our case into
- octets. Unicode is (among other things) a codeset, UTF-8 is an encoding,
- and ISO-8859-1 (= latin 1) and ASCII are both codesets I<and> encodings at
- the same time, which can be confusing.
+ =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 C<utf8> flag disabled
+ =item Arguments: $path
- When C<utf8> is disabled (the default), then C<encode>/C<decode> generate
- and expect Unicode strings, that is, characters with high ordinal Unicode
- values (> 255) will be encoded as such characters, and likewise such
- characters are decoded as-is, no changes to them will be done, except
- "(re-)interpreting" them as Unicode codepoints or Unicode characters,
- respectively (to Perl, these are the same thing in strings unless you do
- funny/weird/dumb stuff).
+ =item Return value: $base_path
- This is useful when you want to do the encoding yourself (e.g. when you
- want to have UTF-16 encoded JSON texts) or when some other layer does
- the encoding for you (for example, when printing to a terminal using a
- filehandle that transparently encodes to UTF-8 you certainly do NOT want
- to UTF-8 encode your data first and have Perl encode it another time).
+ =back
- =item C<utf8> flag enabled
+ Builds and returns the base path into which to set up the local module
+ installation. Defaults to C<~/perl5>.
- If the C<utf8>-flag is enabled, C<encode>/C<decode> will encode all
- characters using the corresponding UTF-8 multi-byte sequence, and will
- expect your input strings to be encoded as UTF-8, that is, no "character"
- of the input string must have any value > 255, as UTF-8 does not allow
- that.
+ =head2 resolve_home_path
- The C<utf8> flag therefore switches between two modes: disabled means you
- will get a Unicode string in Perl, enabled means you get an UTF-8 encoded
- octet/binary string in Perl.
+ =over 4
- =item C<latin1> or C<ascii> flags enabled
+ =item Arguments: $path
- With C<latin1> (or C<ascii>) enabled, C<encode> will escape characters
- with ordinal values > 255 (> 127 with C<ascii>) and encode the remaining
- characters as specified by the C<utf8> flag.
+ =item Return value: $home_path
- If C<utf8> is disabled, then the result is also correctly encoded in those
- character sets (as both are proper subsets of Unicode, meaning that a
- Unicode string with all character values < 256 is the same thing as a
- ISO-8859-1 string, and a Unicode string with all character values < 128 is
- the same thing as an ASCII string in Perl).
+ =back
- If C<utf8> is enabled, you still get a correct UTF-8-encoded string,
- regardless of these flags, just some more characters will be escaped using
- C<\uXXXX> then before.
+ Attempts to find the user's home directory. If installed, uses C<File::HomeDir>
+ for this purpose. If no definite answer is available, throws an exception.
- Note that ISO-8859-1-I<encoded> strings are not compatible with UTF-8
- encoding, while ASCII-encoded strings are. That is because the ISO-8859-1
- encoding is NOT a subset of UTF-8 (despite the ISO-8859-1 I<codeset> being
- a subset of Unicode), while ASCII is.
+ =head2 resolve_relative_path
- Surprisingly, C<decode> will ignore these flags and so treat all input
- values as governed by the C<utf8> flag. If it is disabled, this allows you
- to decode ISO-8859-1- and ASCII-encoded strings, as both strict subsets of
- Unicode. If it is enabled, you can correctly decode UTF-8 encoded strings.
+ =over 4
- So neither C<latin1> nor C<ascii> are incompatible with the C<utf8> flag -
- they only govern when the JSON output engine escapes a character or not.
+ =item Arguments: $path
- The main use for C<latin1> is to relatively efficiently store binary data
- as JSON, at the expense of breaking compatibility with most JSON decoders.
+ =item Return value: $absolute_path
- The main use for C<ascii> is to force the output to not contain characters
- with values > 127, which means you can interpret the resulting string
- as UTF-8, ISO-8859-1, ASCII, KOI8-R or most about any character set and
- 8-bit-encoding, and still get the same data structure back. This is useful
- when your channel for JSON transfer is not 8-bit clean or the encoding
- might be mangled in between (e.g. in mail), and works because ASCII is a
- proper subset of most 8-bit and multibyte encodings in use in the world.
+ =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</resolve_empty_path>, L</resolve_home_path>,
+ L</resolve_relative_path>. Passes the given path argument to
+ L</resolve_empty_path> which then returns a result that is passed to
+ L</resolve_home_path>, which then has its result passed to
+ L</resolve_relative_path>. The result of this final call is returned from
+ L</resolve_path>.
- =head2 JSON and ECMAscript
+ =head1 OBJECT INTERFACE
- JSON syntax is based on how literals are represented in javascript (the
- not-standardised predecessor of ECMAscript) which is presumably why it is
- called "JavaScript Object Notation".
+ =head2 new
- However, JSON is not a subset (and also not a superset of course) of
- ECMAscript (the standard) or javascript (whatever browsers actually
- implement).
+ =over 4
- If you want to use javascript's C<eval> function to "parse" JSON, you
- might run into parse errors for valid JSON texts, or the resulting data
- structure might not be queryable:
+ =item Arguments: %attributes
- One of the problems is that U+2028 and U+2029 are valid characters inside
- JSON strings, but are not allowed in ECMAscript string literals, so the
- following Perl fragment will not output something that can be guaranteed
- to be parsable by javascript's C<eval>:
+ =item Return value: $local_lib
- use JSON::XS;
+ =back
+
+ Constructs a new C<local::lib> object, representing the current state of
+ C<@INC> and the relevant environment variables.
- print encode_json [chr 0x2028];
+ =head1 ATTRIBUTES
- The right fix for this is to use a proper JSON parser in your javascript
- programs, and not rely on C<eval> (see for example Douglas Crockford's
- F<json2.js> parser).
+ =head2 roots
- If this is not an option, you can, as a stop-gap measure, simply encode to
- ASCII-only JSON:
+ An arrayref representing active C<local::lib> directories.
- use JSON::XS;
+ =head2 inc
- print JSON::XS->new->ascii->encode ([chr 0x2028]);
+ An arrayref representing C<@INC>.
- Note that this will enlarge the resulting JSON text quite a bit if you
- have many non-ASCII characters. You might be tempted to run some regexes
- to only escape U+2028 and U+2029, e.g.:
+ =head2 libs
- # DO NOT USE THIS!
- my $json = JSON::XS->new->utf8->encode ([chr 0x2028]);
- $json =~ s/\xe2\x80\xa8/\\u2028/g; # escape U+2028
- $json =~ s/\xe2\x80\xa9/\\u2029/g; # escape U+2029
- print $json;
+ An arrayref representing the PERL5LIB environment variable.
- Note that I<this is a bad idea>: the above only works for U+2028 and
- U+2029 and thus only for fully ECMAscript-compliant parsers. Many existing
- javascript implementations, however, have issues with other characters as
- well - using C<eval> naively simply I<will> cause problems.
+ =head2 bins
- Another problem is that some javascript implementations reserve
- some property names for their own purposes (which probably makes
- them non-ECMAscript-compliant). For example, Iceweasel reserves the
- C<__proto__> property name for its own purposes.
+ An arrayref representing the PATH environment variable.
- If that is a problem, you could parse try to filter the resulting JSON
- output for these property strings, e.g.:
+ =head2 extra
- $json =~ s/"__proto__"\s*:/"__proto__renamed":/g;
+ A hashref of extra environment variables (e.g. C<PERL_MM_OPT> and
+ C<PERL_MB_OPT>)
- This works because C<__proto__> is not valid outside of strings, so every
- occurrence of C<"__proto__"\s*:> must be a string used as property name.
+ =head2 no_create
- If you know of other incompatibilities, please let me know.
+ If set, C<local::lib> will not try to create directories when activating them.
+ =head1 OBJECT METHODS
+
+ =head2 clone
- =head2 JSON and YAML
+ =over 4
- You often hear that JSON is a subset of YAML. This is, however, a mass
- hysteria(*) and very far from the truth (as of the time of this writing),
- so let me state it clearly: I<in general, there is no way to configure
- JSON::XS to output a data structure as valid YAML> that works in all
- cases.
+ =item Arguments: %attributes
- If you really must use JSON::XS to generate YAML, you should use this
- algorithm (subject to change in future versions):
+ =item Return value: $local_lib
- my $to_yaml = JSON::XS->new->utf8->space_after (1);
- my $yaml = $to_yaml->encode ($ref) . "\n";
+ =back
- This will I<usually> generate JSON texts that also parse as valid
- YAML. Please note that YAML has hardcoded limits on (simple) object key
- lengths that JSON doesn't have and also has different and incompatible
- unicode character escape syntax, so you should make sure that your hash
- keys are noticeably shorter than the 1024 "stream characters" YAML allows
- and that you do not have characters with codepoint values outside the
- Unicode BMP (basic multilingual page). YAML also does not allow C<\/>
- sequences in strings (which JSON::XS does not I<currently> generate, but
- other JSON generators might).
+ Constructs a new C<local::lib> object based on the existing one, overriding the
+ specified attributes.
- There might be other incompatibilities that I am not aware of (or the YAML
- specification has been changed yet again - it does so quite often). In
- general you should not try to generate YAML with a JSON generator or vice
- versa, or try to parse JSON with a YAML parser or vice versa: chances are
- high that you will run into severe interoperability problems when you
- least expect it.
+ =head2 activate
=over 4
- =item (*)
-
- I have been pressured multiple times by Brian Ingerson (one of the
- authors of the YAML specification) to remove this paragraph, despite him
- acknowledging that the actual incompatibilities exist. As I was personally
- bitten by this "JSON is YAML" lie, I refused and said I will continue to
- educate people about these issues, so others do not run into the same
- problem again and again. After this, Brian called me a (quote)I<complete
- and worthless idiot>(unquote).
-
- In my opinion, instead of pressuring and insulting people who actually
- clarify issues with YAML and the wrong statements of some of its
- proponents, I would kindly suggest reading the JSON spec (which is not
- that difficult or long) and finally make YAML compatible to it, and
- educating users about the changes, instead of spreading lies about the
- real compatibility for many I<years> and trying to silence people who
- point out that it isn't true.
-
- Addendum/2009: the YAML 1.2 spec is still incompatible with JSON, even
- though the incompatibilities have been documented (and are known to Brian)
- for many years and the spec makes explicit claims that YAML is a superset
- of JSON. It would be so easy to fix, but apparently, bullying people and
- corrupting userdata is so much easier.
+ =item Arguments: $path
+
+ =item Return value: $new_local_lib
=back
+ Constructs a new instance with the specified path active.
- =head2 SPEED
+ =head2 deactivate
- It seems that JSON::XS is surprisingly fast, as shown in the following
- tables. They have been generated with the help of the C<eg/bench> program
- in the JSON::XS distribution, to make it easy to compare on your own
- system.
+ =over 4
- First comes a comparison between various modules using
- a very short single-line JSON string (also available at
- L<http://dist.schmorp.de/misc/json/short.json>).
-
- {"method": "handleMessage", "params": ["user1",
- "we were just talking"], "id": null, "array":[1,11,234,-5,1e5,1e7,
- 1, 0]}
-
- It shows the number of encodes/decodes per second (JSON::XS uses
- the functional interface, while JSON::XS/2 uses the OO interface
- with pretty-printing and hashkey sorting enabled, JSON::XS/3 enables
- shrink. JSON::DWIW/DS uses the deserialise function, while JSON::DWIW::FJ
- uses the from_json method). Higher is better:
-
- module | encode | decode |
- --------------|------------|------------|
- JSON::DWIW/DS | 86302.551 | 102300.098 |
- JSON::DWIW/FJ | 86302.551 | 75983.768 |
- JSON::PP | 15827.562 | 6638.658 |
- JSON::Syck | 63358.066 | 47662.545 |
- JSON::XS | 511500.488 | 511500.488 |
- JSON::XS/2 | 291271.111 | 388361.481 |
- JSON::XS/3 | 361577.931 | 361577.931 |
- Storable | 66788.280 | 265462.278 |
- --------------+------------+------------+
-
- That is, JSON::XS is almost six times faster than JSON::DWIW on encoding,
- about five times faster on decoding, and over thirty to seventy times
- faster than JSON's pure perl implementation. It also compares favourably
- to Storable for small amounts of data.
-
- Using a longer test string (roughly 18KB, generated from Yahoo! Locals
- search API (L<http://dist.schmorp.de/misc/json/long.json>).
-
- module | encode | decode |
- --------------|------------|------------|
- JSON::DWIW/DS | 1647.927 | 2673.916 |
- JSON::DWIW/FJ | 1630.249 | 2596.128 |
- JSON::PP | 400.640 | 62.311 |
- JSON::Syck | 1481.040 | 1524.869 |
- JSON::XS | 20661.596 | 9541.183 |
- JSON::XS/2 | 10683.403 | 9416.938 |
- JSON::XS/3 | 20661.596 | 9400.054 |
- Storable | 19765.806 | 10000.725 |
- --------------+------------+------------+
-
- Again, JSON::XS leads by far (except for Storable which non-surprisingly
- decodes a bit faster).
-
- On large strings containing lots of high Unicode characters, some modules
- (such as JSON::PC) seem to decode faster than JSON::XS, but the result
- will be broken due to missing (or wrong) Unicode handling. Others refuse
- to decode or encode properly, so it was impossible to prepare a fair
- comparison table for that case.
-
-
- =head1 SECURITY CONSIDERATIONS
-
- When you are using JSON in a protocol, talking to untrusted potentially
- hostile creatures requires relatively few measures.
-
- First of all, your JSON decoder should be secure, that is, should not have
- any buffer overflows. Obviously, this module should ensure that and I am
- trying hard on making that true, but you never know.
-
- Second, you need to avoid resource-starving attacks. That means you should
- limit the size of JSON texts you accept, or make sure then when your
- resources run out, that's just fine (e.g. by using a separate process that
- can crash safely). The size of a JSON text in octets or characters is
- usually a good indication of the size of the resources required to decode
- it into a Perl structure. While JSON::XS can check the size of the JSON
- text, it might be too late when you already have it in memory, so you
- might want to check the size before you accept the string.
-
- Third, JSON::XS recurses using the C stack when decoding objects and
- arrays. The C stack is a limited resource: for instance, on my amd64
- machine with 8MB of stack size I can decode around 180k nested arrays but
- only 14k nested JSON objects (due to perl itself recursing deeply on croak
- to free the temporary). If that is exceeded, the program crashes. To be
- conservative, the default nesting limit is set to 512. If your process
- has a smaller stack, you should adjust this setting accordingly with the
- C<max_depth> method.
-
- Something else could bomb you, too, that I forgot to think of. In that
- case, you get to keep the pieces. I am always open for hints, though...
-
- Also keep in mind that JSON::XS might leak contents of your Perl data
- structures in its error messages, so when you serialise sensitive
- information you might want to make sure that exceptions thrown by JSON::XS
- will not end up in front of untrusted eyes.
-
- If you are using JSON::XS to return packets to consumption
- by JavaScript scripts in a browser you should have a look at
- L<http://blog.archive.jpsykes.com/47/practical-csrf-and-json-security/> to
- see whether you are vulnerable to some common attack vectors (which really
- are browser design bugs, but it is still you who will have to deal with
- it, as major browser developers care only for features, not about getting
- security right).
-
-
- =head1 "OLD" VS. "NEW" JSON (RFC 4627 VS. RFC 7159)
-
- TL;DR: Due to security concerns, JSON::XS will not allow scalar data in
- JSON texts by default - you need to create your own JSON::XS object and
- enable C<allow_nonref>:
-
-
- my $json = JSON::XS->new->allow_nonref;
-
- $text = $json->encode ($data);
- $data = $json->decode ($text);
+ =item Arguments: $path
- The long version: JSON being an important and supposedly stable format,
- the IETF standardised it as RFC 4627 in 2006. Unfortunately, the inventor
- of JSON, Dougles Crockford, unilaterally changed the definition of JSON in
- javascript. Rather than create a fork, the IETF decided to standardise the
- new syntax (apparently, so Iw as told, without finding it very amusing).
+ =item Return value: $new_local_lib
- The biggest difference between thed original JSON and the new JSON is that
- the new JSON supports scalars (anything other than arrays and objects) at
- the toplevel of a JSON text. While this is strictly backwards compatible
- to older versions, it breaks a number of protocols that relied on sending
- JSON back-to-back, and is a minor security concern.
+ =back
- For example, imagine you have two banks communicating, and on one side,
- trhe JSON coder gets upgraded. Two messages, such as C<10> and C<1000>
- might then be confused to mean C<101000>, something that couldn't happen
- in the original JSON, because niether of these messages would be valid
- JSON.
+ Constructs a new instance with the specified path deactivated.
- If one side accepts these messages, then an upgrade in the coder on either
- side could result in this becoming exploitable.
+ =head2 deactivate_all
- This module has always allowed these messages as an optional extension, by
- default disabled. The security concerns are the reason why the default is
- still disabled, but future versions might/will likely upgrade to the newer
- RFC as default format, so you are advised to check your implementation
- and/or override the default with C<< ->allow_nonref (0) >> to ensure that
- future versions are safe.
+ =over 4
+ =item Arguments: None
- =head1 INTEROPERABILITY WITH OTHER MODULES
+ =item Return value: $new_local_lib
- C<JSON::XS> uses the L<Types::Serialiser> module to provide boolean
- constants. That means that the JSON true and false values will be
- comaptible to true and false values of other modules that do the same,
- such as L<JSON::PP> and L<CBOR::XS>.
+ =back
+ Constructs a new instance with all C<local::lib> directories deactivated.
- =head1 INTEROPERABILITY WITH OTHER JSON DECODERS
+ =head2 environment_vars_string
- As long as you only serialise data that can be directly expressed in JSON,
- C<JSON::XS> is incapable of generating invalid JSON output (modulo bugs,
- but C<JSON::XS> has found more bugs in the official JSON testsuite (1)
- than the official JSON testsuite has found in C<JSON::XS> (0)).
+ =over 4
- When you have trouble decoding JSON generated by this module using other
- decoders, then it is very likely that you have an encoding mismatch or the
- other decoder is broken.
+ =item Arguments: [ $shelltype ]
- When decoding, C<JSON::XS> is strict by default and will likely catch all
- errors. There are currently two settings that change this: C<relaxed>
- makes C<JSON::XS> accept (but not generate) some non-standard extensions,
- and C<allow_tags> will allow you to encode and decode Perl objects, at the
- cost of not outputting valid JSON anymore.
+ =item Return value: $shell_env_string
- =head2 TAGGED VALUE SYNTAX AND STANDARD JSON EN/DECODERS
+ =back
- When you use C<allow_tags> to use the extended (and also nonstandard and
- invalid) JSON syntax for serialised objects, and you still want to decode
- the generated When you want to serialise objects, you can run a regex
- to replace the tagged syntax by standard JSON arrays (it only works for
- "normal" package names without comma, newlines or single colons). First,
- the readable Perl version:
+ Returns a string to set up the C<local::lib>, meant to be run by a shell.
- # if your FREEZE methods return no values, you need this replace first:
- $json =~ s/\( \s* (" (?: [^\\":,]+|\\.|::)* ") \s* \) \s* \[\s*\]/[$1]/gx;
+ =head2 build_environment_vars
- # this works for non-empty constructor arg lists:
- $json =~ s/\( \s* (" (?: [^\\":,]+|\\.|::)* ") \s* \) \s* \[/[$1,/gx;
+ =over 4
- And here is a less readable version that is easy to adapt to other
- languages:
+ =item Arguments: None
- $json =~ s/\(\s*("([^\\":,]+|\\.|::)*")\s*\)\s*\[/[$1,/g;
+ =item Return value: %environment_vars
- Here is an ECMAScript version (same regex):
+ =back
- json = json.replace (/\(\s*("([^\\":,]+|\\.|::)*")\s*\)\s*\[/g, "[$1,");
+ Returns a hash with the variables listed above, properly set to use the
+ given path as the base directory.
- Since this syntax converts to standard JSON arrays, it might be hard to
- distinguish serialised objects from normal arrays. You can prepend a
- "magic number" as first array element to reduce chances of a collision:
+ =head2 setup_env_hash
- $json =~ s/\(\s*("([^\\":,]+|\\.|::)*")\s*\)\s*\[/["XU1peReLzT4ggEllLanBYq4G9VzliwKF",$1,/g;
+ =over 4
- And after decoding the JSON text, you could walk the data
- structure looking for arrays with a first element of
- C<XU1peReLzT4ggEllLanBYq4G9VzliwKF>.
+ =item Arguments: None
- The same approach can be used to create the tagged format with another
- encoder. First, you create an array with the magic string as first member,
- the classname as second, and constructor arguments last, encode it as part
- of your JSON structure, and then:
+ =item Return value: None
- $json =~ s/\[\s*"XU1peReLzT4ggEllLanBYq4G9VzliwKF"\s*,\s*("([^\\":,]+|\\.|::)*")\s*,/($1)[/g;
+ =back
- Again, this has some limitations - the magic string must not be encoded
- with character escapes, and the constructor arguments must be non-empty.
+ Constructs the C<%ENV> keys for the given path, by calling
+ L</build_environment_vars>.
+ =head2 setup_local_lib
- =head1 RFC7159
+ Constructs the C<%ENV> hash using L</setup_env_hash>, and set up C<@INC>.
- Since this module was written, Google has written a new JSON RFC, RFC 7159
- (and RFC7158). Unfortunately, this RFC breaks compatibility with both the
- original JSON specification on www.json.org and RFC4627.
+ =head1 A WARNING ABOUT UNINST=1
- As far as I can see, you can get partial compatibility when parsing by
- using C<< ->allow_nonref >>. However, consider the security implications
- of doing so.
+ 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.
- I haven't decided yet when to break compatibility with RFC4627 by default
- (and potentially leave applications insecure) and change the default to
- follow RFC7159, but application authors are well advised to call C<<
- ->allow_nonref(0) >> even if this is the current default, if they cannot
- handle non-reference values, in preparation for the day when the default
- will change.
+ =head1 LIMITATIONS
+ =over 4
- =head1 THREADS
+ =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<after> 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<SHELL> 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<File::Spec>.
+ This means any L<File::Spec> version installed in the local::lib will be
+ ignored by scripts using local::lib. A workaround for this is using
+ C<use lib "$local_lib/lib/perl5";> instead of using C<local::lib> directly.
+
+ =item * Conflicts with L<ExtUtils::MakeMaker>'s C<PREFIX> option.
+ C<local::lib> uses the C<INSTALL_BASE> option, as it has more predictable and
+ sane behavior. If something attempts to use the C<PREFIX> option when running
+ a F<Makefile.PL>, L<ExtUtils::MakeMaker> will refuse to run, as the two
+ options conflict. This can be worked around by temporarily unsetting the
+ C<PERL_MM_OPT> environment variable.
+
+ =item * Conflicts with L<Module::Build>'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<PERL_MB_OPT>
+ environment variable.
- This module is I<not> guaranteed to be thread safe and there are no
- plans to change this until Perl gets thread support (as opposed to the
- horribly slow so-called "threads" which are simply slow and bloated
- process simulations - use fork, it's I<much> faster, cheaper, better).
+ =back
- (It might actually work, but you have been warned).
+ Patches very much welcome for any of the above.
+ =over 4
- =head1 THE PERILS OF SETLOCALE
+ =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.
- Sometimes people avoid the Perl locale support and directly call the
- system's setlocale function with C<LC_ALL>.
+ =back
- This breaks both perl and modules such as JSON::XS, as stringification of
- numbers no longer works correctly (e.g. C<$x = 0.1; print "$x"+1> might
- print C<1>, and JSON::XS might output illegal JSON as JSON::XS relies on
- perl to stringify numbers).
+ =head1 TROUBLESHOOTING
- The solution is simple: don't call C<setlocale>, or use it for only those
- categories you need, such as C<LC_MESSAGES> or C<LC_CTYPE>.
+ 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<cpan
+ -i Foo::Bar>, but it fails with an error like: C<Warning: You do not have
+ permissions to install into /usr/lib64/perl5/site_perl/5.8.8/x86_64-linux at
+ /usr/lib64/perl5/5.8.8/Foo/Bar.pm> 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.
- If you need C<LC_NUMERIC>, you should enable it only around the code that
- actually needs it (avoiding stringification of numbers), and restore it
- afterwards.
+ To remedy this situation, rerun the bootstrapping procedure documented above.
+ Then, run C<rm -r ~/.cpan/build/Foo-Bar*>
- =head1 BUGS
+ Finally, re-run C<cpan -i Foo::Bar> and it should install without problems.
- While the goal of this module is to be correct, that unfortunately does
- not mean it's bug-free, only that I think its design is bug-free. If you
- keep reporting bugs they will be fixed swiftly, though.
+ =head1 ENVIRONMENT
- Please refrain from using rt.cpan.org or any other bug reporting
- service. I put the contact address into my modules for a reason.
+ =over 4
- =cut
+ =item SHELL
- BEGIN {
- *true = \$Types::Serialiser::true;
- *true = \&Types::Serialiser::true;
- *false = \$Types::Serialiser::false;
- *false = \&Types::Serialiser::false;
- *is_bool = \&Types::Serialiser::is_bool;
+ =item COMSPEC
- *JSON::XS::Boolean:: = *Types::Serialiser::Boolean::;
- }
+ local::lib looks at the user's C<SHELL> environment variable when printing out
+ commands to add to the shell configuration file.
- XSLoader::load "JSON::XS", $VERSION;
+ On Win32 systems, C<COMSPEC> is also examined.
+
+ =back
=head1 SEE ALSO
- The F<json_xs> command line utility for quick experiments.
+ =over 4
+
+ =item * L<Perl Advent article, 2011|http://perladvent.org/2011/2011-12-01.html>
+
+ =back
+
+ =head1 SUPPORT
+
+ IRC:
+
+ Join #toolchain on irc.perl.org.
=head1 AUTHOR
- Marc Lehmann <schmorp@schmorp.de>
- http://home.schmorp.de/
+ Matt S Trout <mst@shadowcat.co.uk> http://www.shadowcat.co.uk/
- =cut
+ 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 <apeiron@cpan.org>.
+
+ Doc patches for a custom local::lib directory, more cleanups in the english
+ documentation and a L<german documentation|POD2::DE::local::lib> contributed by
+ Torsten Raudssus <torsten@raudssus.de>.
+
+ Hans Dieter Pearcey <hdp@cpan.org> 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 <csjewell@cpan.org>.
+
+ Warnings for missing PATH/PERL5LIB (as when not running interactively) silenced
+ by a patch from Marco Emilio Poleggi.
+
+ Mark Stosberg <mark@summersault.com> provided the code for the now deleted
+ '--self-contained' option.
+
+ Documentation patches to make win32 usage clearer by
+ David Mertens <dcmertens.perl@gmail.com> (run4flat).
- 1
+ Brazilian L<portuguese translation|POD2::PT_BR::local::lib> and minor doc
+ patches contributed by Breno G. de Oliveira <garu@cpan.org>.
-X86_64-LINUX-GNU-THREAD-MULTI_JSON_XS
+ Improvements to stacking multiple local::lib dirs and removing them from the
+ environment later on contributed by Andrew Rodland <arodland@cpan.org>.
+
+ Patch for Carp version mismatch contributed by Hakim Cassimally
+ <osfameron@cpan.org>.
+
+ Rewrite of internals and numerous bug fixes and added features contributed by
+ Graham Knop <haarg@haarg.org>.
+
+ =head1 COPYRIGHT
+
+ Copyright (c) 2007 - 2013 the local::lib L</AUTHOR> and L</CONTRIBUTORS> 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{"x86_64-linux-gnu-thread-multi/JSON/XS/Boolean.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'X86_64-LINUX-GNU-THREAD-MULTI_JSON_XS_BOOLEAN';
+$fatpacked{"x86_64-linux-gnu-thread-multi/Socket.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'X86_64-LINUX-GNU-THREAD-MULTI_SOCKET';
+ package Socket;
+
+ use strict;
+ { use 5.006001; }
+
+ our $VERSION = '2.029';
+
=head1 NAME
- JSON::XS::Boolean - dummy module providing JSON::XS::Boolean
+ C<Socket> - networking constants and support functions
=head1 SYNOPSIS
- # do not "use" yourself
+ C<Socket> a low-level module used by, among other things, the L<IO::Socket>
+ family of modules. The following examples demonstrate some low-level uses but
+ a practical program would likely use the higher-level API provided by
+ C<IO::Socket> or similar instead.
+
+ use Socket qw(PF_INET SOCK_STREAM pack_sockaddr_in inet_aton);
+
+ socket(my $socket, PF_INET, SOCK_STREAM, 0)
+ or die "socket: $!";
+
+ my $port = getservbyname "echo", "tcp";
+ connect($socket, pack_sockaddr_in($port, inet_aton("localhost")))
+ or die "connect: $!";
+
+ print $socket "Hello, world!\n";
+ print <$socket>;
+
+ See also the L</EXAMPLES> section.
=head1 DESCRIPTION
- This module exists only to provide overload resolution for Storable and
- similar modules. It's only needed for compatibility with data serialised
- (by other modules such as Storable) that was decoded by JSON::XS versions
- before 3.0.
+ This module provides a variety of constants, structure manipulators and other
+ functions related to socket-based networking. The values and functions
+ provided are useful when used in conjunction with Perl core functions such as
+ socket(), setsockopt() and bind(). It also provides several other support
+ functions, mostly for dealing with conversions of network addresses between
+ human-readable and native binary forms, and for hostname resolver operations.
+
+ Some constants and functions are exported by default by this module; but for
+ backward-compatibility any recently-added symbols are not exported by default
+ and must be requested explicitly. When an import list is provided to the
+ C<use Socket> line, the default exports are not automatically imported. It is
+ therefore best practice to always to explicitly list all the symbols required.
+
+ Also, some common socket "newline" constants are provided: the constants
+ C<CR>, C<LF>, and C<CRLF>, as well as C<$CR>, C<$LF>, and C<$CRLF>, which map
+ to C<\015>, C<\012>, and C<\015\012>. If you do not want to use the literal
+ characters in your programs, then use the constants provided here. They are
+ not exported by default, but can be imported individually, and with the
+ C<:crlf> export tag:
+
+ use Socket qw(:DEFAULT :crlf);
+
+ $sock->print("GET / HTTP/1.0$CRLF");
- Since 3.0, JSON::PP::Boolean has replaced it. Support for
- JSON::XS::Boolean will be removed in a future release.
+ The entire getaddrinfo() subsystem can be exported using the tag C<:addrinfo>;
+ this exports the getaddrinfo() and getnameinfo() functions, and all the
+ C<AI_*>, C<NI_*>, C<NIx_*> and C<EAI_*> constants.
=cut
- use JSON::XS ();
+ =head1 CONSTANTS
- 1;
+ In each of the following groups, there may be many more constants provided
+ than just the ones given as examples in the section heading. If the heading
+ ends C<...> then this means there are likely more; the exact constants
+ provided will depend on the OS and headers found at compile-time.
+
+ =cut
+
+ =head2 PF_INET, PF_INET6, PF_UNIX, ...
+
+ Protocol family constants to use as the first argument to socket() or the
+ value of the C<SO_DOMAIN> or C<SO_FAMILY> socket option.
+
+ =head2 AF_INET, AF_INET6, AF_UNIX, ...
+
+ Address family constants used by the socket address structures, to pass to
+ such functions as inet_pton() or getaddrinfo(), or are returned by such
+ functions as sockaddr_family().
+
+ =head2 SOCK_STREAM, SOCK_DGRAM, SOCK_RAW, ...
+
+ Socket type constants to use as the second argument to socket(), or the value
+ of the C<SO_TYPE> socket option.
+
+ =head2 SOCK_NONBLOCK. SOCK_CLOEXEC
+
+ Linux-specific shortcuts to specify the C<O_NONBLOCK> and C<FD_CLOEXEC> flags
+ during a C<socket(2)> call.
+
+ socket( my $sockh, PF_INET, SOCK_DGRAM|SOCK_NONBLOCK, 0 )
+
+ =head2 SOL_SOCKET
+
+ Socket option level constant for setsockopt() and getsockopt().
+
+ =head2 SO_ACCEPTCONN, SO_BROADCAST, SO_ERROR, ...
+
+ Socket option name constants for setsockopt() and getsockopt() at the
+ C<SOL_SOCKET> level.
+
+ =head2 IP_OPTIONS, IP_TOS, IP_TTL, ...
+
+ Socket option name constants for IPv4 socket options at the C<IPPROTO_IP>
+ level.
+
+ =head2 IP_PMTUDISC_WANT, IP_PMTUDISC_DONT, ...
+
+ Socket option value contants for C<IP_MTU_DISCOVER> socket option.
+
+ =head2 IPTOS_LOWDELAY, IPTOS_THROUGHPUT, IPTOS_RELIABILITY, ...
+
+ Socket option value constants for C<IP_TOS> socket option.
+
+ =head2 MSG_BCAST, MSG_OOB, MSG_TRUNC, ...
+
+ Message flag constants for send() and recv().
+
+ =head2 SHUT_RD, SHUT_RDWR, SHUT_WR
+
+ Direction constants for shutdown().
+
+ =head2 INADDR_ANY, INADDR_BROADCAST, INADDR_LOOPBACK, INADDR_NONE
+
+ Constants giving the special C<AF_INET> addresses for wildcard, broadcast,
+ local loopback, and invalid addresses.
+
+ Normally equivalent to inet_aton('0.0.0.0'), inet_aton('255.255.255.255'),
+ inet_aton('localhost') and inet_aton('255.255.255.255') respectively.
+
+ =head2 IPPROTO_IP, IPPROTO_IPV6, IPPROTO_TCP, ...
+
+ IP protocol constants to use as the third argument to socket(), the level
+ argument to getsockopt() or setsockopt(), or the value of the C<SO_PROTOCOL>
+ socket option.
+
+ =head2 TCP_CORK, TCP_KEEPALIVE, TCP_NODELAY, ...
+
+ Socket option name constants for TCP socket options at the C<IPPROTO_TCP>
+ level.
+
+ =head2 IN6ADDR_ANY, IN6ADDR_LOOPBACK
+
+ Constants giving the special C<AF_INET6> addresses for wildcard and local
+ loopback.
+
+ Normally equivalent to inet_pton(AF_INET6, "::") and
+ inet_pton(AF_INET6, "::1") respectively.
+
+ =head2 IPV6_ADD_MEMBERSHIP, IPV6_MTU, IPV6_V6ONLY, ...
+
+ Socket option name constants for IPv6 socket options at the C<IPPROTO_IPV6>
+ level.
+
+ =cut
+
+ # Still undocumented: SCM_*, SOMAXCONN, IOV_MAX, UIO_MAXIOV
+
+ =head1 STRUCTURE MANIPULATORS
+
+ The following functions convert between lists of Perl values and packed binary
+ strings representing structures.
+
+ =cut
+
+ =head2 $family = sockaddr_family $sockaddr
+
+ Takes a packed socket address (as returned by pack_sockaddr_in(),
+ pack_sockaddr_un() or the perl builtin functions getsockname() and
+ getpeername()). Returns the address family tag. This will be one of the
+ C<AF_*> constants, such as C<AF_INET> for a C<sockaddr_in> addresses or
+ C<AF_UNIX> for a C<sockaddr_un>. It can be used to figure out what unpack to
+ use for a sockaddr of unknown type.
+
+ =head2 $sockaddr = pack_sockaddr_in $port, $ip_address
+
+ Takes two arguments, a port number and an opaque string (as returned by
+ inet_aton(), or a v-string). Returns the C<sockaddr_in> structure with those
+ arguments packed in and C<AF_INET> filled in. For Internet domain sockets,
+ this structure is normally what you need for the arguments in bind(),
+ connect(), and send().
+
+ An undefined $port argument is taken as zero; an undefined $ip_address is
+ considered a fatal error.
+
+ =head2 ($port, $ip_address) = unpack_sockaddr_in $sockaddr
+
+ Takes a C<sockaddr_in> structure (as returned by pack_sockaddr_in(),
+ getpeername() or recv()). Returns a list of two elements: the port and an
+ opaque string representing the IP address (you can use inet_ntoa() to convert
+ the address to the four-dotted numeric format). Will croak if the structure
+ does not represent an C<AF_INET> address.
+
+ In scalar context will return just the IP address.
+
+ =head2 $sockaddr = sockaddr_in $port, $ip_address
+
+ =head2 ($port, $ip_address) = sockaddr_in $sockaddr
+
+ A wrapper of pack_sockaddr_in() or unpack_sockaddr_in(). In list context,
+ unpacks its argument and returns a list consisting of the port and IP address.
+ In scalar context, packs its port and IP address arguments as a C<sockaddr_in>
+ and returns it.
+
+ Provided largely for legacy compatibility; it is better to use
+ pack_sockaddr_in() or unpack_sockaddr_in() explicitly.
+
+ =head2 $sockaddr = pack_sockaddr_in6 $port, $ip6_address, [$scope_id, [$flowinfo]]
+
+ Takes two to four arguments, a port number, an opaque string (as returned by
+ inet_pton()), optionally a scope ID number, and optionally a flow label
+ number. Returns the C<sockaddr_in6> structure with those arguments packed in
+ and C<AF_INET6> filled in. IPv6 equivalent of pack_sockaddr_in().
+
+ An undefined $port argument is taken as zero; an undefined $ip6_address is
+ considered a fatal error.
+
+ =head2 ($port, $ip6_address, $scope_id, $flowinfo) = unpack_sockaddr_in6 $sockaddr
+
+ Takes a C<sockaddr_in6> structure. Returns a list of four elements: the port
+ number, an opaque string representing the IPv6 address, the scope ID, and the
+ flow label. (You can use inet_ntop() to convert the address to the usual
+ string format). Will croak if the structure does not represent an C<AF_INET6>
+ address.
+
+ In scalar context will return just the IP address.
+
+ =head2 $sockaddr = sockaddr_in6 $port, $ip6_address, [$scope_id, [$flowinfo]]
+
+ =head2 ($port, $ip6_address, $scope_id, $flowinfo) = sockaddr_in6 $sockaddr
+
+ A wrapper of pack_sockaddr_in6() or unpack_sockaddr_in6(). In list context,
+ unpacks its argument according to unpack_sockaddr_in6(). In scalar context,
+ packs its arguments according to pack_sockaddr_in6().
+
+ Provided largely for legacy compatibility; it is better to use
+ pack_sockaddr_in6() or unpack_sockaddr_in6() explicitly.
+
+ =head2 $sockaddr = pack_sockaddr_un $path
+
+ Takes one argument, a pathname. Returns the C<sockaddr_un> structure with that
+ path packed in with C<AF_UNIX> filled in. For C<PF_UNIX> sockets, this
+ structure is normally what you need for the arguments in bind(), connect(),
+ and send().
+
+ =head2 ($path) = unpack_sockaddr_un $sockaddr
+
+ Takes a C<sockaddr_un> structure (as returned by pack_sockaddr_un(),
+ getpeername() or recv()). Returns a list of one element: the pathname. Will
+ croak if the structure does not represent an C<AF_UNIX> address.
+
+ =head2 $sockaddr = sockaddr_un $path
+
+ =head2 ($path) = sockaddr_un $sockaddr
+
+ A wrapper of pack_sockaddr_un() or unpack_sockaddr_un(). In a list context,
+ unpacks its argument and returns a list consisting of the pathname. In a
+ scalar context, packs its pathname as a C<sockaddr_un> and returns it.
+
+ Provided largely for legacy compatibility; it is better to use
+ pack_sockaddr_un() or unpack_sockaddr_un() explicitly.
+
+ These are only supported if your system has E<lt>F<sys/un.h>E<gt>.
+
+ =head2 $ip_mreq = pack_ip_mreq $multiaddr, $interface
+
+ Takes an IPv4 multicast address and optionally an interface address (or
+ C<INADDR_ANY>). Returns the C<ip_mreq> structure with those arguments packed
+ in. Suitable for use with the C<IP_ADD_MEMBERSHIP> and C<IP_DROP_MEMBERSHIP>
+ sockopts.
+
+ =head2 ($multiaddr, $interface) = unpack_ip_mreq $ip_mreq
+
+ Takes an C<ip_mreq> structure. Returns a list of two elements; the IPv4
+ multicast address and interface address.
+
+ =head2 $ip_mreq_source = pack_ip_mreq_source $multiaddr, $source, $interface
+
+ Takes an IPv4 multicast address, source address, and optionally an interface
+ address (or C<INADDR_ANY>). Returns the C<ip_mreq_source> structure with those
+ arguments packed in. Suitable for use with the C<IP_ADD_SOURCE_MEMBERSHIP>
+ and C<IP_DROP_SOURCE_MEMBERSHIP> sockopts.
+
+ =head2 ($multiaddr, $source, $interface) = unpack_ip_mreq_source $ip_mreq
+
+ Takes an C<ip_mreq_source> structure. Returns a list of three elements; the
+ IPv4 multicast address, source address and interface address.
+
+ =head2 $ipv6_mreq = pack_ipv6_mreq $multiaddr6, $ifindex
+
+ Takes an IPv6 multicast address and an interface number. Returns the
+ C<ipv6_mreq> structure with those arguments packed in. Suitable for use with
+ the C<IPV6_ADD_MEMBERSHIP> and C<IPV6_DROP_MEMBERSHIP> sockopts.
+
+ =head2 ($multiaddr6, $ifindex) = unpack_ipv6_mreq $ipv6_mreq
+
+ Takes an C<ipv6_mreq> structure. Returns a list of two elements; the IPv6
+ address and an interface number.
+
+ =cut
+
+ =head1 FUNCTIONS
+
+ =cut
+
+ =head2 $ip_address = inet_aton $string
+
+ Takes a string giving the name of a host, or a textual representation of an IP
+ address and translates that to an packed binary address structure suitable to
+ pass to pack_sockaddr_in(). If passed a hostname that cannot be resolved,
+ returns C<undef>. For multi-homed hosts (hosts with more than one address),
+ the first address found is returned.
+
+ For portability do not assume that the result of inet_aton() is 32 bits wide,
+ in other words, that it would contain only the IPv4 address in network order.
+
+ This IPv4-only function is provided largely for legacy reasons. Newly-written
+ code should use getaddrinfo() or inet_pton() instead for IPv6 support.
+
+ =head2 $string = inet_ntoa $ip_address
+
+ Takes a packed binary address structure such as returned by
+ unpack_sockaddr_in() (or a v-string representing the four octets of the IPv4
+ address in network order) and translates it into a string of the form
+ C<d.d.d.d> where the C<d>s are numbers less than 256 (the normal
+ human-readable four dotted number notation for Internet addresses).
+
+ This IPv4-only function is provided largely for legacy reasons. Newly-written
+ code should use getnameinfo() or inet_ntop() instead for IPv6 support.
+
+ =head2 $address = inet_pton $family, $string
+
+ Takes an address family (such as C<AF_INET> or C<AF_INET6>) and a string
+ containing a textual representation of an address in that family and
+ translates that to an packed binary address structure.
+
+ See also getaddrinfo() for a more powerful and flexible function to look up
+ socket addresses given hostnames or textual addresses.
+
+ =head2 $string = inet_ntop $family, $address
+
+ Takes an address family and a packed binary address structure and translates
+ it into a human-readable textual representation of the address; typically in
+ C<d.d.d.d> form for C<AF_INET> or C<hhhh:hhhh::hhhh> form for C<AF_INET6>.
+
+ See also getnameinfo() for a more powerful and flexible function to turn
+ socket addresses into human-readable textual representations.
+
+ =head2 ($err, @result) = getaddrinfo $host, $service, [$hints]
+
+ Given both a hostname and service name, this function attempts to resolve the
+ host name into a list of network addresses, and the service name into a
+ protocol and port number, and then returns a list of address structures
+ suitable to connect() to it.
+
+ Given just a host name, this function attempts to resolve it to a list of
+ network addresses, and then returns a list of address structures giving these
+ addresses.
+
+ Given just a service name, this function attempts to resolve it to a protocol
+ and port number, and then returns a list of address structures that represent
+ it suitable to bind() to. This use should be combined with the C<AI_PASSIVE>
+ flag; see below.
+
+ Given neither name, it generates an error.
+
+ If present, $hints should be a reference to a hash, where the following keys
+ are recognised:
+
+ =over 4
+
+ =item flags => INT
+
+ A bitfield containing C<AI_*> constants; see below.
+
+ =item family => INT
+
+ Restrict to only generating addresses in this address family
+
+ =item socktype => INT
+
+ Restrict to only generating addresses of this socket type
+
+ =item protocol => INT
+
+ Restrict to only generating addresses for this protocol
+
+ =back
+
+ The return value will be a list; the first value being an error indication,
+ followed by a list of address structures (if no error occurred).
+
+ The error value will be a dualvar; comparable to the C<EAI_*> error constants,
+ or printable as a human-readable error message string. If no error occurred it
+ will be zero numerically and an empty string.
+
+ Each value in the results list will be a hash reference containing the following
+ fields:
+
+ =over 4
+
+ =item family => INT
+
+ The address family (e.g. C<AF_INET>)
+
+ =item socktype => INT
+
+ The socket type (e.g. C<SOCK_STREAM>)
+
+ =item protocol => INT
+
+ The protocol (e.g. C<IPPROTO_TCP>)
+
+ =item addr => STRING
+
+ The address in a packed string (such as would be returned by
+ pack_sockaddr_in())
+
+ =item canonname => STRING
+
+ The canonical name for the host if the C<AI_CANONNAME> flag was provided, or
+ C<undef> otherwise. This field will only be present on the first returned
+ address.
+
+ =back
+
+ The following flag constants are recognised in the $hints hash. Other flag
+ constants may exist as provided by the OS.
+
+ =over 4
+
+ =item AI_PASSIVE
+
+ Indicates that this resolution is for a local bind() for a passive (i.e.
+ listening) socket, rather than an active (i.e. connecting) socket.
+
+ =item AI_CANONNAME
+
+ Indicates that the caller wishes the canonical hostname (C<canonname>) field
+ of the result to be filled in.
+
+ =item AI_NUMERICHOST
+
+ Indicates that the caller will pass a numeric address, rather than a hostname,
+ and that getaddrinfo() must not perform a resolve operation on this name. This
+ flag will prevent a possibly-slow network lookup operation, and instead return
+ an error if a hostname is passed.
+
+ =back
+
+ =head2 ($err, $hostname, $servicename) = getnameinfo $sockaddr, [$flags, [$xflags]]
+
+ Given a packed socket address (such as from getsockname(), getpeername(), or
+ returned by getaddrinfo() in a C<addr> field), returns the hostname and
+ symbolic service name it represents. $flags may be a bitmask of C<NI_*>
+ constants, or defaults to 0 if unspecified.
+
+ The return value will be a list; the first value being an error condition,
+ followed by the hostname and service name.
+
+ The error value will be a dualvar; comparable to the C<EAI_*> error constants,
+ or printable as a human-readable error message string. The host and service
+ names will be plain strings.
+
+ The following flag constants are recognised as $flags. Other flag constants may
+ exist as provided by the OS.
+
+ =over 4
+
+ =item NI_NUMERICHOST
+
+ Requests that a human-readable string representation of the numeric address be
+ returned directly, rather than performing a name resolve operation that may
+ convert it into a hostname. This will also avoid potentially-blocking network
+ IO.
+
+ =item NI_NUMERICSERV
+
+ Requests that the port number be returned directly as a number representation
+ rather than performing a name resolve operation that may convert it into a
+ service name.
+
+ =item NI_NAMEREQD
+
+ If a name resolve operation fails to provide a name, then this flag will cause
+ getnameinfo() to indicate an error, rather than returning the numeric
+ representation as a human-readable string.
+
+ =item NI_DGRAM
+
+ Indicates that the socket address relates to a C<SOCK_DGRAM> socket, for the
+ services whose name differs between TCP and UDP protocols.
+
+ =back
+
+ The following constants may be supplied as $xflags.
+
+ =over 4
+
+ =item NIx_NOHOST
+
+ Indicates that the caller is not interested in the hostname of the result, so
+ it does not have to be converted. C<undef> will be returned as the hostname.
+
+ =item NIx_NOSERV
+
+ Indicates that the caller is not interested in the service name of the result,
+ so it does not have to be converted. C<undef> will be returned as the service
+ name.
+
+ =back
+
+ =head1 getaddrinfo() / getnameinfo() ERROR CONSTANTS
+
+ The following constants may be returned by getaddrinfo() or getnameinfo().
+ Others may be provided by the OS.
+
+ =over 4
+
+ =item EAI_AGAIN
+
+ A temporary failure occurred during name resolution. The operation may be
+ successful if it is retried later.
+
+ =item EAI_BADFLAGS
+
+ The value of the C<flags> hint to getaddrinfo(), or the $flags parameter to
+ getnameinfo() contains unrecognised flags.
+
+ =item EAI_FAMILY
+
+ The C<family> hint to getaddrinfo(), or the family of the socket address
+ passed to getnameinfo() is not supported.
+
+ =item EAI_NODATA
+
+ The host name supplied to getaddrinfo() did not provide any usable address
+ data.
+
+ =item EAI_NONAME
+
+ The host name supplied to getaddrinfo() does not exist, or the address
+ supplied to getnameinfo() is not associated with a host name and the
+ C<NI_NAMEREQD> flag was supplied.
+
+ =item EAI_SERVICE
+
+ The service name supplied to getaddrinfo() is not available for the socket
+ type given in the $hints.
+
+ =back
+
+ =cut
+
+ =head1 EXAMPLES
+
+ =head2 Lookup for connect()
+
+ The getaddrinfo() function converts a hostname and a service name into a list
+ of structures, each containing a potential way to connect() to the named
+ service on the named host.
+
+ use IO::Socket;
+ use Socket qw(SOCK_STREAM getaddrinfo);
+
+ my %hints = (socktype => SOCK_STREAM);
+ my ($err, @res) = getaddrinfo("localhost", "echo", \%hints);
+ die "Cannot getaddrinfo - $err" if $err;
+
+ my $sock;
+
+ foreach my $ai (@res) {
+ my $candidate = IO::Socket->new();
+
+ $candidate->socket($ai->{family}, $ai->{socktype}, $ai->{protocol})
+ or next;
+
+ $candidate->connect($ai->{addr})
+ or next;
+
+ $sock = $candidate;
+ last;
+ }
+
+ die "Cannot connect to localhost:echo" unless $sock;
+
+ $sock->print("Hello, world!\n");
+ print <$sock>;
+
+ Because a list of potential candidates is returned, the C<while> loop tries
+ each in turn until it finds one that succeeds both the socket() and connect()
+ calls.
+
+ This function performs the work of the legacy functions gethostbyname(),
+ getservbyname(), inet_aton() and pack_sockaddr_in().
+
+ In practice this logic is better performed by L<IO::Socket::IP>.
+
+ =head2 Making a human-readable string out of an address
+
+ The getnameinfo() function converts a socket address, such as returned by
+ getsockname() or getpeername(), into a pair of human-readable strings
+ representing the address and service name.
+
+ use IO::Socket::IP;
+ use Socket qw(getnameinfo);
+
+ my $server = IO::Socket::IP->new(LocalPort => 12345, Listen => 1) or
+ die "Cannot listen - $@";
+
+ my $socket = $server->accept or die "accept: $!";
+
+ my ($err, $hostname, $servicename) = getnameinfo($socket->peername);
+ die "Cannot getnameinfo - $err" if $err;
+
+ print "The peer is connected from $hostname\n";
+
+ Since in this example only the hostname was used, the redundant conversion of
+ the port number into a service name may be omitted by passing the
+ C<NIx_NOSERV> flag.
+
+ use Socket qw(getnameinfo NIx_NOSERV);
+
+ my ($err, $hostname) = getnameinfo($socket->peername, 0, NIx_NOSERV);
+
+ This function performs the work of the legacy functions unpack_sockaddr_in(),
+ inet_ntoa(), gethostbyaddr() and getservbyport().
+
+ In practice this logic is better performed by L<IO::Socket::IP>.
+
+ =head2 Resolving hostnames into IP addresses
+
+ To turn a hostname into a human-readable plain IP address use getaddrinfo()
+ to turn the hostname into a list of socket structures, then getnameinfo() on
+ each one to make it a readable IP address again.
+
+ use Socket qw(:addrinfo SOCK_RAW);
+
+ my ($err, @res) = getaddrinfo($hostname, "", {socktype => SOCK_RAW});
+ die "Cannot getaddrinfo - $err" if $err;
+
+ while( my $ai = shift @res ) {
+ my ($err, $ipaddr) = getnameinfo($ai->{addr}, NI_NUMERICHOST, NIx_NOSERV);
+ die "Cannot getnameinfo - $err" if $err;
+
+ print "$ipaddr\n";
+ }
+
+ The C<socktype> hint to getaddrinfo() filters the results to only include one
+ socket type and protocol. Without this most OSes return three combinations,
+ for C<SOCK_STREAM>, C<SOCK_DGRAM> and C<SOCK_RAW>, resulting in triplicate
+ output of addresses. The C<NI_NUMERICHOST> flag to getnameinfo() causes it to
+ return a string-formatted plain IP address, rather than reverse resolving it
+ back into a hostname.
+
+ This combination performs the work of the legacy functions gethostbyname()
+ and inet_ntoa().
+
+ =head2 Accessing socket options
+
+ The many C<SO_*> and other constants provide the socket option names for
+ getsockopt() and setsockopt().
+
+ use IO::Socket::INET;
+ use Socket qw(SOL_SOCKET SO_RCVBUF IPPROTO_IP IP_TTL);
+
+ my $socket = IO::Socket::INET->new(LocalPort => 0, Proto => 'udp')
+ or die "Cannot create socket: $@";
+
+ $socket->setsockopt(SOL_SOCKET, SO_RCVBUF, 64*1024) or
+ die "setsockopt: $!";
+
+ print "Receive buffer is ", $socket->getsockopt(SOL_SOCKET, SO_RCVBUF),
+ " bytes\n";
+
+ print "IP TTL is ", $socket->getsockopt(IPPROTO_IP, IP_TTL), "\n";
+
+ As a convenience, L<IO::Socket>'s setsockopt() method will convert a number
+ into a packed byte buffer, and getsockopt() will unpack a byte buffer of the
+ correct size back into a number.
+
+ =cut
=head1 AUTHOR
- Marc Lehmann <schmorp@schmorp.de>
- http://home.schmorp.de/
+ This module was originally maintained in Perl core by the Perl 5 Porters.
+
+ It was extracted to dual-life on CPAN at version 1.95 by
+ Paul Evans <leonerd@leonerd.org.uk>
=cut
-X86_64-LINUX-GNU-THREAD-MULTI_JSON_XS_BOOLEAN
+ use Carp;
+ use warnings::register;
+
+ require Exporter;
+ require XSLoader;
+ our @ISA = qw(Exporter);
+
+ # <@Nicholas> you can't change @EXPORT without breaking the implicit API
+ # Please put any new constants in @EXPORT_OK!
+
+ # List re-ordered to match documentation above. Try to keep the ordering
+ # consistent so it's easier to see which ones are or aren't documented.
+ our @EXPORT = qw(
+ PF_802 PF_AAL PF_APPLETALK PF_CCITT PF_CHAOS PF_CTF PF_DATAKIT
+ PF_DECnet PF_DLI PF_ECMA PF_GOSIP PF_HYLINK PF_IMPLINK PF_INET PF_INET6
+ PF_ISO PF_KEY PF_LAST PF_LAT PF_LINK PF_MAX PF_NBS PF_NIT PF_NS PF_OSI
+ PF_OSINET PF_PUP PF_ROUTE PF_SNA PF_UNIX PF_UNSPEC PF_USER PF_WAN
+ PF_X25
+
+ AF_802 AF_AAL AF_APPLETALK AF_CCITT AF_CHAOS AF_CTF AF_DATAKIT
+ AF_DECnet AF_DLI AF_ECMA AF_GOSIP AF_HYLINK AF_IMPLINK AF_INET AF_INET6
+ AF_ISO AF_KEY AF_LAST AF_LAT AF_LINK AF_MAX AF_NBS AF_NIT AF_NS AF_OSI
+ AF_OSINET AF_PUP AF_ROUTE AF_SNA AF_UNIX AF_UNSPEC AF_USER AF_WAN
+ AF_X25
+
+ SOCK_DGRAM SOCK_RAW SOCK_RDM SOCK_SEQPACKET SOCK_STREAM
+
+ SOL_SOCKET
+
+ SO_ACCEPTCONN SO_ATTACH_FILTER SO_BACKLOG SO_BROADCAST SO_CHAMELEON
+ SO_DEBUG SO_DETACH_FILTER SO_DGRAM_ERRIND SO_DOMAIN SO_DONTLINGER
+ SO_DONTROUTE SO_ERROR SO_FAMILY SO_KEEPALIVE SO_LINGER SO_OOBINLINE
+ SO_PASSCRED SO_PASSIFNAME SO_PEERCRED SO_PROTOCOL SO_PROTOTYPE
+ SO_RCVBUF SO_RCVLOWAT SO_RCVTIMEO SO_REUSEADDR SO_REUSEPORT
+ SO_SECURITY_AUTHENTICATION SO_SECURITY_ENCRYPTION_NETWORK
+ SO_SECURITY_ENCRYPTION_TRANSPORT SO_SNDBUF SO_SNDLOWAT SO_SNDTIMEO
+ SO_STATE SO_TYPE SO_USELOOPBACK SO_XOPEN SO_XSE
+
+ IP_HDRINCL IP_OPTIONS IP_RECVOPTS IP_RECVRETOPTS IP_RETOPTS IP_TOS
+ IP_TTL
+
+ MSG_BCAST MSG_BTAG MSG_CTLFLAGS MSG_CTLIGNORE MSG_CTRUNC MSG_DONTROUTE
+ MSG_DONTWAIT MSG_EOF MSG_EOR MSG_ERRQUEUE MSG_ETAG MSG_FASTOPEN MSG_FIN
+ MSG_MAXIOVLEN MSG_MCAST MSG_NOSIGNAL MSG_OOB MSG_PEEK MSG_PROXY MSG_RST
+ MSG_SYN MSG_TRUNC MSG_URG MSG_WAITALL MSG_WIRE
+
+ SHUT_RD SHUT_RDWR SHUT_WR
+
+ INADDR_ANY INADDR_BROADCAST INADDR_LOOPBACK INADDR_NONE
+
+ SCM_CONNECT SCM_CREDENTIALS SCM_CREDS SCM_RIGHTS SCM_TIMESTAMP
+
+ SOMAXCONN
+
+ IOV_MAX
+ UIO_MAXIOV
+
+ sockaddr_family
+ pack_sockaddr_in unpack_sockaddr_in sockaddr_in
+ pack_sockaddr_in6 unpack_sockaddr_in6 sockaddr_in6
+ pack_sockaddr_un unpack_sockaddr_un sockaddr_un
+
+ inet_aton inet_ntoa
+ );
+
+ # List re-ordered to match documentation above. Try to keep the ordering
+ # consistent so it's easier to see which ones are or aren't documented.
+ our @EXPORT_OK = qw(
+ CR LF CRLF $CR $LF $CRLF
+
+ SOCK_NONBLOCK SOCK_CLOEXEC
+
+ IP_ADD_MEMBERSHIP IP_ADD_SOURCE_MEMBERSHIP IP_BIND_ADDRESS_NO_PORT
+ IP_DROP_MEMBERSHIP IP_DROP_SOURCE_MEMBERSHIP IP_FREEBIND
+ IP_MULTICAST_ALL IP_MULTICAST_IF IP_MULTICAST_LOOP IP_MULTICAST_TTL
+ IP_MTU IP_MTU_DISCOVER IP_NODEFRAG IP_RECVERR IP_TRANSPARENT
+
+ IPPROTO_IP IPPROTO_IPV6 IPPROTO_RAW IPPROTO_ICMP IPPROTO_IGMP
+ IPPROTO_TCP IPPROTO_UDP IPPROTO_GRE IPPROTO_ESP IPPROTO_AH
+ IPPROTO_ICMPV6 IPPROTO_SCTP
+
+ IP_PMTUDISC_DO IP_PMTUDISC_DONT IP_PMTUDISC_PROBE IP_PMTUDISC_WANT
+
+ IPTOS_LOWDELAY IPTOS_THROUGHPUT IPTOS_RELIABILITY IPTOS_MINCOST
+
+ TCP_CONGESTION TCP_CONNECTIONTIMEOUT TCP_CORK TCP_DEFER_ACCEPT
+ TCP_FASTOPEN TCP_INFO TCP_INIT_CWND TCP_KEEPALIVE TCP_KEEPCNT
+ TCP_KEEPIDLE TCP_KEEPINTVL TCP_LINGER2 TCP_MAXRT TCP_MAXSEG
+ TCP_MD5SIG TCP_NODELAY TCP_NOOPT TCP_NOPUSH TCP_QUICKACK
+ TCP_SACK_ENABLE TCP_STDURG TCP_SYNCNT TCP_USER_TIMEOUT
+ TCP_WINDOW_CLAMP
+
+ IN6ADDR_ANY IN6ADDR_LOOPBACK
+
+ IPV6_ADDRFROM IPV6_ADD_MEMBERSHIP IPV6_DROP_MEMBERSHIP IPV6_JOIN_GROUP
+ IPV6_LEAVE_GROUP IPV6_MTU IPV6_MTU_DISCOVER IPV6_MULTICAST_HOPS
+ IPV6_MULTICAST_IF IPV6_MULTICAST_LOOP IPV6_RECVERR IPV6_ROUTER_ALERT
+ IPV6_UNICAST_HOPS IPV6_V6ONLY
+
+ SO_LOCK_FILTER SO_RCVBUFFORCE SO_SNDBUFFORCE
+
+ pack_ip_mreq unpack_ip_mreq pack_ip_mreq_source unpack_ip_mreq_source
+
+ pack_ipv6_mreq unpack_ipv6_mreq
+
+ inet_pton inet_ntop
+
+ getaddrinfo getnameinfo
+
+ AI_ADDRCONFIG AI_ALL AI_CANONIDN AI_CANONNAME AI_IDN
+ AI_IDN_ALLOW_UNASSIGNED AI_IDN_USE_STD3_ASCII_RULES AI_NUMERICHOST
+ AI_NUMERICSERV AI_PASSIVE AI_V4MAPPED
+
+ NI_DGRAM NI_IDN NI_IDN_ALLOW_UNASSIGNED NI_IDN_USE_STD3_ASCII_RULES
+ NI_NAMEREQD NI_NOFQDN NI_NUMERICHOST NI_NUMERICSERV
+
+ NIx_NOHOST NIx_NOSERV
+
+ EAI_ADDRFAMILY EAI_AGAIN EAI_BADFLAGS EAI_BADHINTS EAI_FAIL EAI_FAMILY
+ EAI_NODATA EAI_NONAME EAI_PROTOCOL EAI_SERVICE EAI_SOCKTYPE EAI_SYSTEM
+ );
+
+ our %EXPORT_TAGS = (
+ crlf => [qw(CR LF CRLF $CR $LF $CRLF)],
+ addrinfo => [qw(getaddrinfo getnameinfo), grep m/^(?:AI|NI|NIx|EAI)_/, @EXPORT_OK],
+ all => [@EXPORT, @EXPORT_OK],
+ );
+
+ BEGIN {
+ sub CR () {"\015"}
+ sub LF () {"\012"}
+ sub CRLF () {"\015\012"}
+
+ # These are not gni() constants; they're extensions for the perl API
+ # The definitions in Socket.pm and Socket.xs must match
+ sub NIx_NOHOST() {1 << 0}
+ sub NIx_NOSERV() {1 << 1}
+ }
+
+ *CR = \CR();
+ *LF = \LF();
+ *CRLF = \CRLF();
+
+ sub sockaddr_in {
+ if (@_ == 6 && !wantarray) { # perl5.001m compat; use this && die
+ my($af, $port, @quad) = @_;
+ warnings::warn "6-ARG sockaddr_in call is deprecated"
+ if warnings::enabled();
+ pack_sockaddr_in($port, inet_aton(join('.', @quad)));
+ } elsif (wantarray) {
+ croak "usage: (port,iaddr) = sockaddr_in(sin_sv)" unless @_ == 1;
+ unpack_sockaddr_in(@_);
+ } else {
+ croak "usage: sin_sv = sockaddr_in(port,iaddr))" unless @_ == 2;
+ pack_sockaddr_in(@_);
+ }
+ }
+
+ sub sockaddr_in6 {
+ if (wantarray) {
+ croak "usage: (port,in6addr,scope_id,flowinfo) = sockaddr_in6(sin6_sv)" unless @_ == 1;
+ unpack_sockaddr_in6(@_);
+ }
+ else {
+ croak "usage: sin6_sv = sockaddr_in6(port,in6addr,[scope_id,[flowinfo]])" unless @_ >= 2 and @_ <= 4;
+ pack_sockaddr_in6(@_);
+ }
+ }
+
+ sub sockaddr_un {
+ if (wantarray) {
+ croak "usage: (filename) = sockaddr_un(sun_sv)" unless @_ == 1;
+ unpack_sockaddr_un(@_);
+ } else {
+ croak "usage: sun_sv = sockaddr_un(filename)" unless @_ == 1;
+ pack_sockaddr_un(@_);
+ }
+ }
+
+ XSLoader::load(__PACKAGE__, $VERSION);
+
+ my %errstr;
+
+ if( defined &getaddrinfo ) {
+ # These are not part of the API, nothing uses them, and deleting them
+ # reduces the size of %Socket:: by about 12K
+ delete $Socket::{fake_getaddrinfo};
+ delete $Socket::{fake_getnameinfo};
+ } else {
+ require Scalar::Util;
+
+ *getaddrinfo = \&fake_getaddrinfo;
+ *getnameinfo = \&fake_getnameinfo;
+
+ # These numbers borrowed from GNU libc's implementation, but since
+ # they're only used by our emulation, it doesn't matter if the real
+ # platform's values differ
+ my %constants = (
+ AI_PASSIVE => 1,
+ AI_CANONNAME => 2,
+ AI_NUMERICHOST => 4,
+ AI_V4MAPPED => 8,
+ AI_ALL => 16,
+ AI_ADDRCONFIG => 32,
+ # RFC 2553 doesn't define this but Linux does - lets be nice and
+ # provide it since we can
+ AI_NUMERICSERV => 1024,
+
+ EAI_BADFLAGS => -1,
+ EAI_NONAME => -2,
+ EAI_NODATA => -5,
+ EAI_FAMILY => -6,
+ EAI_SERVICE => -8,
+
+ NI_NUMERICHOST => 1,
+ NI_NUMERICSERV => 2,
+ NI_NOFQDN => 4,
+ NI_NAMEREQD => 8,
+ NI_DGRAM => 16,
+
+ # Constants we don't support. Export them, but croak if anyone tries to
+ # use them
+ AI_IDN => 64,
+ AI_CANONIDN => 128,
+ AI_IDN_ALLOW_UNASSIGNED => 256,
+ AI_IDN_USE_STD3_ASCII_RULES => 512,
+ NI_IDN => 32,
+ NI_IDN_ALLOW_UNASSIGNED => 64,
+ NI_IDN_USE_STD3_ASCII_RULES => 128,
+
+ # Error constants we'll never return, so it doesn't matter what value
+ # these have, nor that we don't provide strings for them
+ EAI_SYSTEM => -11,
+ EAI_BADHINTS => -1000,
+ EAI_PROTOCOL => -1001
+ );
+
+ foreach my $name ( keys %constants ) {
+ my $value = $constants{$name};
+
+ no strict 'refs';
+ defined &$name or *$name = sub () { $value };
+ }
+
+ %errstr = (
+ # These strings from RFC 2553
+ EAI_BADFLAGS() => "invalid value for ai_flags",
+ EAI_NONAME() => "nodename nor servname provided, or not known",
+ EAI_NODATA() => "no address associated with nodename",
+ EAI_FAMILY() => "ai_family not supported",
+ EAI_SERVICE() => "servname not supported for ai_socktype",
+ );
+ }
+
+ # The following functions are used if the system does not have a
+ # getaddrinfo(3) function in libc; and are used to emulate it for the AF_INET
+ # family
+
+ # Borrowed from Regexp::Common::net
+ my $REGEXP_IPv4_DECIMAL = qr/25[0-5]|2[0-4][0-9]|[0-1]?[0-9]{1,2}/;
+ my $REGEXP_IPv4_DOTTEDQUAD = qr/$REGEXP_IPv4_DECIMAL\.$REGEXP_IPv4_DECIMAL\.$REGEXP_IPv4_DECIMAL\.$REGEXP_IPv4_DECIMAL/;
+
+ sub fake_makeerr
+ {
+ my ( $errno ) = @_;
+ my $errstr = $errno == 0 ? "" : ( $errstr{$errno} || $errno );
+ return Scalar::Util::dualvar( $errno, $errstr );
+ }
+
+ sub fake_getaddrinfo
+ {
+ my ( $node, $service, $hints ) = @_;
+
+ $node = "" unless defined $node;
+
+ $service = "" unless defined $service;
+
+ my ( $family, $socktype, $protocol, $flags ) = @$hints{qw( family socktype protocol flags )};
+
+ $family ||= Socket::AF_INET(); # 0 == AF_UNSPEC, which we want too
+ $family == Socket::AF_INET() or return fake_makeerr( EAI_FAMILY() );
+
+ $socktype ||= 0;
+
+ $protocol ||= 0;
+
+ $flags ||= 0;
+
+ my $flag_passive = $flags & AI_PASSIVE(); $flags &= ~AI_PASSIVE();
+ my $flag_canonname = $flags & AI_CANONNAME(); $flags &= ~AI_CANONNAME();
+ my $flag_numerichost = $flags & AI_NUMERICHOST(); $flags &= ~AI_NUMERICHOST();
+ my $flag_numericserv = $flags & AI_NUMERICSERV(); $flags &= ~AI_NUMERICSERV();
+
+ # These constants don't apply to AF_INET-only lookups, so we might as well
+ # just ignore them. For AI_ADDRCONFIG we just presume the host has ability
+ # to talk AF_INET. If not we'd have to return no addresses at all. :)
+ $flags &= ~(AI_V4MAPPED()|AI_ALL()|AI_ADDRCONFIG());
+
+ $flags & (AI_IDN()|AI_CANONIDN()|AI_IDN_ALLOW_UNASSIGNED()|AI_IDN_USE_STD3_ASCII_RULES()) and
+ croak "Socket::getaddrinfo() does not support IDN";
+
+ $flags == 0 or return fake_makeerr( EAI_BADFLAGS() );
+
+ $node eq "" and $service eq "" and return fake_makeerr( EAI_NONAME() );
+
+ my $canonname;
+ my @addrs;
+ if( $node ne "" ) {
+ return fake_makeerr( EAI_NONAME() ) if( $flag_numerichost and $node !~ m/^$REGEXP_IPv4_DOTTEDQUAD$/ );
+ ( $canonname, undef, undef, undef, @addrs ) = gethostbyname( $node );
+ defined $canonname or return fake_makeerr( EAI_NONAME() );
+
+ undef $canonname unless $flag_canonname;
+ }
+ else {
+ $addrs[0] = $flag_passive ? Socket::inet_aton( "0.0.0.0" )
+ : Socket::inet_aton( "127.0.0.1" );
+ }
+
+ my @ports; # Actually ARRAYrefs of [ socktype, protocol, port ]
+ my $protname = "";
+ if( $protocol ) {
+ $protname = eval { getprotobynumber( $protocol ) };
+ }
+
+ if( $service ne "" and $service !~ m/^\d+$/ ) {
+ return fake_makeerr( EAI_NONAME() ) if( $flag_numericserv );
+ getservbyname( $service, $protname ) or return fake_makeerr( EAI_SERVICE() );
+ }
+
+ foreach my $this_socktype ( Socket::SOCK_STREAM(), Socket::SOCK_DGRAM(), Socket::SOCK_RAW() ) {
+ next if $socktype and $this_socktype != $socktype;
+
+ my $this_protname = "raw";
+ $this_socktype == Socket::SOCK_STREAM() and $this_protname = "tcp";
+ $this_socktype == Socket::SOCK_DGRAM() and $this_protname = "udp";
+
+ next if $protname and $this_protname ne $protname;
+
+ my $port;
+ if( $service ne "" ) {
+ if( $service =~ m/^\d+$/ ) {
+ $port = "$service";
+ }
+ else {
+ ( undef, undef, $port, $this_protname ) = getservbyname( $service, $this_protname );
+ next unless defined $port;
+ }
+ }
+ else {
+ $port = 0;
+ }
+
+ push @ports, [ $this_socktype, eval { scalar getprotobyname( $this_protname ) } || 0, $port ];
+ }
+
+ my @ret;
+ foreach my $addr ( @addrs ) {
+ foreach my $portspec ( @ports ) {
+ my ( $socktype, $protocol, $port ) = @$portspec;
+ push @ret, {
+ family => $family,
+ socktype => $socktype,
+ protocol => $protocol,
+ addr => Socket::pack_sockaddr_in( $port, $addr ),
+ canonname => undef,
+ };
+ }
+ }
+
+ # Only supply canonname for the first result
+ if( defined $canonname ) {
+ $ret[0]->{canonname} = $canonname;
+ }
+
+ return ( fake_makeerr( 0 ), @ret );
+ }
+
+ sub fake_getnameinfo
+ {
+ my ( $addr, $flags, $xflags ) = @_;
+
+ my ( $port, $inetaddr );
+ eval { ( $port, $inetaddr ) = Socket::unpack_sockaddr_in( $addr ) }
+ or return fake_makeerr( EAI_FAMILY() );
+
+ my $family = Socket::AF_INET();
+
+ $flags ||= 0;
+
+ my $flag_numerichost = $flags & NI_NUMERICHOST(); $flags &= ~NI_NUMERICHOST();
+ my $flag_numericserv = $flags & NI_NUMERICSERV(); $flags &= ~NI_NUMERICSERV();
+ my $flag_nofqdn = $flags & NI_NOFQDN(); $flags &= ~NI_NOFQDN();
+ my $flag_namereqd = $flags & NI_NAMEREQD(); $flags &= ~NI_NAMEREQD();
+ my $flag_dgram = $flags & NI_DGRAM() ; $flags &= ~NI_DGRAM();
+
+ $flags & (NI_IDN()|NI_IDN_ALLOW_UNASSIGNED()|NI_IDN_USE_STD3_ASCII_RULES()) and
+ croak "Socket::getnameinfo() does not support IDN";
+
+ $flags == 0 or return fake_makeerr( EAI_BADFLAGS() );
+
+ $xflags ||= 0;
+
+ my $node;
+ if( $xflags & NIx_NOHOST ) {
+ $node = undef;
+ }
+ elsif( $flag_numerichost ) {
+ $node = Socket::inet_ntoa( $inetaddr );
+ }
+ else {
+ $node = gethostbyaddr( $inetaddr, $family );
+ if( !defined $node ) {
+ return fake_makeerr( EAI_NONAME() ) if $flag_namereqd;
+ $node = Socket::inet_ntoa( $inetaddr );
+ }
+ elsif( $flag_nofqdn ) {
+ my ( $shortname ) = split m/\./, $node;
+ my ( $fqdn ) = gethostbyname $shortname;
+ $node = $shortname if defined $fqdn and $fqdn eq $node;
+ }
+ }
+
+ my $service;
+ if( $xflags & NIx_NOSERV ) {
+ $service = undef;
+ }
+ elsif( $flag_numericserv ) {
+ $service = "$port";
+ }
+ else {
+ my $protname = $flag_dgram ? "udp" : "";
+ $service = getservbyport( $port, $protname );
+ if( !defined $service ) {
+ $service = "$port";
+ }
+ }
+
+ return ( fake_makeerr( 0 ), $node, $service );
+ }
+
+ 1;
+X86_64-LINUX-GNU-THREAD-MULTI_SOCKET
+
+$fatpacked{"x86_64-linux-gnu-thread-multi/version.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'X86_64-LINUX-GNU-THREAD-MULTI_VERSION';
+ #!perl -w
+ package version;
+
+ use 5.006002;
+ use strict;
+ use warnings::register;
+ if ($] >= 5.015) {
+ warnings::register_categories(qw/version/);
+ }
+
+ our $VERSION = 0.9924;
+ our $CLASS = 'version';
+ our (@ISA, $STRICT, $LAX);
+
+ # !!!!Delete this next block completely when adding to Perl core!!!!
+ {
+ local $SIG{'__DIE__'};
+ eval "use version::vxs $VERSION";
+ if ( $@ ) { # don't have the XS version installed
+ 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::(cmp'} = \&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::(cmp'} = \&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;
+ *LAX_DECIMAL_VERSION = \$version::regex::LAX_DECIMAL_VERSION;
+ *LAX_DOTTED_DECIMAL_VERSION = \$version::regex::LAX_DOTTED_DECIMAL_VERSION;
+ *STRICT = \$version::regex::STRICT;
+ *STRICT_DECIMAL_VERSION = \$version::regex::STRICT_DECIMAL_VERSION;
+ *STRICT_DOTTED_DECIMAL_VERSION = \$version::regex::STRICT_DOTTED_DECIMAL_VERSION;
+
+ 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;
+X86_64-LINUX-GNU-THREAD-MULTI_VERSION
+
+$fatpacked{"x86_64-linux-gnu-thread-multi/version/regex.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'X86_64-LINUX-GNU-THREAD-MULTI_VERSION_REGEX';
+ package version::regex;
+
+ use strict;
+
+ our $VERSION = 0.9924;
+
+ #--------------------------------------------------------------------------#
+ # 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.
+
+ our $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.
+
+ our $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
+
+ our $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
+
+ our $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
+
+ our $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
+
+ our $LAX =
+ qr/ undef | $LAX_DOTTED_DECIMAL_VERSION | $LAX_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;
+X86_64-LINUX-GNU-THREAD-MULTI_VERSION_REGEX
-$fatpacked{"x86_64-linux-gnu-thread-multi/common/sense.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'X86_64-LINUX-GNU-THREAD-MULTI_COMMON_SENSE';
- package common::sense;
+$fatpacked{"x86_64-linux-gnu-thread-multi/version/vpp.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'X86_64-LINUX-GNU-THREAD-MULTI_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
- our $VERSION = 3.74;
+ use overload (
+ '""' => \&thischar,
+ '0+' => \&thischar,
+ '++' => \&increment,
+ '--' => \&decrement,
+ '+' => \&plus,
+ '-' => \&minus,
+ '*' => \&multiply,
+ 'cmp' => \&cmp,
+ '<=>' => \&spaceship,
+ 'bool' => \&thischar,
+ '=' => \&clone,
+ );
- # overload should be included
+ 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;
+
+ our $VERSION = 0.9924;
+ our $CLASS = 'version::vpp';
+ our ($LAX, $STRICT, $WARN_CATEGORY);
+
+ 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 {
- local $^W; # work around perl 5.16 spewing out warnings for next statement
- # use warnings
- ${^WARNING_BITS} ^= ${^WARNING_BITS} ^ "\x0c\x3f\x33\x00\x0f\xf0\x0f\xc0\xf0\xfc\x33\x00\x00";
- # use strict, use utf8; use feature;
- $^H |= 0x820f00;
- @^H{qw(feature_unicode feature_say feature_state feature_switch)} = (1) x 4;
+ 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/);
}
- 1
-X86_64-LINUX-GNU-THREAD-MULTI_COMMON_SENSE
+ 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 eq '_') {
+ $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 ) {
+ next if $s eq '_';
+ $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) {
+ next if $end eq '_';
+ $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 eq '_') {
+ $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(sprintf "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 $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];
+ $string .= sprintf("%03d", $digit);
+ }
+
+ if ( $len == 0 ) {
+ $string .= sprintf("000");
+ }
+
+ return $string;
+ }
+
+ sub normal {
+ my ($self) = @_;
+ unless (_verify($self)) {
+ require Carp;
+ Carp::croak("Invalid version object");
+ }
+
+ 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 <= 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 {
+ 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++;
+ }
+
+ # 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;
+ }
+ }
+ $tvalue =~ tr/_//d;
+ 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
+X86_64-LINUX-GNU-THREAD-MULTI_VERSION_VPP
+
+$fatpacked{"x86_64-linux-gnu-thread-multi/version/vxs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'X86_64-LINUX-GNU-THREAD-MULTI_VERSION_VXS';
+ #!perl -w
+ package version::vxs;
+
+ use v5.10;
+ use strict;
+
+ our $VERSION = 0.9924;
+ our $CLASS = 'version::vxs';
+ our @ISA;
+
+ eval {
+ require XSLoader;
+ local $^W; # shut up the 'redefined' warning for UNIVERSAL::VERSION
+ XSLoader::load('version::vxs', $VERSION);
+ 1;
+ } or do {
+ require DynaLoader;
+ push @ISA, 'DynaLoader';
+ local $^W; # shut up the 'redefined' warning for UNIVERSAL::VERSION
+ bootstrap version::vxs $VERSION;
+ };
+
+ # Preloaded methods go here.
+
+ 1;
+X86_64-LINUX-GNU-THREAD-MULTI_VERSION_VXS
s/^ //mg for values %fatpacked;
generated by cgit v1.2.3 (git 2.25.1) at 2025-04-26 11:54:12 +0000