Файловый менеджер - Редактировать - /home/jogoso94/public_html/static/img/logo/App-cpanminus-1.7047-0.zip
�азад
PK jA[ pm_to_blibnu �[��� PK jA[a�HMS� S� Changesnu �[��� See http://github.com/miyagawa/cpanminus/ for the latest development. 1.7047 2023-07-29 22:59:16 PDT [Bug Fix] - Upgrade fatpacked CPAN::Meta::Check to 0.018 (#662) 1.7046 2022-04-26 23:00:56 PDT [Documentation] - Remove git.io URL that's going to be deprecated. 1.7045 2022-01-26 19:03:44 PST [Security] - [CVE-2020-16154] remove the functionality to verify CHECKSUMS signature 1.7044 2018-04-19 13:54:29 CEST [Improvements] - Support zip files with comments (skaji) #560 - Use metacpan download_url API (haarg) #522 1.7043 2017-04-02 20:56:06 PDT [Improvements] - Set PERL_USE_UNSAFE_INC for 5.26+ (haarg) #521 - Strictly match module NAME in Bundle 1.7042 2016-05-24 00:48:13 PDT [Improvements] - Merge configure dependencies with cpanfile requirements too 1.7041 2016-05-08 11:28:31 PDT [Improvements] - Add environment variables to man pages (Doug Bell) #481 - Support --with-configure and --without-condfigure (zebardy) #482 - Make file mirror faster (Matthew Horsfall) #499 1.7040 2016-01-07 11:28:07 PST [Improvements] - Removed a workaround to skip tests for config dependencies such as Module::Build #462 - Various doc improvements 1.7039 2015-06-28 18:05:10 PDT [Improvements] - Only enable softening of MakeMaker dependency when Module::Install is present (reported by haarg) - Support .git URL with http protocol (shoichikaji) #468 1.7038 2015-06-22 18:04:44 PDT [Releng] - bump minimum perl requirement to 5.8.1 in META files 1.7037 2015-06-18 14:37:32 PDT [Improvements] - Bump CPAN-Meta-Check to 0.012 #465 - Bump HTTP-Tiny to 0.056 - Bump CPAN-Meta to 2.150005 - Bump CPAN-Meta-YAML to 0.016 1.7036 2015-06-05 22:07:50 PDT [Improvements] - Also soften MakeMaker depenency in runtime prereq, which is just a weird bug in an old Module::Install pre 1.0 1.7035 2015-06-05 10:51:17 PDT [Improvements] - Add a workaround for distributions with an old (buggy) Module::Install, now that the problems occur more frequently with 5.22.0 shipping with a dev version of ExtUtils::MakeMaker #463 1.7034 2015-05-07 14:20:57 PDT [Improvements] - Improved an error message when dependency requirement in cpanfile get conflict with prereqs in sub dependencies. 1.7033 2015-05-01 17:17:42 PDT [Improvements] - Remove MakeMaker and Module::Build from cpanm's runtime dependencies. Rather it will upgrade the minimum version requirement as it finds distributions that uses them in configure requirements. Also, they will be installed with 'notest' option for now, since Module::Build test suite takes a bit too long time. 1.7032 2015-04-29 18:51:36 PDT [Improvements] - Prefer to use cpanmetadb's package history API for pinning versions. Note that it only works against versions since April 2012. You can set `--metacpan` to still prefer MetaCPAN API search, and can use `--cascade-search` to fallback to MetaCPAN after CPAN MetaDB as well. 1.7031 2015-04-22 14:13:37 PDT [Bug Fixes] - Fixed a rare case where circular dependencies in cpanfile prevents satisfying modules from being installed. (#452) [Improvements] - Stop reporting perl versions by default if running under certain CI related env vars. 1.7030 2015-04-19 14:15:34 CEST - Same as 1.7029 1.7029 2015-04-19 00:15:32 CEST [New Features] - Consider root cpanfile's requirement when following dependencies with --installdeps (#363) - Added back --metacpan option [Improvements] - Bump Module::Metadata to 1.000027 - Bump CPAN::Meta::Check to 0.011 - Bump CPAN::Meta::YAML to 0.014 - Bump Parse::PMFile to 0.36 1.7028 2015-04-17 19:22:59 CEST [Improvements] - Keep the mirror index file as absolute (skaji) #438 - Updated the documentation about HTTPS cert warnings #441 1.7027 2015-02-14 12:14:13 PST [Improvements] - Use provides as provided in META.json and do not scan packages as PAUSE does. #435 1.7026 2015-02-13 17:11:38 PST [Improvements] - Respect provides in META file before loading from Parse::PMFile 1.7025 2015-02-07 07:58:21 CET [Improvements] - Bump Parse::PMFile to 0.35 - Bump CPAN::Meta::Check to 0.020 - Bump CPAN::Meta::Requirements to 2.132 - Bump HTTP::Tiny to 0.054 - Bump Module::Metadata to 1.000026 - Bump version.pm to 0.9912 1.7024 2015-01-12 13:31:19 PST [New Features] - Includes vendor lib and arch path to search for core modules, when installing self-contained lib by default. This behavior can be turned off with --exclude-vendor (tartansandal) #426 1.7023 2015-01-05 07:59:52 JST [Improvements] - Bump Parse::PMFile to 0.34 - Bump CPAN::Meta::Requirements to 2.131 - Bump HTTP::Tiny to 0.53 - Bump Module::Metadata to 1.000025 - Bump local::lib to 2.000015 1.7022 2014-12-12 16:41:47 PST [Improvements] - Enabled unsafe option to parse version with PMFile to avoid segfaults and weird errors 1.7021 2014-12-11 21:42:36 PST [Improvements] - Bump Parse::PMFile to 0.32 - Bump HTTP::Tiny to 0.052 1.7020 2014-12-08 17:53:18 PST [Improvements] - Bump Parse::PMFile to 0.31 1.7019 2014-12-04 12:51:41 PST [Improvements] - Bump Parse::PMFile to 0.30 1.7018 2014-11-25 14:08:41 PST [Maintenance] - bump $VERSION correctly in cpanm executable 1.7017 2014-11-25 14:00:40 PST [Improvements] - Bump fatpacked CPAN::Meta and HTTP::Tiny - Added documentation for -M and --from in man page 1.7016 2014-11-16 11:46:32 PST [New Features] - Added -M and --from to set --mirror and --mirror-only at the same time while overriding previously set mirrors (sri) #175, #417 [Improvements] - cpanmin.us is now available under HTTPS (marcus) 1.7015 2014-11-14 13:14:07 PST [Improvements] - Bump Parse::PMFile to 0.29 - Bump CPAN::Meta::Requirements to 2.129 1.7014 2014-10-07 20:52:58 PDT [Improvements] - Bump Parse::PMFile to 0.28 1.7013 2014-10-06 23:52:14 PDT [Improvements] - Update bundled JSON::PP to fix issues with JSON parsing on older perl 5.8 1.7012 2014-09-26 19:28:25 PDT [Improvements] - Upgrade CPAN::Meta and HTTP::Tiny in fatpack - Skip @INC on dev directory when running from git checkout when to search for an installed module 1.7011 2014-09-22 15:08:22 JST - Same as 1.7010. Make it a non-trial release. 1.7010 2014-09-17 18:27:53 JST [Improvements] - Use Parse::PMFile rather than our own fork (charsbar) #409 1.7009 2014-09-10 01:43:45 PDT [Bug Fixes] - Fix fatpacked executable to include Parse::CPAN::Meta 1.7008 2014-09-10 01:19:04 PDT [Improvements] - Show **** instead of *password* when masking passwords - Internal code refactoring 1.7007 2014-09-09 09:25:46 PDT [Improvements] - Make sure MetaCPAN search looks up the dist by right author #405 - Ignore Module::Build artifacts in _build when indexing modules metadata 1.7006 2014-09-05 15:44:15 PDT [Bug Fixes] - Work around MetaCPAN bugs in numifying dev release versions (#367, #377) - Bump bootstrapping MakeMaker version recent enough to support MYMETA [Incompatible Changes] - Removed undocumented --metacpan option that was only for testing purposes 1.7005 2014-09-05 05:04:06 PDT [Bug Fixes] - Do not index common directories such as t, xt or inc in install.json - Support tarball extraction on HP-UX 11 (Brian Wightman) [Improvements] - Update Parse::PMFile to 0.19 equivalent (charsbar) - Fixed various documentation (syohex, Graham Ollis) - Mask passwords when failing to download a module (andyjones) - Don't find directories when searching for executables (haarg) - Only assume Module::Build configure prereq when there's no config prereq (haarg) - Upgrade fatpacked modules to the latest 1.7004 2014-04-27 18:22:11 CEST [Bug Fixes] - Downgrade Parse::CPAN::Meta as well #373 1.7003 2014-04-27 17:11:14 CEST [Bug Fixes] - Downgrade CPAN::Meta (moznion) #372 1.7002 2014-04-27 07:45:53 CEST [Bug Fixes] - Bump fatpacked local::lib #364 - Fix a bug where build.log files are not properly renamed on the first run on Win32 (haarg) #368 1.7001 2013-09-08 13:11:16 PDT [Bug Fixes] - Fix bootstrap with perl 5.8 and MakeMaker/Module::Build (haarg) #311 1.7000 2013-09-04 15:01:34 PDT - Same as 1.6943. Some of the major changes between 1.61 are: - Add --uninstall/-U command - Support installing recommends/suggests/develop dependencies - Support features selection with --with-feature, --without-feature etc. - Support passing arguments to configure, build, test and install with --configure-args etc. - Add experimental --cpanfile option - Add experimental --pp option - Now much safer to run multiple instances of cpanm - Improved local::lib support - Improved MetaCPAN query - Improved version extraction for install metadata (for Carton) - Completely eliminated dependency on search.cpan.org 1.6943 2013-09-03 16:39:27 PDT [Bug Fixes] - Localize PERL_MB_OPT for --pureperl-only since it leaks out in build/test/install process (Thanks to doyster and leont) 1.6942 2013-08-27 11:10:40 PDT [Bug Fixes] - Fixed the date sort for developer releases with MetaCPAN #308 1.6941 2013-08-20 11:32:09 PDT [Incompatible Changes] - -v/--verbose doesn't imply --interactive anymore. It was added as a backward compatibility when --interactive was added, but i think it now does more harm than good. [RT#70041] 1.6940 2013-08-08 12:35:36 PDT [Bug Fixes] - Support extracting packages from dists without MANIFEST https://github.com/miyagawa/carton/issues/126 1.6939 2013-08-06 02:55:08 PDT [Bug Fixes] - Fix extracting version from Parse::RecDescent (lestrrat) 1.6938 2013-08-05 23:11:16 PDT [Bug Fixes] - Fix extracting version from modules with qv(). #299 (lestrrat) 1.6937 2013-08-05 18:54:31 PDT [Bug Fixes] - Fix a bug where version is not correctly scanned for VERSIONs using version.pm (lestrrat) [Improvements] - Gives a warning when local::lib directory contains spaces in its name, since it will likely cause issues with local::lib and MakeMaker #298 - Upgrade bundled CPAN::Meta, CPAN::Meta::Check, local::lib and Module::CPANfile 1.6936 2013-08-04 21:37:32 PDT [Bug Fixes] - Create correct install info for dists with ancient META.yml (tokuhirom) - Extract packages based on the sorted filenames order to eliminate randomness 1.6935 2013-07-31 11:36:03 PDT [Bug Fixes] - Fix install meta information where it populates empty key for the dist name - Collect packages from .pm.PL like PAUSE (using Parse::PMFile) - Don't display () in error messages when version is not specified [Improvements] - Display git cloning errors even under -q 1.6934 2013-07-26 16:16:57 PDT [Bug Fixes] - Fix install failure when non-array version of no_index is used in META.yml #294 1.6933 2013-07-25 09:57:38 PDT [Bug Fixes] - inline CPAN::Version since it wasn't core on older perls #293 [Improvements] - Use MANIFEST to find files to scan packages for rather than finding them 1.6932 2013-07-24 15:28:05 PDT [Bug Fixes] - Stop scanning .pm files for root installdeps target (e.g. carton apps) 1.6931 2013-07-24 14:50:59 PDT [Bug Fixes] - Use (patched) Parse::PMFile to parse packages and versions from current directory rather than Module::Metadata from blib. - Fixes a bug where install.json has bogus file path in provides - Honor no_index metadata when scanning provides from .pm files - no_index fatscript.pm since fatpacks bunch of external modules 1.6930 2013-07-24 13:46:10 PDT [Bug Fixes] - Fixed fatscript.pm being stripped, causing issues with Metadata inspection - Bumped Module::CPANfile 1.6929 2013-07-24 11:45:48 PDT [New Features] - Include App/cpanminus/fatscript.pm which is exactly the same content as cpanm. This allows both calling .pm as a script or reading the content to call with Scriptlet, which would also make fatpacking cpanm (in another program!) easier. - Removed the Share dir feature added in 1.6928 in favor of fatscript 1.6928 2013-07-23 14:10:20 PDT [New Features] - Installs cpanm executable to share dir for App-cpanminus, so that other applications can run the specific version of cpanm without relying on user's $PATH or shebang 1.6927 2013-07-23 00:44:53 PDT [New Features] - Add experimental --cpanfile option to specify alternate cpanfile location 1.6926 2013-07-20 09:02:39 PDT [Incompatible Changes] - Log messages are printed to STDOUT rather than STDERR, except errors. - --scandeps are now deprecated. Only in the documentation for now. [Bug Fixes] - Fixes a bug in printing "Expiring directories" 1.6925 2013-07-19 22:07:21 PDT [Bug Fixes] - Ignore leading/trailing spaces in PERL_CPANM_OPT #288 (ribasushi) - Stop checking dependencies with --scandeps mode #286 (tazle) [Improvements] - Mask passwords in URI when printing them in terminal and log files #281 (xdg, thaljef) - Added link to App::cpanminus::reporter #284 (garu) [New Features] - Added experimental --cpanmetadb option #279 (xdg) 1.6924 2013-07-16 11:36:56 PDT [Bug Fixes] - Sort MetaCPAN API results based on date (older one wins) to work around the issue with Crixa-0.01 (https://github.com/CPAN-API/cpan-api/issues/274) [Improvements] - Document --with-develop - Document fixes (oalders, garu) - Added Perl::Strip for develop deps if you'd like to build fatpacked binary 1.6923 2013-07-03 22:16:04 PDT [Bug Fixes] - Reverted the --skipdeps in PERL_AUTOINSTALL since it breaks default dependencies in Module::Install-based distributions 1.6922 2013-06-19 13:55:54 PDT [Improvements] - No changes in the code, packaging update so the fatpacked executable on cpanm has the right version. #274 1.6921 2013-06-18 03:18:55 PDT [Bug Fixes] - Fixes install with Module::Build < 0.35, i.e. vanilla perl 5.10.1 (Thanks to joshk for the report) - Fixes install on 5.8 with Module::Build dists without configure_requires #273 (Thanks to gildegoma for the report) 1.6920 2013-06-14 14:08:44 PDT [Improvements] - Handle PERL_LOCAL_LIB_ROOT in case multiple paths are stacked (mst) - Remove the search.cpan.org fallback where no META files exist. Generate stub using CPAN::Meta 1.6919 2013-06-12 08:32:06 PDT [Incompatible Changes] - Automatically detect local::lib mode when environment variables are already configured on the shell. This is to fix the first time run when local::lib is configure but arch library path doesn't exist. #263 1.6918 2013-06-10 13:02:06 PDT [Improvements] - Fix documentation about --quiet - Find the best (non-backpan) match out of MetaCPAN results when there are multiple results https://github.com/CPAN-API/cpan-api/issues/274 1.6917 2013-06-05 10:07:12 JST [Incompatible Changes] - build.log is now created inside a work directory, then a symlink to the file is made in ~/.cpanm. On platforms where symlink is not available (Win32), the build.log file is copied from the build directory once the installation has finished. (ilmari) 1.6916 2013-06-04 19:54:36 JST [Improvements] - Do not complain upgrading cpanm in local::lib - Accept 0-9_ in PAUSE ID (#265) 1.6915 2013-05-15 19:00:56 PDT [Improvements] - Skip LWP when HTTPS mirror is specified and SSL driver is not installed (thaljef) #258 - Fatpack Exporter to fix bootstrapping problems with perl 5.8.1/5.8.2 (tokuhirom) 1.6914 2013-05-12 16:02:28 PDT [Incompatible Changes] - When you have a 1.01 of module X and CPAN mirror has 1.00, `cpanm X` would not overwrite with 1.00, unless you specify `--reinstall`. `cpanm X@1.00` will continue installing the version (and ranges) you specify. #257 1.6913 2013-05-09 17:02:43 PDT [Improvements] - Fix download URL for 2-letter PAUSE-ID #255 - Documentation fixes 1.6912 2013-05-06 13:58:33 PDT [Bug Fixes] - `curl -L cpanmin.us | perl - --self-upgrade` should not complain about '-' not in the install path (Thanks to jdb) 1.6911 2013-05-04 13:26:17 PDT [Incompatible Changes] - Turn off automatic installation of recommendations by default, for now 1.6910 2013-05-03 00:29:22 PDT [Bug Fixes] - Do not output the "up to date" message when the requested version is higher than what's on mirror index #246 1.6909 2013-04-29 01:49:04 PDT [Improvements] - Fixed error messages and tests for #237 1.6908 2013-04-26 18:11:38 PDT [Improvements] - Stop counting failures upon installing dependencies, rather check if dependencies are satisfied once it's done. #237 1.6907 2013-04-26 11:39:00 PDT [Maintenance] - Make this a non-dev release 1.6906 2013-04-24 23:18:54 PDT [Improvements] - Fixed messaging so that downgrading says downgrades (@tsibley) #240 - Prepend space in pure-perl options so that other args can stay (@gfx) #242 - Add --skipdeps to PERL_AUTOINSTALL env for old versions of AutoInstall bundled in inc/ 1.6905 2013-04-23 20:03:36 PDT [Improvements] - Added NONINTERACTIVE_TESTING environment variables when it is not interactive per Lancaster Consensus - Added --pp, --pureperl command line option to prefer Pure perl build of the distribution which supports Lancaster Consensus 1.6904 2013-04-23 19:23:31 PDT [Bug Fixes] - Fixes installation failure when perl is in 'recommends' (sjn) #238 1.6903 2013-04-22 09:05:50 CST [New Features] - EXPERIMENTAL --uninstall/-U command to uninstall modules 1.6902 2013-04-21 09:16:46 CST - No changes, maintenance release 1.6901 2013-04-21 08:50:10 CST [Improvements] - --self-upgrade dies rather than warns when it's installed via perlbrew etc. - Fixed --version output 1.6900 2013-04-15 16:41:31 JST [Maintenance] - Remove 'cpanm' executable in the root directory from the distribution 1.6193 2013-04-15 16:36:53 JST [Maintenance] - Changed how to make a release by switching to Milla and dzil 1.6192 Sun Apr 14 17:12:52 JST 2013 [New Features] - Support features with --with-feature [Improvements] - Fixed an inconsistency when `cpanm Module@ver` always tries to reinstall the module even when you have it already, when --skip-installed is on - Display useful info about %ENV, %Config and @INC in cpanm --version 1.6191 Sun Apr 14 12:05:57 JST 2013 [New Features] - Support --configure-args [Improvements] - Use String::ShellQuote on non-Win32 systems - Strip lib files for cpanm executable as well - Support version requirements for 'perl', not just modules 1.6190 Sat Apr 13 20:44:52 JST 2013 [New Features] - Support --with-develop to install develop dependencies - Installs 'recommends' dependencies by default, but ignore failures - Add --with-suggests to also install 'suggests' dependencies [Improvements] - Overhauled Metadata handling using CPAN::Meta's validation - Stopped monkey-patching Module::Build to skip man-page generation #130 1.6108 Sat Apr 13 15:29:32 JST 2013 [Improvements] - Fix the way local::lib options are expanded - Support --configure-timeout, --build-timeout and --test-timeout - Enable PERL_MM_USE_DEFAULT in building as well - Fixed the way fatpacked modules are perl-stripped 1.6107 Sat Apr 6 21:17:57 PDT 2013 [Improvements] - strip perl files in fatlib. Reduces cpanm executable size about 100KB 1.6106 Sat Apr 6 14:18:25 PDT 2013 [Improvements] - Support git-ssh with @commit (ikasam_a) 1.6105 Thu Apr 4 22:15:44 PDT 2013 [Improvements] - Better error message when https is not supported with LWP #117 1.6104 Tue Apr 2 18:02:53 PDT 2013 [New Features] - Added --self-contained, it's like --local-lib-contained but without --local-lib (schwern) 1.6103 Sat Mar 30 14:33:07 PDT 2013 [Bug Fixes] - Fixed rare crash with version.pm loading order in perl 5.8 (tokuhirom) 1.6102 Wed Mar 27 17:14:18 PDT 2013 [Improvements] - Added a safe guard check if Module::CoreList loaded is broken/outdated (jdb) - Removed the check to see if make executable begins with quotes (jdb, charsbar) - Added to load Module::Metadata in post-installation #226 1.6101 Mon Mar 25 13:39:56 PDT 2013 [Improvements] - Always install direct test dependencies with --installdeps even when --notest option is used. This should make Travis CI users happy #222 (hide_o_55) 1.6100 Sun Mar 24 21:09:30 PDT 2013 [Improvements] - Support 'perl' key in requires (aka The Oslo Consensus) #221 (tokuhirom) - Gives warnings when pruning lots of work directories (xdg) 1.6008 Tue Mar 19 09:07:43 PDT 2013 [Improvements] - Document the link to privacy policy for perl version collection, as well as added option --no-report-perl-version to opt out 1.6007 Sun Mar 17 14:26:07 PDT 2013 [Improvements] - Fixed a warning where temp directory created with git install doesn't actually cleanup the temporary directory. (Tim Heaney) #219 1.6006 Wed Mar 13 22:53:44 PDT 2013 [Improvements] - Fixed --save-dists option when used with non-CPAN distros. They're now saved into $dir/vendor. (Dave Rolsky) #216 - Fixed PAUSE dist path where author ID is only 2 chars (Brian Cassidy) #218 1.6005 Fri Mar 8 11:46:11 PST 2013 [Improvements] - Fatpack CPAN::Meta to fix bootstrap failure with --installdeps + cpanfile 1.6004 Fri Mar 8 11:30:37 PST 2013 [Improvements] - Add perl version to User-Agent strings 1.6003 Fri Mar 8 10:57:13 PST 2013 [Improvements] - Display cpanfile syntax error if any (robario) - Fixed failure to install oddly laid out dists without blib (winfinit) 1.6002 Wed Feb 27 12:12:09 PST 2013 [Improvements] - Support parsing configure dependencies from META.json in spec 2 (kazeburo) 1.6001 Tue Feb 26 16:57:04 PST 2013 [Improvements] - Enable developer release if a specific version is requested with == or @. #203 1.6000 Tue Feb 26 09:50:57 PST 2013 [Major Changes since 1.5] - Support fixed version search with @version and ~"version range" - MetaCPAN and BackPAN search using MetaCPAN API - --dev to install developer releases - Install via git:// URL (with @branch, tag or commit) - Better MYMETA version range and cpanfile support - No fallback to search.cpan.org, which means you can't install from command names 1.59_13 Mon Feb 25 12:06:44 PST 2013 [New Features] - Support @branch (or commit or tag) in Git URLs so that you can specify a commitish to check out before installing from Git repo - Search for BackPAN by default when specific version (or range) is requested [Improvements] - Detect .zip root directory more reliably (frioux) - Fixed pathname of the CPAN distribution given as a URL (xaicron) 1.59_12 Wed Feb 13 18:13:49 PST 2013 [Internals] - Switch to metacpan_script for the new MetaCPAN query 1.59_11 Mon Feb 11 14:10:26 PST 2013 [Improvements] - Support META.json in addition to META.yml for pre-configure requirements - Fatpack JSON::PP and CPAN::Meta::YAML properly 1.59_10 Thu Feb 7 16:27:03 PST 2013 [New Features] - EXPERIMENTAL: added an ability to install from git URL (ikasam_a) [Improvements] - Exclude backpan distribution from MetaCPAN query (mo) - Add back Module::CPANfile to fatpack, accidentally deleted in a previous release - Remove CPAN::Meta from fatpack, because it's unsued yet. This reduces the file size of cpanm executable about 30%. 1.59_09 Thu Feb 7 01:55:48 PST 2013 [Improvements] - Re-enable --metacpan option to prefer MetaCPAN over CPANMetaDB for all queries, mostly for testing purpose. - Improved MetaCPAN queries in case a release have multiple modules with different versions. Also fixed a bug where it tried to extract distribution version as a module version in some cases 1.59_08 Wed Feb 6 11:25:45 PST 2013 [Bug Fixes] - Prioritize MetaCPAN when --dev option is enabled, for real 1.59_07 Wed Feb 6 11:08:05 PST 2013 [Incompatible Changes] - Disable implicit --skip-satisfied auto conversion with version specification - Do not fallback to search.cpan.org scraping anymore. This means some of the bogus search that doesn't match package name on PAUSE but returns a hit on search.cpan.org can't be installed anymore. You have to use the right package name for it. - Enable MetaCPAN search by default. --metacpan option is deprecated [New Features] - EXPERIMENTAL: --dev option to enable including developer release for searching against MetaCPAN [Improvements] - Improve MetaCPAN query to search stable releases, unless developer release is requested 1.59_06 Tue Feb 5 12:36:00 PST 2013 [Incompatible Changes] - --mirror-index option doesn't automatically assume --mirror-only [Improvements] - Use versioned MetaCPAN API endpoint (oalders) 1.59_05 Mon Feb 4 11:49:40 PST 2013 [New Features] - Support version ranges in command args and cpanfile queried agsinst MetaCPAN with the proper version range query to get the best version that satisfies the requirements. Huge thanks to #metacpan guys 1.59_04 Sun Feb 3 09:04:12 PST 2013 [Improvements] - Make file copy more reliable on Win32 (A.J. Lucas) #180 - Always send cpanminus User-Agent to the servers no matter which backend is used (curl, wget etc.) 1.59_03 Fri Feb 1 10:42:57 PST 2013 [Improvements] - Fix issues working with file:// URLs with drive letters on Win32 (A.J. Lucas) #180 - Fix home directory detection without HOME env on win32 (kmx, Christian Walde) #132 - Allow comment fields in 02packages file (Jeffrey Thalhammer) #187 1.59_02 Thu Jan 31 19:09:43 PST 2013 [New Features] - Added experimental @ shortcut to mean exact version e.g. cpanm DBI@1.20 - Support version range with "~", such as cpanm DBI~">= 1.0, < 2.0" - Enable metacpan release search when exact version is given (and when mirror-only is not specified) i.e. cpanm DBI@1.100 will fetch the exact release based on metacpan 1.59_01 Thu Jan 31 09:54:50 PST 2013 [New Features] - Added a proper support for version range in MYMETA files using CPAN::Meta::Requirements - Skip installing modules when found versions from CPAN doesn't satisfy the requirement, rather than proceeding as if it is ok. For instance, if a ditribution X requires Y >= 1.1 and Y on CPAN (or your CPAN mirror) has 1.0, cpanm will just complain and stop installing it. - Better cpanfile end-to-end support - Upgraded fatpacked modules to the latest 1.5021 Thu Jan 31 00:42:28 PST 2013 [Improvements] - Added new --verify option that enables verifying CHECKSUM and SIGNATURE for distributions from CPAN/PAUSE 1.5020 Tue Jan 29 10:29:08 PST 2013 [Bug Fixes] - Fixed a bug in --cascade-search that was checking a wrong version from 02packages file (Bryce Baril) - Added a workaround for older version of File::Temp bug (kentnl) 1.5019 Sun Dec 23 02:19:45 JST 2012 [Bug Fixes] - Fixes a bug where --installdeps fail to configure dependencies with cpanfile (hoelzro) [Improvements] - Cleaned up unused code - Added documentation about --mirror option and local file path 1.5018 Wed Sep 19 14:40:28 JST 2012 [Improvements] - Check cpanm path upon --self-upgrade to give warnings for perlbrew users 1.5017 Wed Jul 18 08:28:49 PDT 2012 [Improvements] - Ignore tarballs whose first entry is "./" (doy) #184 1.5016 Tue Jul 17 12:00:57 PDT 2012 [Improvements] - Added Module/CPANfile.pm to the fatlib. This allows bootstrapping dependencies with cpanm --installdeps on Heroku etc. 1.5015 Sun Jun 24 15:34:57 PDT 2012 [Improvements] - Improved Makefile.PL to include bugtracker info (Ben Bullock) - Fixed some merge mess with devel 1.5014 Tue Jun 12 18:27:02 PDT 2012 [Improvements] - Make sure 'f' flag becomes the last for some tar versions (mst, aaronsw) - Fixed warnings on perl 5.17+ (rjbs) - Fix local::lib error message (berekuk) 1.5013 Sat May 12 06:15:44 EEST 2012 [Bug Fixes] - Fixed --cascade-search to seach for missing modules, which was broken by #150 1.5012 Fri May 11 05:47:56 CEST 2012 [Improvements] - Change the behavior of --mirror-index so that it won't fallback to CPAN mirrors #150 (thaljef) - Support v-strings in versions specified install [https://github.com/miyagawa/carton/issues/48] 1.5011 Thu Apr 12 18:57:06 JST 2012 [Improvements] - Point default mirror to www.cpan.org #148 1.5010 Sat Mar 31 12:59:52 CEST 2012 [New Feature] - Implemented --test-only option #40 1.5009 Fri Mar 30 18:44:12 CEST 2012 [Bug Fixes] - Fixed a bug where URL containing ~ (childe) fails to install #134 - Fixed a bug where install.json contains bogus data when you specify dist paths 1.5008 Sat Mar 17 18:19:57 PDT 2012 [Bug Fixes] - Fied a bug where `cpanm Foo` doesn't properly activate local::lib during installs when you don't have write permissions #143 (goodel, ash) - Improved the warning message when you don't have write permisisons #145 (ash) 1.5007 Tue Dec 20 10:15:48 PST 2011 [Bug Fixes] - Fixed to change directory when installing from multiple local directories (motemen) [Improvements] - Stop setting AUTOMATED_TESTING (again!) and set PERL_MM_USE_DEFAULT in testing (#138) - Offer opening the build.log with PAGER when --prompt is enabled (doy) - Documentation added for --skip-installed option (AlexBio) 1.5006 Tue Nov 29 11:47:15 PST 2011 [Improvements] - Updated cpanmetadb URL to point to cpanmetadb.plackperl.org 1.5005 Tue Nov 22 13:29:27 PST 2011 [Bug Fixes] - Fixed a bug where copying meta JSON files fail on Win32 (#133, #135) 1.5004 Tue Nov 8 14:28:20 PST 2011 [Bug Fixes] - Include version of the main module instead of distribution version in install.json (pfig) 1.5003 Wed Oct 19 16:29:29 JST 2011 [Bug Fixes] - Use ExtUtils::Install to install meta files and let --sudo run it with sudo #124 1.5002 Tue Oct 18 09:06:17 JST 2011 [Bug Fixes] - Make sure to include non-core perl modules in -L that are installed in 'perl' by mistake - Ensure all module names use :: instead of dashes because of EUMM NAME errors (Christian Walde) 1.5001 Fri Oct 14 00:18:33 JST 2011 [New Features] - Added EXPERIMENTAL --metacpan support (tokuhirom) [Improvements] - Do not scan Makefile if MYMETA.yml is found - Support MYMETA.json with spec 2.0 1.5000 Thu Oct 13 15:31:13 JST 2011 [New Features] - Added EXPERIMENTAL --mirror-index, --skip-satisfied and --cascade-search options - Installs MYMETA.json and install.json into $ARCH/.meta library path [Bug Fixes] - Use Cwd::chdir to update CWD environment variable - Fix ExtUtils::ParseXS issue with -L - Fix CoreList bootstrap issue with perl < 5.8.9 when using -L - Dump more descriptive error message when configure failed with --installdeps #111 [Improvements] - Upgraded many fatlib embedded modules - Support --no-quiet - Removed ugly @INC dumping hack for -L. This causes modules that has conditional deps such as Any::Moose not to pull down necessary requirements. This is a known issue and will be addressed later. - Support special _ for -l and -L argument to respect local::lib defaults #115 1.49_02 Wed Oct 12 18:53:35 JST 2011 [Improvements] - Use Cwd::chdir to change PWD (yannk) [Bug Fixes] - Unbreak -L with newer ExtUtils::ParseXS installed [Developers] - Changed the path to save metadata information - removed Dist::Metadata use, but instead use Module::Metadata to get provides - removed the ugly DumpedINC hack for -L 1.49_01 Sun Jun 26 10:56:51 PDT 2011 - A couple of experimental new features (documented in 1.5) 1.4008 Wed Jun 15 17:58:28 PDT 2011 [Improvements] - Added experimental --skip-configure - Delay load Module::Build bootstrap so that -L won't auto-intall the latest M::B 1.4007 Tue May 17 10:51:18 PDT 2011 [Incompatible Changes] - Remove LWP from Makefile.PL dependencies, since due to the split it brings in many dependencies such as HTTP::Daemon and HTTP::Parser (which requires a C compiler). HTTP::Tiny is embedded as a last resort anyway, and if Makefile.PL is executed via some CPAN client (CPAN.pm, CPANPLUS or cpanminus) it means your client is already configured to be able to fetch files over HTTP. 1.4006 Mon May 16 10:02:45 PDT 2011 [Bug Fixes] - Proper fix for the -l option installing the same modules 1.4005 Wed May 11 12:05:49 PDT 2011 [Bug Fixes] - -l should now correctly locate installed modules to skip reinstalling. Regression in 1.4004 - Ignore Module::CoreList loading errors with -L on perl < 5.8.9 - Fixed --prompt in combination with --quiet RT:66602 - Fixed a broken Bundle:: module installation 1.4004 Thu Mar 10 10:04:28 PST 2011 [Incompatible Changes] - Fixed the issue where `ssh host cpanm Module` waits on input forever. As a side effect of fixing this bug, cpanm reads modules from STDIN only if there's no module arguments given. Options such as -L or --scandeps continu to work. #86 (Reported by dku, Getty and many people) [Bug Fixes] - Fixed a long standing bug where newer versions of bundled modules such as LWP could be loaded when combined with -L or -l, which causes API incompatiblities. - Fixed the use of gunzip (cho45) 1.4003 Wed Mar 9 18:13:21 PST 2011 - Fixed a weird bug that -L fails to bootstrap Module::Build when an old version such as 0.28 is installed - Do not show help if it reads args from STDIN and nothing is supplied - Stripped down the `cpanm` executable size for 20% by stripping POD for fatpacked dependencies :) 1.4002 Tue Mar 8 17:47:51 PST 2011 - Display configure errors in --scandeps so that configure_requires can be manually satisfied (suggested by marcus) 1.4001 Tue Mar 8 10:10:28 PST 2011 - Fixed a workaround code for META.yml being JSON (reported by leedo) 1.4000 Tue Mar 8 01:00:49 PST 2011 [New Features] - Changed the verbosity level of -q to be actually *so* useful and recommended now - Added a new option --no-man-pages to skip man page generation and installation - Added new --scandeps and --format option that scans module dependency tree before actually installing a module - Support Bundle:: modules - Added new --save-dists option See below changes between 1.30_02 and 1.30_13 for more improvements and bug fixes. 1.30_13 Mon Mar 7 10:42:01 PST 2011 - Fix for the use of Module::CoreList for perl with versions ending in 0, such as 5.13.10. - Do not attempt to upgrade Module::Build if you have the version that comes with perl 1.30_12 Sun Mar 6 18:54:41 PST 2011 - Support Bundle:: modules #81 - Fixed a bug where META.yml is being fetched for no reason. This reduces the HTTP GET calls a lot and should speed up the build process - Falls back to search.cpan.org/meta service when (and only when) META.yml is not included or unparsable. Now it can handle distributions like AnyEvent::HTTP or ancient packages better. - Fixed a bug where nmake is doubly quoted on Win32 (charsbar) #76 - Makes the wget/curl execution safer (J. Nick Koston) - Support archives where tar list begins with ./ like Image::Magick (Reported by doy) #80 1.30_11 Sun Mar 6 01:34:59 PST 2011 - Fix SIGNATURE testing for Module::Build 0.38 or later - Implemented EXPERIMENTAL --scandeps command and --format option - Implemented EXPERIMENTAL --save-tarballs option - Show (undef) in the version output instead of () 1.30_10 Sat Mar 5 14:55:16 PST 2011 - Changed how it special cases Module::Build load path in -L mode. It's much more reliable and support 0.38 with the new CPAN::Meta dependencies 1.30_09 Fri Mar 4 18:15:40 PST 2011 - Changed the verbosity level of -q|--quiet so that it prints only necessary information (instead of nothing, which is not really useful) - Shows the number of distribution in the end of the session 1.30_08 Fri Mar 4 16:04:29 PST 2011 - Renamed the option to --man-pages and --no-man-pages 1.30_07 Fri Mar 4 15:19:44 PST 2011 - Disable the man page generation by default only if -L is in use. (suggested by rjbs) 1.30_06 Fri Mar 4 14:55:35 PST 2011 - Skip the man page generation by default. You can enable it with --pod2man 1.30_05 Fri Mar 4 01:36:28 PST 2011 - Fixed the way it reduces @INC in the tests when -L is in use, so the tests that call $^X with -I can keep those library paths. i.e. Test::More 1.30_04 Fri Mar 4 00:46:24 PST 2011 - Support minor case where blib/* is manually added via -I (e.g. FCGI.pm) 1.30_03 Fri Mar 4 00:30:39 PST 2011 - Fixed a bug the modules are not loaded from blib in test_harness with -L 1.30_02 Thu Mar 3 19:53:30 PST 2011 - Fixed a bug where tests are loading modules from your site_perl even when -L is used 1.3001 Thu Mar 3 18:33:56 PST 2011 - Documentation overhaul - Fixed a bug -L will install non-core modules again and again for each run 1.3000 Wed Mar 2 14:39:44 PST 2011 - No changes since the last beta 1.29_02 Tue Mar 1 16:06:20 PST 2011 - Improved the dependencies detection when -L is in use so the core modules that have been upgraded inside can be correctly be detected, using Module::CoreList. - Added a crazy hack to support Build.PL configure dependencies > 0.36 when -L is in effect 1.29_01 Mon Feb 28 18:57:27 PST 2011 - Disable --uninstall-shadows by default for perl >= 5.12 1.2001 Wed Feb 16 10:54:21 PST 2011 - This be official 1.2 - Skips tests during the bootstrap, making a much better first time experience 1.19_02 Tue Jan 18 14:11:23 PST 2011 - Module::Metadata now requires version.pm 0.87. This makes cpanm unable to boostrap when version.pm is older than that. For now, include the pure perl version/vpp.pm and version.pm in the fatlib and then fatpacked in cpanm executable #78 1.19_01 Tue Jan 18 12:48:47 PST 2011 - Upgraded bundled modules, notably Module::Metadata and local::lib - Switched the pure perl fallback to HTTP::Tiny 1.1007 Tue Jan 18 09:39:05 PST 2011 - Fixed installation documents - Added PERL_CPANM_NO_AUTOMATED_TESTING to unset AUTOMATED_TESTING to find which modules break (mst) 1.1006 Thu Dec 16 11:27:29 PST 2010 - Fixed docs to use curl instead of wget because of its cert bug - Fixed the usage of local() where PERL5_CPANPLUS_IS_RUNING was leaking (dg) #75 1.1005 Tue Dec 14 15:07:31 PST 2010 - Accept Foo/Bar/Baz.pm style invocation in args (requested by larryl and many others) 1.1004 Tue Nov 30 10:03:01 PST 2010 - Fixed a bug where uncompressed and compressed index timestamps are out of sync which causes issues when the local and mirror server's clocks are out of sync (reported by sukria) 1.1003 Thu Nov 25 01:17:28 PST 2010 - Fixed a bug where --mirror-only doesn't detect module version updates (reported by sukria) 1.1002 Tue Nov 16 18:27:19 PST 2010 - Implemented --auto-cleanup and set that to 7 (days) by default 1.1001 Fri Nov 12 12:37:31 PST 2010 - Fixed the mirror index scanning code to uncompress on-disk and scan line-by-line to be less RAM hoggy (hobbs) - Fixed docs 1.1000 Thu Nov 11 23:56:46 PST 2010 - Added --mirror-only to support minicpan and DarkPAN (jonallen, xdg, tokuhirom) 1.0015 Fri Sep 24 16:51:49 PDT 2010 - Fixed the output introcuced in the previous release 1.0014 Tue Sep 21 12:42:28 PDT 2010 - Added "--> Working on ..." output for a better understanding of overall build process 1.0013 Sun Sep 12 12:46:36 PDT 2010 - Added --no-wget and --no-curl to bootstrap LWP in an environment with old versions of wget/curl (rsp) 1.0012 Fri Aug 20 12:46:34 PDT 2010 - version check with -L and -l was failing with --skip-installed default. Now fixed (reported by leedo) #55 - Fixed the code to find root of tarballs (perlpilot) 1.0011 Wed Aug 18 16:38:24 PDT 2010 - -f now implies --reinstall (perigrin) 1.0010 Fri Jul 30 12:54:03 PDT 2010 - Make --skip-installed as default - Revised documentations 1.0006 Fri Jul 2 16:52:06 PDT 2010 - Use module's version number instead of distribution when to display whether this is an upgrade or reinstall (doy) #43 1.0005 Fri Jul 2 16:36:55 PDT 2010 - Clarified that the minimal perl version supported is 5.8 (chocolateboy) - Now being able to look when configure and build fails - Automatically disable uninstall_shadows when local::lib is used. This bug was causing cpanm to remove modules in @INC with perl 5.10 or older (kazeburo, sugyan) 1.0004 Fri May 14 16:08:23 PDT 2010 - Do not use Cwd::abs_path if the -l path begins with / (rafl) - Skipping perl should now be considered as success, not failure (rafl) - Fixed PREREQ_PM scanner for dists that conflict with core functions such as UNIVERSAL::isa (yannk) - --look should now imply --no-skip-installed (doy) #45 1.0003 Tue May 4 16:12:53 PDT 2010 - Worked around win32 fork and stdout dup issue (xaicron, charsbar) 1.0002 Sat May 1 20:49:39 PDT 2010 - Fixed docs - Fallback to the version of the distribution filename when META.yml is not parsable 1.0001 Sat Apr 24 16:20:56 CST 2010 - Make this 1.0! 0.999_05 Wed Apr 21 20:37:25 JST 2010 [Bug Fixes] - Fixed the timing to make -l and -L an abstract path (ash) 0.999_04 Mon Apr 19 15:21:01 JST 2010 [Bug Fixes] - Fixed installationg from arbitrary URLs or file paths 0.999_03 Wed Apr 14 02:26:28 PDT 2010 [Improvements] - Fixed a problem when uninstalling shadows fail with an old ExtUtils::Install by bootstrapping it to require 1.46 0.999_02 Tue Apr 13 09:08:00 CEST 2010 [Improvements] - Improved --skip-installed so sub packages version in a distribution can be compared correctly - --look command is now back, per popular demands [Bug Fixes] - Fixed broken configure_requires in 0.999_01 0.999_01 Mon Apr 12 12:24:57 CEST 2010 This is the first release candidate for 1.00 [INCOMPATIBLE CHANGES] - Do not support (undocumented) CPANMINUS_* environment variable anymore. Use PERL_CPANM_* instead - Plugins are not supported anymore. They will be available as part of a new client! - Deleted --look command - Deleted --recent command [Improvements] - Get metadata from search.cpan.org before fetching tarballs, which makes commands like --info or --skip-installed much faster. #3, #8, #9 - Added --mirror option where you can specify the mirror base URL - Added --prompt option that asks users to skip, force install, retry or look when test fails #23 - When one of the dependencies fail to install, cpanm bails out the installation of source dist by default. --prompt will ask if you want to install anyway - Added a man page for cpanm [Developer Fixes] - Do not display 'Already tried...' message by default - Set non-zero exit code if one or more modules failed to build 0.9934 Sun Apr 11 13:53:07 CEST 2010 [Developer Fixes] - Unlink MYMETA.yml after the configuration to avoid failing Module::Signature tests - Always run make install UNINST=1. You can disable it with --no-uninst-shadows #26 0.99_33 Sun Apr 11 09:44:16 CEST 2010 [Improvements] - Delay load Archive::Zip #38 (Tim Bunce) - Made wget download more fault torelant #15 [Bug Fixes] - Work around the situation where installsitelib doesn't exist yet #2 [Developer Fixes] - Upgrade local::lib #33 - Delay local::lib configuration as late as possible #35 (doy) - Redirect tar's stderr (stoned) - Shows an error message when CPANM home is not writable #37 (avar) - Fixed how to handle duplicated dependencies #6, #32 - Indicate test failures with --force #22 (rafl) 0.9932 Mon Apr 5 16:27:12 PDT 2010 [Developer Fixes] - Special case deprecated modules so they can be upgraded into site lib #34 0.9931 Sun Apr 4 18:16:46 PDT 2010 [Developer Fixes] - Doesn't close STDIN anymore when building modules. Instead set AUTOMATED_TESTING #36 0.9930 Tue Mar 30 14:27:49 PDT 2010 [Improvements] - untar now works with Solaris' stock bad tar (nnunley) 0.9929 Fri Mar 26 21:35:23 PDT 2010 [Improvements] - Make cpanm work with perl 5.10.0 with old version.pm [Developer Fixes] - Stopped using Safe.pm reval() to parse Makefile or _build/prereqs 0.9928 Thu Mar 25 22:03:36 PDT 2010 [Bug Fixes] - Make PERL_CPANM_OPT=~/perl work again (clkao) [Developer Fixes] - Document --skip-installed 0.9927 Tue Mar 23 11:23:18 PDT 2010 [Improvements] - Suppress warnings when initializing local::lib directory [Developer Fixes] - Fixes -L with local::lib enabled shell 0.99_26 Mon Mar 22 20:22:10 PDT 2010 [Developer Fixes] - Fixed the broken delay loaded LWP runtime in -L - Actually changed how -L sets up @INC so that it won't affect the current cpanm process at all which is more correct way to deal with this. 0.99_25 Mon Mar 22 19:52:12 PDT 2010 [Improvements] - Log version information of build tools in build.log [Developer Fixes] - Fixed the way it passes DumpedINC - Fixes tools initialization like LWP with -L - Set PID in PERL5_CPAN*_IS_RUNNING rather than just 1 0.99_24 Sun Mar 21 21:57:59 PDT 2010 [Improvements] - Improve the error message on bootstrapping - Implemented experimental -L|--local-lib-contained option to install module and its non-core dependencies into local::lib directory [Developer Fixes] - Use Module::Metadata and avoid calling another perl interpreter to check the installed versions of the modules - Also dump @INC into a file DumpedINC.pm when self-contained is enabled - Set PERL5_CPANM_IS_RUNNING in configure - Changed the way to pack modules into a file, now using App::FatPacker 0.9923 Mon Mar 15 17:03:14 PDT 2010 [Improvements] - Improved docs (chromatic) [Developer Fixes] - Added a dummy test to make CPAN testers happy (gfx) 0.9922 Thu Mar 11 10:56:10 JST 2010 [Improvements] - Possibly support bad tar (GNU tar 1.13 or 1.22 on Win32) (mattn) [Developer Fixes] - Support building with Module::Build < 0.36 - Use Safe to eval some code when scanning prereqs 0.9921 Wed Mar 10 23:59:49 JST 2010 [Bug Fixes] - Fixed an occasional STDIN related errors in tests (lestrrat) - Fixed a bug where cpanm /path/to/dir doesn't work [Developer Fixes] - Once bootstrap is done, return to the original current dir rather than work dir so that `cpanm .` still looks at the (right) current directory 0.99_20 Wed Mar 10 18:46:45 JST 2010 [Developer Fixes] - Prefer Build.PL except some exceptions such as Module::Build dependencies 0.9919 Wed Mar 10 11:39:35 JST 2010 [Bug Fixes] - Fixed Module::Build distribution, broken in 0.9917 (rafl) 0.9918 Wed Mar 10 11:19:35 JST 2010 [Bug Fixes] - Fix --sudo broken in 0.9917 (omega) 0.9917 Tue Mar 9 22:51:21 JST 2010 [Improvements] - Do not wait on input on bad tests waiting on STDIN (except on some Win32 environments) [Developer Fixes] - Do not uses system() when running Makefile.PL or make etc. but uses fork & exec (tokuhirom) - Depend on newer LWP that has decoded_content - Do not overwrite verbose internal flag (mst) 0.9916 Thu Mar 4 11:33:16 PST 2010 [Developer Fixes] - Use 'distfile' as cpanmetadb key rather than 'dist' (rjbs, xdg) 0.9915 Thu Mar 4 01:56:06 PST 2010 [Developer Fixes] - Fixed circular references (hopefully) 0.9914 Thu Mar 4 00:39:49 PST 2010 [Improvements] - Use cpanmetadb for the faster and more reliable lookup [Developer Fixes] - Fixed ->get on LWP to return undef when the request errored out 0.9913 Tue Mar 2 19:20:34 PST 2010 [Bug fixes] - Fixes --recent and --list-plugins to work again 0.9912 Tue Mar 2 18:50:23 PST 2010 [Improvements] - Some boolean options can now be set to PERL_CPANM_OPT but can be negated using the --no- prefix such as --no-sudo - Directory mode now only works if it begins with / or . [Developer fixes] - --self-upgrade skips if it's already the latest - Improved perl Makefile.PL --author - --help and --version won't bother ~/perl5 initialization (rjbs, ingy) - LWP dependency is injected only if you run from CPAN clients (ingy, marcus) 0.9911 Mon Mar 1 16:27:52 PST 2010 [Developer fixes] - Removed build_timeout and test_timeout by default (rafl) [Bug fixes] - Fixed broken --self-upgrade (chocolateboy) 0.9910 Sun Feb 28 21:56:30 PST 2010 [Improvements] - wget cpanm | perl - should now work better (hachi, dormando) [Developer fixes] - Always use forward slashes even if it's on win32 (charsbar, xaicron) - Check installsitebin (charsbar) - Stop setting AUTOMATED_TESTING 0.99_07 Sat Feb 27 21:05:08 PST 2010 [Improvements] - Bootstrap local::lib directory in ~/perl5 for the first run - Bootstrap ExtUtils::MakeMaker, ExtUtils::Install and Module::Build in the first run - Support --local-lib|-l option to specify which path to set local::lib dir - Added PERL_CPANM_OPT command line option to add global command line options - Support curl fallback (squeeky, gfx) - Improved the installation success message to indicate it is a new, upgrade or reinstall of the distribution - Improved the error message in configure failure - Fall back to embedded HTTP::Lite when any of LWP/wget/curl is unavailable - Support piping module/dist for cpanm command, like `cat module_list | cpanm` - Added --skip-installed option which makes cpanm behave like cpan - Documented how to upgrade cpanm itself [Developer fixes] - Remove LWP::Simple and switch to LWP::UserAgent - Create a temp file first when to generate standalone executable (gfx) - cpanm (without argument) will output a shorten help - Changed the NO_LWP env var to --no-lwp option - Improved the permission check to also check sitebin directory - Added --author option to Makefile.PL to generate cpanm from git repo (gfx) - Introduced $depth parameter when installing dependencies. Unused in any places yet 0.99_06 Thu Feb 25 14:50:51 PST 2010 - Fixed packaging and VERSION 0.99_05 Thu Feb 25 14:39:07 PST 2010 [Developer fixes] - Changed the way 'cpanm' standalone script is generated - Developers checking out from git should use script/cpanm.PL for test drive 0.99_04 Thu Feb 25 09:11:44 PST 2010 [Improvements] - Supported modules and packages without POD on search.cpan.org - --look command now works on Win32 (charsbar, xaicron) - Improved the error message when configure fails (tokuhirom) - Supported modules with .tgz format archive (frew) - Supported older LWP < 5.828 (chocolateboy) [Developer fixes] - Improved the way it checks configuration results (mst, confound, rjbs, LeoNerd) - Killed the automatic Build.PL stub generation because it doesn't work. - Support PERL_MB_OPT in the sanity check - Adds PERL5_CPANPLUS_IS_RUNNING to work with older Module::AutoInstall < 0.73 (Alias) - Changed the way plugins check api_version - Rewrote internals for the at_exit hook and removed Util:: functions (vincent, mst, ewhilhelm) 0.99_03 Tue Feb 23 23:03:20 PST 2010 [Bug fixes] - .zip support didn't go through the proper merge process. Now merged 0.99_02 Tue Feb 23 22:13:46 PST 2010 [Improvements] - Limit the number of --recent to 50 [Bug fixes] - Work around with broken LWP installations (yannk) [Developer fixes] - Updated cpandb URI (BinGOs) - Standardize env var keys to PERL_CPANM_* so `env | grep PERL` can be used (miyagawa, mst) - Added ->env method - Added PERL_CPANM_NO_LWP=1 so it can upgrade LWP without LWP - Move documents to lib/App/cpanminus.pm 0.99_01 Tue Feb 23 12:31:56 PST 2010 [Improvements] - Improved the duplicated or circular dependent package detections (gfx, Yappo) - Improved the progressive message format - Support .zip files (sekimura) - Added --look command, like CPAN shell's look - Added --recent command that shows you the recent updated modules - Added --interactive option, good middleground when installing Task:: modules - Added --self-upgrade (NOTE: it will downgrade to the stable if you run from the dev release!) - Fixed the installation doc to prefer git over CPAN shell - Documented that you need GNU tar >= 1.22 - Wraps configure and test with alarm timeout to not choke on bad dists (hirose31, yappo, tokuhirom) [Bug fixes] - Fixed a bug where log appending fails on Win32 (xaicron) - Various fixes on win32 (charsbar) - Fixed a bug failing on dists with dual Build.PL/Makefile.PL (mst, aperion) - Fixed a bug where build/ directory is treated as Module::Build's Build file on HFS [Developer fixes] - Rewrote the internal using a sane and simple object oriented programming - Changed the ~/.cpanm directroy layout - much easier to dig through - Rewrote the documentation to be less defensive - set AUTOMATED_TESTING when testing a distribution - Mentions pip in the doc (chocolateboy, adamk) - Support cpan:// URI - Added --perl option to specify which perl path to use (mst) - Specify minimum versions for ExtUtils::MakeMaker, Module::Build and ExtUtils::Install [Beta features] - Implemented plugin architectures - this is unstable and turned off by default 0.09 Sat Feb 20 23:47:16 PST 2010 - Fixed the way archives are untared - Log file is now always ~/.cpanm/build.log - Improve the diag message - Made quiet mode the default. Use -v|--verbose to make it chatty like CPAN(PLUS) - Added retry for HTTP downloads - Fixed the way it generates a stub Build.PL when make is not available 0.08 Sat Feb 20 15:36:53 PST 2010 - Implemented --installdeps - Implemented -q|--quiet that makes you a peaceful install experience - Relaxed the defensive docs a little bit since many people love the idea 0.07 Sat Feb 20 12:17:56 PST 2010 - Fixed packaging -- standalone cpanm file now has '/usr/bin/env perl' in shebang but CPAN dist has #!perl (so EUMM can fix it) - Added -i for cpan compatibility - Fixed the way to get VERSION from modules 0.06 Fri Feb 19 21:48:09 PST 2010 - Fixed the command detection in win32 - Make C-c work when downloading tar balls - perl 5.6 compat (i think) - Fixed packaging again 0.05 Fri Feb 19 21:15:20 PST 2010 - Fixed no warranty copy 0.04 Fri Feb 19 21:01:10 PST 2010 - Added -v - Changed how to get dependencies to be more sensible and #toolchain friendly by supporting MYMETA.yml etc. - Added NO WARRANTY 0.03 Fri Feb 19 19:38:30 PST 2010 - Fixed packaging - Make local file install work without LWP (hopefully) 0.02 Fri Feb 19 19:13:03 PST 2010 - arguments to cpanm can now be a directory, file, URI or CPAN tarball name 0.01 Fri Feb 19 18:24:04 PST 2010 - Initial version to CPAN PK jA[ ,1�x x MANIFEST.SKIPnu �[��� \.git-placeholder dist\.ini lib/App/cpanminus/(?!fatscript) ^fatlib/ ^plugins/ ^script/ ^maint/ ^xt/ ^testdist/ ^cpanm$ PK jA[���O cpanfilenu �[��� requires 'perl', '5.008001'; on test => sub { requires 'Test::More'; }; on develop => sub { requires 'App::FatPacker'; requires 'CPAN::DistnameInfo'; requires 'CPAN::Meta', '2.132830'; requires 'CPAN::Meta::Check'; requires 'CPAN::Meta::Prereqs'; requires 'CPAN::Meta::Requirements'; requires 'CPAN::Meta::YAML'; requires 'Digest::SHA'; requires 'Exporter', '5.63'; requires 'File::Temp'; requires 'File::pushd'; requires 'Getopt::Long'; requires 'HTTP::Tiny'; requires 'JSON'; requires 'JSON::PP'; requires 'LWP::Simple'; requires 'LWP::UserAgent', '5.802'; requires 'Module::Install'; requires 'Module::CPANfile'; requires 'Module::CoreList'; requires 'Module::Metadata'; requires 'Parse::CPAN::Meta'; requires 'String::ShellQuote'; requires 'YAML'; requires 'YAML::Tiny'; requires 'local::lib'; requires 'version'; requires 'Capture::Tiny'; requires 'Test::Requires'; requires 'Test::More', '0.90'; requires 'Perl::Strip'; requires 'Parse::PMFile', '0.26'; requires 'Tie::File'; recommends 'Archive::Tar'; recommends 'Archive::Zip'; recommends 'Compress::Zlib'; recommends 'File::HomeDir'; recommends 'Module::Signature'; }; PK jA[�Kd>�t �t Makefilenu �[��� # This Makefile is for the App::cpanminus extension to perl. # # It was generated automatically by MakeMaker version # 7.60 (Revision: 76000) from the contents of # Makefile.PL. Don't edit this file, edit Makefile.PL instead. # # ANY CHANGES MADE HERE WILL BE LOST! # # MakeMaker ARGV: () # # MakeMaker Parameters: # ABSTRACT => q[get, unpack, build and install modules from CPAN] # AUTHOR => [q[- Tatsuhiko Miyagawa]] # BUILD_REQUIRES => { } # CONFIGURE_REQUIRES => { ExtUtils::MakeMaker=>q[0] } # DISTNAME => q[App-cpanminus] # EXE_FILES => [q[bin/cpanm]] # LICENSE => q[perl] # MIN_PERL_VERSION => q[5.008001] # NAME => q[App::cpanminus] # PREREQ_PM => { Test::More=>q[0] } # TEST_REQUIRES => { Test::More=>q[0] } # VERSION => q[1.7047] # test => { TESTS=>q[t/*.t] } # --- MakeMaker post_initialize section: # --- MakeMaker const_config section: # These definitions are from config.sh (via /usr/lib64/perl5/Config.pm). # They may have been overridden via Makefile.PL or on the command line. AR = ar CC = gcc CCCDLFLAGS = -fPIC CCDLFLAGS = -Wl,--enable-new-dtags -Wl,-z,relro -Wl,--as-needed -Wl,-z,now -specs=/usr/lib/rpm/redhat/redhat-hardened-ld -specs=/usr/lib/rpm/redhat/redhat-annobin-cc1 DLEXT = so DLSRC = dl_dlopen.xs EXE_EXT = FULL_AR = /usr/bin/ar LD = gcc LDDLFLAGS = -lpthread -shared -Wl,-z,relro -Wl,--as-needed -Wl,-z,now -specs=/usr/lib/rpm/redhat/redhat-hardened-ld -specs=/usr/lib/rpm/redhat/redhat-annobin-cc1 -L/usr/local/lib -fstack-protector-strong LDFLAGS = -Wl,-z,relro -Wl,--as-needed -Wl,-z,now -specs=/usr/lib/rpm/redhat/redhat-hardened-ld -specs=/usr/lib/rpm/redhat/redhat-annobin-cc1 -fstack-protector-strong -L/usr/local/lib LIBC = /lib/../lib64/libc.so.6 LIB_EXT = .a OBJ_EXT = .o OSNAME = linux OSVERS = 4.18.0-513.18.1.el8_9.x86_64 RANLIB = : SITELIBEXP = /usr/local/share/perl5/5.32 SITEARCHEXP = /usr/local/lib64/perl5/5.32 SO = so VENDORARCHEXP = /usr/lib64/perl5/vendor_perl VENDORLIBEXP = /usr/share/perl5/vendor_perl # --- MakeMaker constants section: AR_STATIC_ARGS = cr DIRFILESEP = / DFSEP = $(DIRFILESEP) NAME = App::cpanminus NAME_SYM = App_cpanminus VERSION = 1.7047 VERSION_MACRO = VERSION VERSION_SYM = 1_7047 DEFINE_VERSION = -D$(VERSION_MACRO)=\"$(VERSION)\" XS_VERSION = 1.7047 XS_VERSION_MACRO = XS_VERSION XS_DEFINE_VERSION = -D$(XS_VERSION_MACRO)=\"$(XS_VERSION)\" INST_ARCHLIB = blib/arch INST_SCRIPT = blib/script INST_BIN = blib/bin INST_LIB = blib/lib INST_MAN1DIR = blib/man1 INST_MAN3DIR = blib/man3 MAN1EXT = 1 MAN3EXT = 3pm MAN1SECTION = 1 MAN3SECTION = 3 INSTALLDIRS = site DESTDIR = PREFIX = $(SITEPREFIX) PERLPREFIX = /usr SITEPREFIX = /usr/local VENDORPREFIX = /usr INSTALLPRIVLIB = /usr/share/perl5 DESTINSTALLPRIVLIB = $(DESTDIR)$(INSTALLPRIVLIB) INSTALLSITELIB = /usr/local/share/perl5/5.32 DESTINSTALLSITELIB = $(DESTDIR)$(INSTALLSITELIB) INSTALLVENDORLIB = /usr/share/perl5/vendor_perl DESTINSTALLVENDORLIB = $(DESTDIR)$(INSTALLVENDORLIB) INSTALLARCHLIB = /usr/lib64/perl5 DESTINSTALLARCHLIB = $(DESTDIR)$(INSTALLARCHLIB) INSTALLSITEARCH = /usr/local/lib64/perl5/5.32 DESTINSTALLSITEARCH = $(DESTDIR)$(INSTALLSITEARCH) INSTALLVENDORARCH = /usr/lib64/perl5/vendor_perl DESTINSTALLVENDORARCH = $(DESTDIR)$(INSTALLVENDORARCH) INSTALLBIN = /usr/bin DESTINSTALLBIN = $(DESTDIR)$(INSTALLBIN) INSTALLSITEBIN = /usr/local/bin DESTINSTALLSITEBIN = $(DESTDIR)$(INSTALLSITEBIN) INSTALLVENDORBIN = /usr/bin DESTINSTALLVENDORBIN = $(DESTDIR)$(INSTALLVENDORBIN) INSTALLSCRIPT = /usr/bin DESTINSTALLSCRIPT = $(DESTDIR)$(INSTALLSCRIPT) INSTALLSITESCRIPT = /usr/local/bin DESTINSTALLSITESCRIPT = $(DESTDIR)$(INSTALLSITESCRIPT) INSTALLVENDORSCRIPT = /usr/bin DESTINSTALLVENDORSCRIPT = $(DESTDIR)$(INSTALLVENDORSCRIPT) INSTALLMAN1DIR = /usr/share/man/man1 DESTINSTALLMAN1DIR = $(DESTDIR)$(INSTALLMAN1DIR) INSTALLSITEMAN1DIR = /usr/local/share/man/man1 DESTINSTALLSITEMAN1DIR = $(DESTDIR)$(INSTALLSITEMAN1DIR) INSTALLVENDORMAN1DIR = /usr/share/man/man1 DESTINSTALLVENDORMAN1DIR = $(DESTDIR)$(INSTALLVENDORMAN1DIR) INSTALLMAN3DIR = /usr/share/man/man3 DESTINSTALLMAN3DIR = $(DESTDIR)$(INSTALLMAN3DIR) INSTALLSITEMAN3DIR = /usr/local/share/man/man3 DESTINSTALLSITEMAN3DIR = $(DESTDIR)$(INSTALLSITEMAN3DIR) INSTALLVENDORMAN3DIR = /usr/share/man/man3 DESTINSTALLVENDORMAN3DIR = $(DESTDIR)$(INSTALLVENDORMAN3DIR) PERL_LIB = /usr/share/perl5 PERL_ARCHLIB = /usr/lib64/perl5 PERL_ARCHLIBDEP = /usr/lib64/perl5 LIBPERL_A = libperl.a FIRST_MAKEFILE = Makefile MAKEFILE_OLD = Makefile.old MAKE_APERL_FILE = Makefile.aperl PERLMAINCC = $(CC) PERL_INC = /usr/lib64/perl5/CORE PERL_INCDEP = /usr/lib64/perl5/CORE PERL = "/usr/bin/perl" FULLPERL = "/usr/bin/perl" ABSPERL = $(PERL) PERLRUN = $(PERL) FULLPERLRUN = $(FULLPERL) ABSPERLRUN = $(ABSPERL) PERLRUNINST = $(PERLRUN) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" FULLPERLRUNINST = $(FULLPERLRUN) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" ABSPERLRUNINST = $(ABSPERLRUN) "-I$(INST_ARCHLIB)" "-I$(INST_LIB)" PERL_CORE = 0 PERM_DIR = 755 PERM_RW = 644 PERM_RWX = 755 MAKEMAKER = /usr/share/perl5/vendor_perl/ExtUtils/MakeMaker.pm MM_VERSION = 7.60 MM_REVISION = 76000 # FULLEXT = Pathname for extension directory (eg Foo/Bar/Oracle). # BASEEXT = Basename part of FULLEXT. May be just equal FULLEXT. (eg Oracle) # PARENT_NAME = NAME without BASEEXT and no trailing :: (eg Foo::Bar) # DLBASE = Basename part of dynamic library. May be just equal BASEEXT. MAKE = make FULLEXT = App/cpanminus BASEEXT = cpanminus PARENT_NAME = App DLBASE = $(BASEEXT) VERSION_FROM = OBJECT = LDFROM = $(OBJECT) LINKTYPE = dynamic BOOTDEP = # Handy lists of source code files: XS_FILES = C_FILES = O_FILES = H_FILES = MAN1PODS = bin/cpanm MAN3PODS = lib/App/cpanminus.pm \ lib/App/cpanminus/fatscript.pm # Where is the Config information that we are using/depend on CONFIGDEP = $(PERL_ARCHLIBDEP)$(DFSEP)Config.pm $(PERL_INCDEP)$(DFSEP)config.h # Where to build things INST_LIBDIR = $(INST_LIB)/App INST_ARCHLIBDIR = $(INST_ARCHLIB)/App INST_AUTODIR = $(INST_LIB)/auto/$(FULLEXT) INST_ARCHAUTODIR = $(INST_ARCHLIB)/auto/$(FULLEXT) INST_STATIC = INST_DYNAMIC = INST_BOOT = # Extra linker info EXPORT_LIST = PERL_ARCHIVE = PERL_ARCHIVEDEP = PERL_ARCHIVE_AFTER = TO_INST_PM = lib/App/cpanminus.pm \ lib/App/cpanminus/fatscript.pm # --- MakeMaker platform_constants section: MM_Unix_VERSION = 7.60 PERL_MALLOC_DEF = -DPERL_EXTMALLOC_DEF -Dmalloc=Perl_malloc -Dfree=Perl_mfree -Drealloc=Perl_realloc -Dcalloc=Perl_calloc # --- MakeMaker tool_autosplit section: # Usage: $(AUTOSPLITFILE) FileToSplit AutoDirToSplitInto AUTOSPLITFILE = $(ABSPERLRUN) -e 'use AutoSplit; autosplit($$$$ARGV[0], $$$$ARGV[1], 0, 1, 1)' -- # --- MakeMaker tool_xsubpp section: # --- MakeMaker tools_other section: SHELL = /bin/sh CHMOD = chmod CP = cp MV = mv NOOP = $(TRUE) NOECHO = @ RM_F = rm -f RM_RF = rm -rf TEST_F = test -f TOUCH = touch UMASK_NULL = umask 0 DEV_NULL = > /dev/null 2>&1 MKPATH = $(ABSPERLRUN) -MExtUtils::Command -e 'mkpath' -- EQUALIZE_TIMESTAMP = $(ABSPERLRUN) -MExtUtils::Command -e 'eqtime' -- FALSE = false TRUE = true ECHO = echo ECHO_N = echo -n UNINST = 0 VERBINST = 0 MOD_INSTALL = $(ABSPERLRUN) -MExtUtils::Install -e 'install([ from_to => {@ARGV}, verbose => '\''$(VERBINST)'\'', uninstall_shadows => '\''$(UNINST)'\'', dir_mode => '\''$(PERM_DIR)'\'' ]);' -- DOC_INSTALL = $(ABSPERLRUN) -MExtUtils::Command::MM -e 'perllocal_install' -- UNINSTALL = $(ABSPERLRUN) -MExtUtils::Command::MM -e 'uninstall' -- WARN_IF_OLD_PACKLIST = $(ABSPERLRUN) -MExtUtils::Command::MM -e 'warn_if_old_packlist' -- MACROSTART = MACROEND = USEMAKEFILE = -f FIXIN = $(ABSPERLRUN) -MExtUtils::MY -e 'MY->fixin(shift)' -- CP_NONEMPTY = $(ABSPERLRUN) -MExtUtils::Command::MM -e 'cp_nonempty' -- # --- MakeMaker makemakerdflt section: makemakerdflt : all $(NOECHO) $(NOOP) # --- MakeMaker dist section: TAR = tar TARFLAGS = cvf ZIP = zip ZIPFLAGS = -r COMPRESS = gzip --best SUFFIX = .gz SHAR = shar PREOP = $(NOECHO) $(NOOP) POSTOP = $(NOECHO) $(NOOP) TO_UNIX = $(NOECHO) $(NOOP) CI = ci -u RCS_LABEL = rcs -Nv$(VERSION_SYM): -q DIST_CP = best DIST_DEFAULT = tardist DISTNAME = App-cpanminus DISTVNAME = App-cpanminus-1.7047 # --- MakeMaker macro section: # --- MakeMaker depend section: # --- MakeMaker cflags section: # --- MakeMaker const_loadlibs section: # --- MakeMaker const_cccmd section: # --- MakeMaker post_constants section: # --- MakeMaker pasthru section: PASTHRU = LIBPERL_A="$(LIBPERL_A)"\ LINKTYPE="$(LINKTYPE)"\ PREFIX="$(PREFIX)"\ PASTHRU_DEFINE='$(DEFINE) $(PASTHRU_DEFINE)'\ PASTHRU_INC='$(INC) $(PASTHRU_INC)' # --- MakeMaker special_targets section: .SUFFIXES : .xs .c .C .cpp .i .s .cxx .cc $(OBJ_EXT) .PHONY: all config static dynamic test linkext manifest blibdirs clean realclean disttest distdir pure_all subdirs clean_subdirs makemakerdflt manifypods realclean_subdirs subdirs_dynamic subdirs_pure_nolink subdirs_static subdirs-test_dynamic subdirs-test_static test_dynamic test_static # --- MakeMaker c_o section: # --- MakeMaker xs_c section: # --- MakeMaker xs_o section: # --- MakeMaker top_targets section: all :: pure_all manifypods $(NOECHO) $(NOOP) pure_all :: config pm_to_blib subdirs linkext $(NOECHO) $(NOOP) subdirs :: $(MYEXTLIB) $(NOECHO) $(NOOP) config :: $(FIRST_MAKEFILE) blibdirs $(NOECHO) $(NOOP) help : perldoc ExtUtils::MakeMaker # --- MakeMaker blibdirs section: blibdirs : $(INST_LIBDIR)$(DFSEP).exists $(INST_ARCHLIB)$(DFSEP).exists $(INST_AUTODIR)$(DFSEP).exists $(INST_ARCHAUTODIR)$(DFSEP).exists $(INST_BIN)$(DFSEP).exists $(INST_SCRIPT)$(DFSEP).exists $(INST_MAN1DIR)$(DFSEP).exists $(INST_MAN3DIR)$(DFSEP).exists $(NOECHO) $(NOOP) # Backwards compat with 6.18 through 6.25 blibdirs.ts : blibdirs $(NOECHO) $(NOOP) $(INST_LIBDIR)$(DFSEP).exists :: Makefile.PL $(NOECHO) $(MKPATH) $(INST_LIBDIR) $(NOECHO) $(CHMOD) $(PERM_DIR) $(INST_LIBDIR) $(NOECHO) $(TOUCH) $(INST_LIBDIR)$(DFSEP).exists $(INST_ARCHLIB)$(DFSEP).exists :: Makefile.PL $(NOECHO) $(MKPATH) $(INST_ARCHLIB) $(NOECHO) $(CHMOD) $(PERM_DIR) $(INST_ARCHLIB) $(NOECHO) $(TOUCH) $(INST_ARCHLIB)$(DFSEP).exists $(INST_AUTODIR)$(DFSEP).exists :: Makefile.PL $(NOECHO) $(MKPATH) $(INST_AUTODIR) $(NOECHO) $(CHMOD) $(PERM_DIR) $(INST_AUTODIR) $(NOECHO) $(TOUCH) $(INST_AUTODIR)$(DFSEP).exists $(INST_ARCHAUTODIR)$(DFSEP).exists :: Makefile.PL $(NOECHO) $(MKPATH) $(INST_ARCHAUTODIR) $(NOECHO) $(CHMOD) $(PERM_DIR) $(INST_ARCHAUTODIR) $(NOECHO) $(TOUCH) $(INST_ARCHAUTODIR)$(DFSEP).exists $(INST_BIN)$(DFSEP).exists :: Makefile.PL $(NOECHO) $(MKPATH) $(INST_BIN) $(NOECHO) $(CHMOD) $(PERM_DIR) $(INST_BIN) $(NOECHO) $(TOUCH) $(INST_BIN)$(DFSEP).exists $(INST_SCRIPT)$(DFSEP).exists :: Makefile.PL $(NOECHO) $(MKPATH) $(INST_SCRIPT) $(NOECHO) $(CHMOD) $(PERM_DIR) $(INST_SCRIPT) $(NOECHO) $(TOUCH) $(INST_SCRIPT)$(DFSEP).exists $(INST_MAN1DIR)$(DFSEP).exists :: Makefile.PL $(NOECHO) $(MKPATH) $(INST_MAN1DIR) $(NOECHO) $(CHMOD) $(PERM_DIR) $(INST_MAN1DIR) $(NOECHO) $(TOUCH) $(INST_MAN1DIR)$(DFSEP).exists $(INST_MAN3DIR)$(DFSEP).exists :: Makefile.PL $(NOECHO) $(MKPATH) $(INST_MAN3DIR) $(NOECHO) $(CHMOD) $(PERM_DIR) $(INST_MAN3DIR) $(NOECHO) $(TOUCH) $(INST_MAN3DIR)$(DFSEP).exists # --- MakeMaker linkext section: linkext :: dynamic $(NOECHO) $(NOOP) # --- MakeMaker dlsyms section: # --- MakeMaker dynamic_bs section: BOOTSTRAP = # --- MakeMaker dynamic section: dynamic :: $(FIRST_MAKEFILE) config $(INST_BOOT) $(INST_DYNAMIC) $(NOECHO) $(NOOP) # --- MakeMaker dynamic_lib section: # --- MakeMaker static section: ## $(INST_PM) has been moved to the all: target. ## It remains here for awhile to allow for old usage: "make static" static :: $(FIRST_MAKEFILE) $(INST_STATIC) $(NOECHO) $(NOOP) # --- MakeMaker static_lib section: # --- MakeMaker manifypods section: POD2MAN_EXE = $(PERLRUN) "-MExtUtils::Command::MM" -e pod2man "--" POD2MAN = $(POD2MAN_EXE) manifypods : pure_all config \ bin/cpanm \ lib/App/cpanminus.pm \ lib/App/cpanminus/fatscript.pm $(NOECHO) $(POD2MAN) --section=$(MAN1SECTION) --perm_rw=$(PERM_RW) -u \ bin/cpanm $(INST_MAN1DIR)/cpanm.$(MAN1EXT) $(NOECHO) $(POD2MAN) --section=$(MAN3SECTION) --perm_rw=$(PERM_RW) -u \ lib/App/cpanminus.pm $(INST_MAN3DIR)/App::cpanminus.$(MAN3EXT) \ lib/App/cpanminus/fatscript.pm $(INST_MAN3DIR)/App::cpanminus::fatscript.$(MAN3EXT) # --- MakeMaker processPL section: # --- MakeMaker installbin section: EXE_FILES = bin/cpanm pure_all :: $(INST_SCRIPT)/cpanm $(NOECHO) $(NOOP) realclean :: $(RM_F) \ $(INST_SCRIPT)/cpanm $(INST_SCRIPT)/cpanm : bin/cpanm $(FIRST_MAKEFILE) $(INST_SCRIPT)$(DFSEP).exists $(INST_BIN)$(DFSEP).exists $(NOECHO) $(RM_F) $(INST_SCRIPT)/cpanm $(CP) bin/cpanm $(INST_SCRIPT)/cpanm $(FIXIN) $(INST_SCRIPT)/cpanm -$(NOECHO) $(CHMOD) $(PERM_RWX) $(INST_SCRIPT)/cpanm # --- MakeMaker subdirs section: # none # --- MakeMaker clean_subdirs section: clean_subdirs : $(NOECHO) $(NOOP) # --- MakeMaker clean section: # Delete temporary files but do not touch installed files. We don't delete # the Makefile here so a later make realclean still has a makefile to use. clean :: clean_subdirs - $(RM_F) \ $(BASEEXT).bso $(BASEEXT).def \ $(BASEEXT).exp $(BASEEXT).x \ $(BOOTSTRAP) $(INST_ARCHAUTODIR)/extralibs.all \ $(INST_ARCHAUTODIR)/extralibs.ld $(MAKE_APERL_FILE) \ *$(LIB_EXT) *$(OBJ_EXT) \ *perl.core MYMETA.json \ MYMETA.yml blibdirs.ts \ core core.*perl.*.? \ core.[0-9] core.[0-9][0-9] \ core.[0-9][0-9][0-9] core.[0-9][0-9][0-9][0-9] \ core.[0-9][0-9][0-9][0-9][0-9] lib$(BASEEXT).def \ mon.out perl \ perl$(EXE_EXT) perl.exe \ perlmain.c pm_to_blib \ pm_to_blib.ts so_locations \ tmon.out - $(RM_RF) \ blib $(NOECHO) $(RM_F) $(MAKEFILE_OLD) - $(MV) $(FIRST_MAKEFILE) $(MAKEFILE_OLD) $(DEV_NULL) # --- MakeMaker realclean_subdirs section: # so clean is forced to complete before realclean_subdirs runs realclean_subdirs : clean $(NOECHO) $(NOOP) # --- MakeMaker realclean section: # Delete temporary files (via clean) and also delete dist files realclean purge :: realclean_subdirs - $(RM_F) \ $(FIRST_MAKEFILE) $(MAKEFILE_OLD) - $(RM_RF) \ $(DISTVNAME) # --- MakeMaker metafile section: metafile : create_distdir $(NOECHO) $(ECHO) Generating META.yml $(NOECHO) $(ECHO) '---' > META_new.yml $(NOECHO) $(ECHO) 'abstract: '\''get, unpack, build and install modules from CPAN'\''' >> META_new.yml $(NOECHO) $(ECHO) 'author:' >> META_new.yml $(NOECHO) $(ECHO) ' - '\''- Tatsuhiko Miyagawa'\''' >> META_new.yml $(NOECHO) $(ECHO) 'build_requires:' >> META_new.yml $(NOECHO) $(ECHO) ' ExtUtils::MakeMaker: '\''0'\''' >> META_new.yml $(NOECHO) $(ECHO) ' Test::More: '\''0'\''' >> META_new.yml $(NOECHO) $(ECHO) 'configure_requires:' >> META_new.yml $(NOECHO) $(ECHO) ' ExtUtils::MakeMaker: '\''0'\''' >> META_new.yml $(NOECHO) $(ECHO) 'dynamic_config: 1' >> META_new.yml $(NOECHO) $(ECHO) 'generated_by: '\''ExtUtils::MakeMaker version 7.60, CPAN::Meta::Converter version 2.150010'\''' >> META_new.yml $(NOECHO) $(ECHO) 'license: perl' >> META_new.yml $(NOECHO) $(ECHO) 'meta-spec:' >> META_new.yml $(NOECHO) $(ECHO) ' url: http://module-build.sourceforge.net/META-spec-v1.4.html' >> META_new.yml $(NOECHO) $(ECHO) ' version: '\''1.4'\''' >> META_new.yml $(NOECHO) $(ECHO) 'name: App-cpanminus' >> META_new.yml $(NOECHO) $(ECHO) 'no_index:' >> META_new.yml $(NOECHO) $(ECHO) ' directory:' >> META_new.yml $(NOECHO) $(ECHO) ' - t' >> META_new.yml $(NOECHO) $(ECHO) ' - inc' >> META_new.yml $(NOECHO) $(ECHO) 'requires:' >> META_new.yml $(NOECHO) $(ECHO) ' perl: '\''5.008001'\''' >> META_new.yml $(NOECHO) $(ECHO) 'version: '\''1.7047'\''' >> META_new.yml $(NOECHO) $(ECHO) 'x_serialization_backend: '\''CPAN::Meta::YAML version 0.018'\''' >> META_new.yml -$(NOECHO) $(MV) META_new.yml $(DISTVNAME)/META.yml $(NOECHO) $(ECHO) Generating META.json $(NOECHO) $(ECHO) '{' > META_new.json $(NOECHO) $(ECHO) ' "abstract" : "get, unpack, build and install modules from CPAN",' >> META_new.json $(NOECHO) $(ECHO) ' "author" : [' >> META_new.json $(NOECHO) $(ECHO) ' "- Tatsuhiko Miyagawa"' >> META_new.json $(NOECHO) $(ECHO) ' ],' >> META_new.json $(NOECHO) $(ECHO) ' "dynamic_config" : 1,' >> META_new.json $(NOECHO) $(ECHO) ' "generated_by" : "ExtUtils::MakeMaker version 7.60, CPAN::Meta::Converter version 2.150010",' >> META_new.json $(NOECHO) $(ECHO) ' "license" : [' >> META_new.json $(NOECHO) $(ECHO) ' "perl_5"' >> META_new.json $(NOECHO) $(ECHO) ' ],' >> META_new.json $(NOECHO) $(ECHO) ' "meta-spec" : {' >> META_new.json $(NOECHO) $(ECHO) ' "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",' >> META_new.json $(NOECHO) $(ECHO) ' "version" : 2' >> META_new.json $(NOECHO) $(ECHO) ' },' >> META_new.json $(NOECHO) $(ECHO) ' "name" : "App-cpanminus",' >> META_new.json $(NOECHO) $(ECHO) ' "no_index" : {' >> META_new.json $(NOECHO) $(ECHO) ' "directory" : [' >> META_new.json $(NOECHO) $(ECHO) ' "t",' >> META_new.json $(NOECHO) $(ECHO) ' "inc"' >> META_new.json $(NOECHO) $(ECHO) ' ]' >> META_new.json $(NOECHO) $(ECHO) ' },' >> META_new.json $(NOECHO) $(ECHO) ' "prereqs" : {' >> META_new.json $(NOECHO) $(ECHO) ' "build" : {' >> META_new.json $(NOECHO) $(ECHO) ' "requires" : {' >> META_new.json $(NOECHO) $(ECHO) ' "ExtUtils::MakeMaker" : "0"' >> META_new.json $(NOECHO) $(ECHO) ' }' >> META_new.json $(NOECHO) $(ECHO) ' },' >> META_new.json $(NOECHO) $(ECHO) ' "configure" : {' >> META_new.json $(NOECHO) $(ECHO) ' "requires" : {' >> META_new.json $(NOECHO) $(ECHO) ' "ExtUtils::MakeMaker" : "0"' >> META_new.json $(NOECHO) $(ECHO) ' }' >> META_new.json $(NOECHO) $(ECHO) ' },' >> META_new.json $(NOECHO) $(ECHO) ' "runtime" : {' >> META_new.json $(NOECHO) $(ECHO) ' "requires" : {' >> META_new.json $(NOECHO) $(ECHO) ' "perl" : "5.008001"' >> META_new.json $(NOECHO) $(ECHO) ' }' >> META_new.json $(NOECHO) $(ECHO) ' },' >> META_new.json $(NOECHO) $(ECHO) ' "test" : {' >> META_new.json $(NOECHO) $(ECHO) ' "requires" : {' >> META_new.json $(NOECHO) $(ECHO) ' "Test::More" : "0"' >> META_new.json $(NOECHO) $(ECHO) ' }' >> META_new.json $(NOECHO) $(ECHO) ' }' >> META_new.json $(NOECHO) $(ECHO) ' },' >> META_new.json $(NOECHO) $(ECHO) ' "release_status" : "stable",' >> META_new.json $(NOECHO) $(ECHO) ' "version" : "1.7047",' >> META_new.json $(NOECHO) $(ECHO) ' "x_serialization_backend" : "JSON::PP version 4.06"' >> META_new.json $(NOECHO) $(ECHO) '}' >> META_new.json -$(NOECHO) $(MV) META_new.json $(DISTVNAME)/META.json # --- MakeMaker signature section: signature : cpansign -s # --- MakeMaker dist_basics section: distclean :: realclean distcheck $(NOECHO) $(NOOP) distcheck : $(PERLRUN) "-MExtUtils::Manifest=fullcheck" -e fullcheck skipcheck : $(PERLRUN) "-MExtUtils::Manifest=skipcheck" -e skipcheck manifest : $(PERLRUN) "-MExtUtils::Manifest=mkmanifest" -e mkmanifest veryclean : realclean $(RM_F) *~ */*~ *.orig */*.orig *.bak */*.bak *.old */*.old # --- MakeMaker dist_core section: dist : $(DIST_DEFAULT) $(FIRST_MAKEFILE) $(NOECHO) $(ABSPERLRUN) -l -e 'print '\''Warning: Makefile possibly out of date with $(VERSION_FROM)'\''' \ -e ' if -e '\''$(VERSION_FROM)'\'' and -M '\''$(VERSION_FROM)'\'' < -M '\''$(FIRST_MAKEFILE)'\'';' -- tardist : $(DISTVNAME).tar$(SUFFIX) $(NOECHO) $(NOOP) uutardist : $(DISTVNAME).tar$(SUFFIX) uuencode $(DISTVNAME).tar$(SUFFIX) $(DISTVNAME).tar$(SUFFIX) > $(DISTVNAME).tar$(SUFFIX)_uu $(NOECHO) $(ECHO) 'Created $(DISTVNAME).tar$(SUFFIX)_uu' $(DISTVNAME).tar$(SUFFIX) : distdir $(PREOP) $(TO_UNIX) $(TAR) $(TARFLAGS) $(DISTVNAME).tar $(DISTVNAME) $(RM_RF) $(DISTVNAME) $(COMPRESS) $(DISTVNAME).tar $(NOECHO) $(ECHO) 'Created $(DISTVNAME).tar$(SUFFIX)' $(POSTOP) zipdist : $(DISTVNAME).zip $(NOECHO) $(NOOP) $(DISTVNAME).zip : distdir $(PREOP) $(ZIP) $(ZIPFLAGS) $(DISTVNAME).zip $(DISTVNAME) $(RM_RF) $(DISTVNAME) $(NOECHO) $(ECHO) 'Created $(DISTVNAME).zip' $(POSTOP) shdist : distdir $(PREOP) $(SHAR) $(DISTVNAME) > $(DISTVNAME).shar $(RM_RF) $(DISTVNAME) $(NOECHO) $(ECHO) 'Created $(DISTVNAME).shar' $(POSTOP) # --- MakeMaker distdir section: create_distdir : $(RM_RF) $(DISTVNAME) $(PERLRUN) "-MExtUtils::Manifest=manicopy,maniread" \ -e "manicopy(maniread(),'$(DISTVNAME)', '$(DIST_CP)');" distdir : create_distdir distmeta $(NOECHO) $(NOOP) # --- MakeMaker dist_test section: disttest : distdir cd $(DISTVNAME) && $(ABSPERLRUN) Makefile.PL cd $(DISTVNAME) && $(MAKE) $(PASTHRU) cd $(DISTVNAME) && $(MAKE) test $(PASTHRU) # --- MakeMaker dist_ci section: ci : $(ABSPERLRUN) -MExtUtils::Manifest=maniread -e '@all = sort keys %{ maniread() };' \ -e 'print(qq{Executing $(CI) @all\n});' \ -e 'system(qq{$(CI) @all}) == 0 or die $$!;' \ -e 'print(qq{Executing $(RCS_LABEL) ...\n});' \ -e 'system(qq{$(RCS_LABEL) @all}) == 0 or die $$!;' -- # --- MakeMaker distmeta section: distmeta : create_distdir metafile $(NOECHO) cd $(DISTVNAME) && $(ABSPERLRUN) -MExtUtils::Manifest=maniadd -e 'exit unless -e q{META.yml};' \ -e 'eval { maniadd({q{META.yml} => q{Module YAML meta-data (added by MakeMaker)}}) }' \ -e ' or die "Could not add META.yml to MANIFEST: $${'\''@'\''}"' -- $(NOECHO) cd $(DISTVNAME) && $(ABSPERLRUN) -MExtUtils::Manifest=maniadd -e 'exit unless -f q{META.json};' \ -e 'eval { maniadd({q{META.json} => q{Module JSON meta-data (added by MakeMaker)}}) }' \ -e ' or die "Could not add META.json to MANIFEST: $${'\''@'\''}"' -- # --- MakeMaker distsignature section: distsignature : distmeta $(NOECHO) cd $(DISTVNAME) && $(ABSPERLRUN) -MExtUtils::Manifest=maniadd -e 'eval { maniadd({q{SIGNATURE} => q{Public-key signature (added by MakeMaker)}}) }' \ -e ' or die "Could not add SIGNATURE to MANIFEST: $${'\''@'\''}"' -- $(NOECHO) cd $(DISTVNAME) && $(TOUCH) SIGNATURE cd $(DISTVNAME) && cpansign -s # --- MakeMaker install section: install :: pure_install doc_install $(NOECHO) $(NOOP) install_perl :: pure_perl_install doc_perl_install $(NOECHO) $(NOOP) install_site :: pure_site_install doc_site_install $(NOECHO) $(NOOP) install_vendor :: pure_vendor_install doc_vendor_install $(NOECHO) $(NOOP) pure_install :: pure_$(INSTALLDIRS)_install $(NOECHO) $(NOOP) doc_install :: doc_$(INSTALLDIRS)_install $(NOECHO) $(NOOP) pure__install : pure_site_install $(NOECHO) $(ECHO) INSTALLDIRS not defined, defaulting to INSTALLDIRS=site doc__install : doc_site_install $(NOECHO) $(ECHO) INSTALLDIRS not defined, defaulting to INSTALLDIRS=site pure_perl_install :: all $(NOECHO) $(MOD_INSTALL) \ read "$(PERL_ARCHLIB)/auto/$(FULLEXT)/.packlist" \ write "$(DESTINSTALLARCHLIB)/auto/$(FULLEXT)/.packlist" \ "$(INST_LIB)" "$(DESTINSTALLPRIVLIB)" \ "$(INST_ARCHLIB)" "$(DESTINSTALLARCHLIB)" \ "$(INST_BIN)" "$(DESTINSTALLBIN)" \ "$(INST_SCRIPT)" "$(DESTINSTALLSCRIPT)" \ "$(INST_MAN1DIR)" "$(DESTINSTALLMAN1DIR)" \ "$(INST_MAN3DIR)" "$(DESTINSTALLMAN3DIR)" $(NOECHO) $(WARN_IF_OLD_PACKLIST) \ "$(SITEARCHEXP)/auto/$(FULLEXT)" pure_site_install :: all $(NOECHO) $(MOD_INSTALL) \ read "$(SITEARCHEXP)/auto/$(FULLEXT)/.packlist" \ write "$(DESTINSTALLSITEARCH)/auto/$(FULLEXT)/.packlist" \ "$(INST_LIB)" "$(DESTINSTALLSITELIB)" \ "$(INST_ARCHLIB)" "$(DESTINSTALLSITEARCH)" \ "$(INST_BIN)" "$(DESTINSTALLSITEBIN)" \ "$(INST_SCRIPT)" "$(DESTINSTALLSITESCRIPT)" \ "$(INST_MAN1DIR)" "$(DESTINSTALLSITEMAN1DIR)" \ "$(INST_MAN3DIR)" "$(DESTINSTALLSITEMAN3DIR)" $(NOECHO) $(WARN_IF_OLD_PACKLIST) \ "$(PERL_ARCHLIB)/auto/$(FULLEXT)" pure_vendor_install :: all $(NOECHO) $(MOD_INSTALL) \ read "$(VENDORARCHEXP)/auto/$(FULLEXT)/.packlist" \ write "$(DESTINSTALLVENDORARCH)/auto/$(FULLEXT)/.packlist" \ "$(INST_LIB)" "$(DESTINSTALLVENDORLIB)" \ "$(INST_ARCHLIB)" "$(DESTINSTALLVENDORARCH)" \ "$(INST_BIN)" "$(DESTINSTALLVENDORBIN)" \ "$(INST_SCRIPT)" "$(DESTINSTALLVENDORSCRIPT)" \ "$(INST_MAN1DIR)" "$(DESTINSTALLVENDORMAN1DIR)" \ "$(INST_MAN3DIR)" "$(DESTINSTALLVENDORMAN3DIR)" doc_perl_install :: all $(NOECHO) $(ECHO) Appending installation info to "$(DESTINSTALLARCHLIB)/perllocal.pod" -$(NOECHO) $(MKPATH) "$(DESTINSTALLARCHLIB)" -$(NOECHO) $(DOC_INSTALL) \ "Module" "$(NAME)" \ "installed into" "$(INSTALLPRIVLIB)" \ LINKTYPE "$(LINKTYPE)" \ VERSION "$(VERSION)" \ EXE_FILES "$(EXE_FILES)" \ >> "$(DESTINSTALLARCHLIB)/perllocal.pod" doc_site_install :: all $(NOECHO) $(ECHO) Appending installation info to "$(DESTINSTALLARCHLIB)/perllocal.pod" -$(NOECHO) $(MKPATH) "$(DESTINSTALLARCHLIB)" -$(NOECHO) $(DOC_INSTALL) \ "Module" "$(NAME)" \ "installed into" "$(INSTALLSITELIB)" \ LINKTYPE "$(LINKTYPE)" \ VERSION "$(VERSION)" \ EXE_FILES "$(EXE_FILES)" \ >> "$(DESTINSTALLARCHLIB)/perllocal.pod" doc_vendor_install :: all $(NOECHO) $(ECHO) Appending installation info to "$(DESTINSTALLARCHLIB)/perllocal.pod" -$(NOECHO) $(MKPATH) "$(DESTINSTALLARCHLIB)" -$(NOECHO) $(DOC_INSTALL) \ "Module" "$(NAME)" \ "installed into" "$(INSTALLVENDORLIB)" \ LINKTYPE "$(LINKTYPE)" \ VERSION "$(VERSION)" \ EXE_FILES "$(EXE_FILES)" \ >> "$(DESTINSTALLARCHLIB)/perllocal.pod" uninstall :: uninstall_from_$(INSTALLDIRS)dirs $(NOECHO) $(NOOP) uninstall_from_perldirs :: $(NOECHO) $(UNINSTALL) "$(PERL_ARCHLIB)/auto/$(FULLEXT)/.packlist" uninstall_from_sitedirs :: $(NOECHO) $(UNINSTALL) "$(SITEARCHEXP)/auto/$(FULLEXT)/.packlist" uninstall_from_vendordirs :: $(NOECHO) $(UNINSTALL) "$(VENDORARCHEXP)/auto/$(FULLEXT)/.packlist" # --- MakeMaker force section: # Phony target to force checking subdirectories. FORCE : $(NOECHO) $(NOOP) # --- MakeMaker perldepend section: # --- MakeMaker makefile section: # We take a very conservative approach here, but it's worth it. # We move Makefile to Makefile.old here to avoid gnu make looping. $(FIRST_MAKEFILE) : Makefile.PL $(CONFIGDEP) $(NOECHO) $(ECHO) "Makefile out-of-date with respect to $?" $(NOECHO) $(ECHO) "Cleaning current config before rebuilding Makefile..." -$(NOECHO) $(RM_F) $(MAKEFILE_OLD) -$(NOECHO) $(MV) $(FIRST_MAKEFILE) $(MAKEFILE_OLD) - $(MAKE) $(USEMAKEFILE) $(MAKEFILE_OLD) clean $(DEV_NULL) $(PERLRUN) Makefile.PL $(NOECHO) $(ECHO) "==> Your Makefile has been rebuilt. <==" $(NOECHO) $(ECHO) "==> Please rerun the $(MAKE) command. <==" $(FALSE) # --- MakeMaker staticmake section: # --- MakeMaker makeaperl section --- MAP_TARGET = perl FULLPERL = "/usr/bin/perl" MAP_PERLINC = "-Iblib/arch" "-Iblib/lib" "-I/usr/lib64/perl5" "-I/usr/share/perl5" $(MAP_TARGET) :: $(MAKE_APERL_FILE) $(MAKE) $(USEMAKEFILE) $(MAKE_APERL_FILE) $@ $(MAKE_APERL_FILE) : static $(FIRST_MAKEFILE) pm_to_blib $(NOECHO) $(ECHO) Writing \"$(MAKE_APERL_FILE)\" for this $(MAP_TARGET) $(NOECHO) $(PERLRUNINST) \ Makefile.PL DIR="" \ MAKEFILE=$(MAKE_APERL_FILE) LINKTYPE=static \ MAKEAPERL=1 NORECURS=1 CCCDLFLAGS= # --- MakeMaker test section: TEST_VERBOSE=0 TEST_TYPE=test_$(LINKTYPE) TEST_FILE = test.pl TEST_FILES = t/*.t TESTDB_SW = -d testdb :: testdb_$(LINKTYPE) $(NOECHO) $(NOOP) test :: $(TEST_TYPE) $(NOECHO) $(NOOP) # Occasionally we may face this degenerate target: test_ : test_dynamic $(NOECHO) $(NOOP) subdirs-test_dynamic :: dynamic pure_all test_dynamic :: subdirs-test_dynamic PERL_DL_NONLAZY=1 $(FULLPERLRUN) "-MExtUtils::Command::MM" "-MTest::Harness" "-e" "undef *Test::Harness::Switches; test_harness($(TEST_VERBOSE), '$(INST_LIB)', '$(INST_ARCHLIB)')" $(TEST_FILES) testdb_dynamic :: dynamic pure_all PERL_DL_NONLAZY=1 $(FULLPERLRUN) $(TESTDB_SW) "-I$(INST_LIB)" "-I$(INST_ARCHLIB)" $(TEST_FILE) subdirs-test_static :: static pure_all test_static :: subdirs-test_static PERL_DL_NONLAZY=1 $(FULLPERLRUN) "-MExtUtils::Command::MM" "-MTest::Harness" "-e" "undef *Test::Harness::Switches; test_harness($(TEST_VERBOSE), '$(INST_LIB)', '$(INST_ARCHLIB)')" $(TEST_FILES) testdb_static :: static pure_all PERL_DL_NONLAZY=1 $(FULLPERLRUN) $(TESTDB_SW) "-I$(INST_LIB)" "-I$(INST_ARCHLIB)" $(TEST_FILE) # --- MakeMaker ppd section: # Creates a PPD (Perl Package Description) for a binary distribution. ppd : $(NOECHO) $(ECHO) '<SOFTPKG NAME="App-cpanminus" VERSION="1.7047">' > App-cpanminus.ppd $(NOECHO) $(ECHO) ' <ABSTRACT>get, unpack, build and install modules from CPAN</ABSTRACT>' >> App-cpanminus.ppd $(NOECHO) $(ECHO) ' <AUTHOR>- Tatsuhiko Miyagawa</AUTHOR>' >> App-cpanminus.ppd $(NOECHO) $(ECHO) ' <IMPLEMENTATION>' >> App-cpanminus.ppd $(NOECHO) $(ECHO) ' <PERLCORE VERSION="5,008001,0,0" />' >> App-cpanminus.ppd $(NOECHO) $(ECHO) ' <ARCHITECTURE NAME="x86_64-linux-thread-multi-5.32" />' >> App-cpanminus.ppd $(NOECHO) $(ECHO) ' <CODEBASE HREF="" />' >> App-cpanminus.ppd $(NOECHO) $(ECHO) ' </IMPLEMENTATION>' >> App-cpanminus.ppd $(NOECHO) $(ECHO) '</SOFTPKG>' >> App-cpanminus.ppd # --- MakeMaker pm_to_blib section: pm_to_blib : $(FIRST_MAKEFILE) $(TO_INST_PM) $(NOECHO) $(ABSPERLRUN) -MExtUtils::Install -e 'pm_to_blib({@ARGV}, '\''$(INST_LIB)/auto'\'', q[$(PM_FILTER)], '\''$(PERM_DIR)'\'')' -- \ 'lib/App/cpanminus.pm' 'blib/lib/App/cpanminus.pm' \ 'lib/App/cpanminus/fatscript.pm' 'blib/lib/App/cpanminus/fatscript.pm' $(NOECHO) $(TOUCH) pm_to_blib # --- MakeMaker selfdocument section: # here so even if top_targets is overridden, these will still be defined # gmake will silently still work if any are .PHONY-ed but nmake won't static :: $(NOECHO) $(NOOP) dynamic :: $(NOECHO) $(NOOP) config :: $(NOECHO) $(NOOP) # --- MakeMaker postamble section: # End. PK jA[��;l l META.jsonnu �[��� { "abstract" : "get, unpack, build and install modules from CPAN", "author" : [ "- Tatsuhiko Miyagawa" ], "dynamic_config" : 0, "generated_by" : "Dist::Milla version v1.0.22, Dist::Zilla version 6.025, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "App-cpanminus", "no_index" : { "directory" : [ "eg", "examples", "inc", "share", "t", "xt" ], "file" : [ "lib/App/cpanminus/fatscript.pm" ] }, "prereqs" : { "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "develop" : { "recommends" : { "Archive::Tar" : "0", "Archive::Zip" : "0", "Compress::Zlib" : "0", "File::HomeDir" : "0", "Module::Signature" : "0" }, "requires" : { "App::FatPacker" : "0", "CPAN::DistnameInfo" : "0", "CPAN::Meta" : "2.132830", "CPAN::Meta::Check" : "0", "CPAN::Meta::Prereqs" : "0", "CPAN::Meta::Requirements" : "0", "CPAN::Meta::YAML" : "0", "Capture::Tiny" : "0", "Digest::SHA" : "0", "Dist::Milla" : "v1.0.22", "Exporter" : "5.63", "File::Temp" : "0", "File::pushd" : "0", "Getopt::Long" : "0", "HTTP::Tiny" : "0", "JSON" : "0", "JSON::PP" : "0", "LWP::Simple" : "0", "LWP::UserAgent" : "5.802", "Module::CPANfile" : "0", "Module::CoreList" : "0", "Module::Install" : "0", "Module::Metadata" : "0", "Parse::CPAN::Meta" : "0", "Parse::PMFile" : "0.26", "Perl::Strip" : "0", "String::ShellQuote" : "0", "Test::More" : "0.90", "Test::Pod" : "1.41", "Test::Requires" : "0", "Tie::File" : "0", "YAML" : "0", "YAML::Tiny" : "0", "local::lib" : "0", "version" : "0" } }, "runtime" : { "requires" : { "perl" : "5.008001" } }, "test" : { "requires" : { "Test::More" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/miyagawa/cpanminus/issues" }, "homepage" : "https://github.com/miyagawa/cpanminus", "repository" : { "type" : "git", "url" : "https://github.com/miyagawa/cpanminus.git", "web" : "https://github.com/miyagawa/cpanminus" } }, "version" : "1.7047", "x_contributors" : [ "Aaron Moses <mosesa02@localhost.localdomain>", "Alessandro Ghedini <al3xbio@gmail.com>", "Andrew Rodland <andrew@cleverdomain.org>", "Andy Jones <andy@broadbean.com>", "andyjones <andy_jones@outgun.com>", "Ash Berlin <ash_github@firemirror.com>", "Ben Bullock <benkasminbullock@gmail.com>", "Breno G. de Oliveira <garu@cpan.org>", "Brian Wightman <MidLifeXis@wightmanfam.org>", "cho45 <cho45@lowreal.net>", "Christian Walde <walde.christian@googlemail.com>", "chromatic <chromatic@wgz.org>", "Dagfinn Ilmari Mannsaker <ilmari@ilmari.org>", "Dana M. Diederich <diederich@gmail.com>", "Dave Goodell <davidjgoodell@gmail.com>", "Dave Rolsky <autarch@urth.org>", "David Golden <dagolden@cpan.org>", "David Steinbrunner <dsteinbrunner@pobox.com>", "Doug Bell <madcityzen@gmail.com>", "Eli Flanagan <eflanagan@innovu.com>", "fREW Schmidt <frioux@gmail.com>", "Fuji, Goro <g.psy.va@gmail.com>", "Gareth Kirwan <gbjk@thermeon.com>", "gfx <gfuji@cpan.org>", "Graham Knop <haarg@haarg.org>", "Graham Ollis <perl@wdlabs.com>", "ikasam_a <masaki.nakagawa@gmail.com>", "Ingy dot Net <ingy@ingy.net>", "Jan Dubois <jand@activestate.com>", "Jeffrey Ryan Thalhammer <jeff@imaginative-software.com>", "Jesse Luehrs <doy@tozt.net>", "J. Nick Koston <nick@cpanel.net>", "jonallen <jj@jonallen.info>", "Jonathan Scott Duff <duff@pobox.com>", "Kahlil (Kal) Hodgson <kahlil.hodgson@dealmax.com.au>", "Kenichi Ishigaki <ishigaki@cpan.org>", "Kent Fredric <kentnl@cpan.org>", "kmx <kmx@cpan.org>", "Larry Leszczynski <larryl@atomiclearning.com>", "lestrrat <lestrrat+github@gmail.com>", "Masahiro Nagano <kazeburo@gmail.com>", "Masayoshi Sekimura <sekimura@gmail.com>", "Matthew Horsfall <wolfsage@gmail.com>", "Matt S Trout <>", "Matt S Trout <mst@shadowcat.co.uk>", "Michael G. Schwern <schwern@pobox.com>", "motemen <motemen@gmail.com>", "moznion <moznion@gmail.com>", "Nicolas R <atoomic@cpan.org>", "Norman Nunley <nnunley@gmail.com>", "Olaf Alders <olaf@wundersolutions.com>", "Olivier Mengue <dolmen@cpan.org>", "Pedro Melo <melo@simplicidade.org>", "Rafal Pocztarski <r.pocztarski@gmail.com>", "reezer <kind@gmx.at>", "Ricardo Signes <rjbs@cpan.org>", "robario <webmaster@robario.com>", "Robert Buels <rmb32@cornell.edu>", "Rob Hoelz <rob@hoelz.ro>", "Roman Jurkov <rjurkov@verio.net>", "Sebastian Riedel <sri@cpan.org>", "Shoichi Kaji <skaji@cpan.org>", "Slaven Rezic <slaven@rezic.de>", "Smylers <Smylers@stripey.com>", "Stoned Elipot <stoned.elipot@gmail.com>", "Syohei YOSHIDA <syohex@gmail.com>", "Tatsuhiko Miyagawa <miyagawa@bulknews.net>", "Tatsuhiko Miyagawa <miyagawa@gmail.com>", "Thomas Sibley <tom@zulutango.org>", "Tokuhiro Matsuno <tokuhirom@gmail.com>", "Tuure Laurinolli <tuure.laurinolli@portalify.com>", "vti <viacheslav.t@gmail.com>", "Vyacheslav Matyukhin <mmcleric@yandex-team.ru>", "xaicron <xaicron@gmail.com>", "Yann Kerherve <yann@cyberion.net>", "yappo <yappo@shibuya.pl>", "zebardy <zebardy@gmail.com>" ], "x_generated_by_perl" : "v5.34.1", "x_serialization_backend" : "Cpanel::JSON::XS version 4.27", "x_spdx_expression" : "Artistic-1.0-Perl OR GPL-1.0-or-later", "x_static_install" : 0 } PK jA[�� ��G �G LICENSEnu �[��� This software is copyright (c) 2010- by - Tatsuhiko Miyagawa. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. Terms of the Perl programming language system itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --- The GNU General Public License, Version 1, February 1989 --- This software is Copyright (c) 2010- by - Tatsuhiko Miyagawa. This is free software, licensed under: The GNU General Public License, Version 1, February 1989 GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. <one line to give the program's name and a brief idea of what it does.> Copyright (C) 19yy <name of author> This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. <signature of Ty Coon>, 1 April 1989 Ty Coon, President of Vice That's all there is to it! --- The Artistic License 1.0 --- This software is Copyright (c) 2010- by - Tatsuhiko Miyagawa. This is free software, licensed under: The Artistic License 1.0 The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End PK jA[�{R� � t/happy_cpantesters.tnu ȯ�� #!perl use strict; use Test::More tests => 1; BEGIN{ require_ok 'App::cpanminus'; # in the future ... # require_ok 'App::cpanminus::script'; } diag("App::cpanminus/$App::cpanminus::VERSION"); __DATA__ PK jA[�� META.ymlnu �[��� --- abstract: 'get, unpack, build and install modules from CPAN' author: - '- Tatsuhiko Miyagawa' build_requires: Test::More: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 0 generated_by: 'Dist::Milla version v1.0.22, Dist::Zilla version 6.025, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: App-cpanminus no_index: directory: - eg - examples - inc - share - t - xt file: - lib/App/cpanminus/fatscript.pm requires: perl: '5.008001' resources: bugtracker: https://github.com/miyagawa/cpanminus/issues homepage: https://github.com/miyagawa/cpanminus repository: https://github.com/miyagawa/cpanminus.git version: '1.7047' x_contributors: - 'Aaron Moses <mosesa02@localhost.localdomain>' - 'Alessandro Ghedini <al3xbio@gmail.com>' - 'Andrew Rodland <andrew@cleverdomain.org>' - 'Andy Jones <andy@broadbean.com>' - 'andyjones <andy_jones@outgun.com>' - 'Ash Berlin <ash_github@firemirror.com>' - 'Ben Bullock <benkasminbullock@gmail.com>' - 'Breno G. de Oliveira <garu@cpan.org>' - 'Brian Wightman <MidLifeXis@wightmanfam.org>' - 'cho45 <cho45@lowreal.net>' - 'Christian Walde <walde.christian@googlemail.com>' - 'chromatic <chromatic@wgz.org>' - 'Dagfinn Ilmari Mannsaker <ilmari@ilmari.org>' - 'Dana M. Diederich <diederich@gmail.com>' - 'Dave Goodell <davidjgoodell@gmail.com>' - 'Dave Rolsky <autarch@urth.org>' - 'David Golden <dagolden@cpan.org>' - 'David Steinbrunner <dsteinbrunner@pobox.com>' - 'Doug Bell <madcityzen@gmail.com>' - 'Eli Flanagan <eflanagan@innovu.com>' - 'fREW Schmidt <frioux@gmail.com>' - 'Fuji, Goro <g.psy.va@gmail.com>' - 'Gareth Kirwan <gbjk@thermeon.com>' - 'gfx <gfuji@cpan.org>' - 'Graham Knop <haarg@haarg.org>' - 'Graham Ollis <perl@wdlabs.com>' - 'ikasam_a <masaki.nakagawa@gmail.com>' - 'Ingy dot Net <ingy@ingy.net>' - 'Jan Dubois <jand@activestate.com>' - 'Jeffrey Ryan Thalhammer <jeff@imaginative-software.com>' - 'Jesse Luehrs <doy@tozt.net>' - 'J. Nick Koston <nick@cpanel.net>' - 'jonallen <jj@jonallen.info>' - 'Jonathan Scott Duff <duff@pobox.com>' - 'Kahlil (Kal) Hodgson <kahlil.hodgson@dealmax.com.au>' - 'Kenichi Ishigaki <ishigaki@cpan.org>' - 'Kent Fredric <kentnl@cpan.org>' - 'kmx <kmx@cpan.org>' - 'Larry Leszczynski <larryl@atomiclearning.com>' - 'lestrrat <lestrrat+github@gmail.com>' - 'Masahiro Nagano <kazeburo@gmail.com>' - 'Masayoshi Sekimura <sekimura@gmail.com>' - 'Matthew Horsfall <wolfsage@gmail.com>' - 'Matt S Trout <>' - 'Matt S Trout <mst@shadowcat.co.uk>' - 'Michael G. Schwern <schwern@pobox.com>' - 'motemen <motemen@gmail.com>' - 'moznion <moznion@gmail.com>' - 'Nicolas R <atoomic@cpan.org>' - 'Norman Nunley <nnunley@gmail.com>' - 'Olaf Alders <olaf@wundersolutions.com>' - 'Olivier Mengue <dolmen@cpan.org>' - 'Pedro Melo <melo@simplicidade.org>' - 'Rafal Pocztarski <r.pocztarski@gmail.com>' - 'reezer <kind@gmx.at>' - 'Ricardo Signes <rjbs@cpan.org>' - 'robario <webmaster@robario.com>' - 'Robert Buels <rmb32@cornell.edu>' - 'Rob Hoelz <rob@hoelz.ro>' - 'Roman Jurkov <rjurkov@verio.net>' - 'Sebastian Riedel <sri@cpan.org>' - 'Shoichi Kaji <skaji@cpan.org>' - 'Slaven Rezic <slaven@rezic.de>' - 'Smylers <Smylers@stripey.com>' - 'Stoned Elipot <stoned.elipot@gmail.com>' - 'Syohei YOSHIDA <syohex@gmail.com>' - 'Tatsuhiko Miyagawa <miyagawa@bulknews.net>' - 'Tatsuhiko Miyagawa <miyagawa@gmail.com>' - 'Thomas Sibley <tom@zulutango.org>' - 'Tokuhiro Matsuno <tokuhirom@gmail.com>' - 'Tuure Laurinolli <tuure.laurinolli@portalify.com>' - 'vti <viacheslav.t@gmail.com>' - 'Vyacheslav Matyukhin <mmcleric@yandex-team.ru>' - 'xaicron <xaicron@gmail.com>' - 'Yann Kerherve <yann@cyberion.net>' - 'yappo <yappo@shibuya.pl>' - 'zebardy <zebardy@gmail.com>' x_generated_by_perl: v5.34.1 x_serialization_backend: 'YAML::Tiny version 1.73' x_spdx_expression: 'Artistic-1.0-Perl OR GPL-1.0-or-later' x_static_install: 0 PK jA[Fk�r Makefile.PLnu �[��� # This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v6.025. use strict; use warnings; use 5.008001; use ExtUtils::MakeMaker; my %WriteMakefileArgs = ( "ABSTRACT" => "get, unpack, build and install modules from CPAN", "AUTHOR" => "- Tatsuhiko Miyagawa", "CONFIGURE_REQUIRES" => { "ExtUtils::MakeMaker" => 0 }, "DISTNAME" => "App-cpanminus", "EXE_FILES" => [ "bin/cpanm" ], "LICENSE" => "perl", "MIN_PERL_VERSION" => "5.008001", "NAME" => "App::cpanminus", "PREREQ_PM" => {}, "TEST_REQUIRES" => { "Test::More" => 0 }, "VERSION" => "1.7047", "test" => { "TESTS" => "t/*.t" } ); my %FallbackPrereqs = ( "Test::More" => 0 ); unless ( eval { ExtUtils::MakeMaker->VERSION(6.63_03) } ) { delete $WriteMakefileArgs{TEST_REQUIRES}; delete $WriteMakefileArgs{BUILD_REQUIRES}; $WriteMakefileArgs{PREREQ_PM} = \%FallbackPrereqs; } delete $WriteMakefileArgs{CONFIGURE_REQUIRES} unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; WriteMakefile(%WriteMakefileArgs); PK jA[�%"�F� F� bin/cpanmnu �[��� #!perl # # This is a pre-compiled source code for the cpanm (cpanminus) program. # For more details about how to install cpanm, go to the following URL: # # https://github.com/miyagawa/cpanminus # # Quickstart: Run the following command and it will install itself for # you. You might want to run it as a root with sudo if you want to install # to places like /usr/local/bin. # # % curl -L https://cpanmin.us | perl - App::cpanminus # # If you don't have curl but wget, replace `curl -L` with `wget -O -`. # DO NOT EDIT -- this is an auto generated file # This chunk of stuff was generated by App::FatPacker. To find the original # file's code, look for the end of this BEGIN block or the string 'FATPACK' BEGIN { my %fatpacked; $fatpacked{"App/cpanminus.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_CPANMINUS'; package App::cpanminus;our$VERSION="1.7047";1; APP_CPANMINUS $fatpacked{"App/cpanminus/Dependency.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_CPANMINUS_DEPENDENCY'; package App::cpanminus::Dependency;use strict;use CPAN::Meta::Requirements;sub from_prereqs {my($class,$prereqs,$phases,$types)=@_;my@deps;for my$type (@$types){push@deps,$class->from_versions($prereqs->merged_requirements($phases,[$type])->as_string_hash,$type,)}return@deps}sub from_versions {my($class,$versions,$type)=@_;my@deps;while (my($module,$version)=each %$versions){push@deps,$class->new($module,$version,$type)}@deps}sub merge_with {my($self,$requirements)=@_;$self->{original_version}=$self->version;eval {$requirements->add_string_requirement($self->module,$self->version)};if ($@ =~ /illegal requirements/){warn sprintf("Can't merge requirements for %s: '%s' and '%s'",$self->module,$self->version,$requirements->requirements_for_module($self->module))}$self->{version}=$requirements->requirements_for_module($self->module)}sub new {my($class,$module,$version,$type)=@_;bless {module=>$module,version=>$version,type=>$type || 'requires',},$class}sub module {$_[0]->{module}}sub version {$_[0]->{version}}sub type {$_[0]->{type}}sub requires_version {my$self=shift;if (defined$self->{original_version}){return$self->{original_version}}$self->version}sub is_requirement {$_[0]->{type}eq 'requires'}1; APP_CPANMINUS_DEPENDENCY $fatpacked{"App/cpanminus/script.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_CPANMINUS_SCRIPT'; package App::cpanminus::script;use strict;use Config;use Cwd ();use App::cpanminus;use App::cpanminus::Dependency;use File::Basename ();use File::Find ();use File::Path ();use File::Spec ();use File::Copy ();use File::Temp ();use Getopt::Long ();use Symbol ();use String::ShellQuote ();use version ();use constant WIN32=>$^O eq 'MSWin32';use constant BAD_TAR=>($^O eq 'solaris' || $^O eq 'hpux');use constant CAN_SYMLINK=>eval {symlink("","");1};our$VERSION=$App::cpanminus::VERSION;if ($INC{"App/FatPacker/Trace.pm"}){require version::vpp}my$quote=WIN32 ? q/"/ : q/'/;sub agent {my$self=shift;my$agent="cpanminus/$VERSION";$agent .= " perl/$]" if$self->{report_perl_version};$agent}sub determine_home {my$class=shift;my$homedir=$ENV{HOME}|| eval {require File::HomeDir;File::HomeDir->my_home}|| join('',@ENV{qw(HOMEDRIVE HOMEPATH)});if (WIN32){require Win32;$homedir=Win32::GetShortPathName($homedir)}return "$homedir/.cpanm"}sub new {my$class=shift;bless {home=>$class->determine_home,cmd=>'install',seen=>{},notest=>undef,test_only=>undef,installdeps=>undef,force=>undef,sudo=>undef,make=>undef,verbose=>undef,quiet=>undef,interactive=>undef,log=>undef,mirrors=>[],mirror_only=>undef,mirror_index=>undef,cpanmetadb=>"http://cpanmetadb.plackperl.org/v1.0/",perl=>$^X,argv=>[],local_lib=>undef,self_contained=>undef,exclude_vendor=>undef,prompt_timeout=>0,prompt=>undef,configure_timeout=>60,build_timeout=>3600,test_timeout=>1800,try_lwp=>1,try_wget=>1,try_curl=>1,uninstall_shadows=>($] < 5.012),skip_installed=>1,skip_satisfied=>0,auto_cleanup=>7,pod2man=>1,installed_dists=>0,install_types=>['requires'],with_develop=>0,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){push@ARGV,$self->load_argv_from_fh(\*STDIN);$self->{load_from_stdin}=1}$self->{argv}=\@ARGV}sub check_upgrade {my$self=shift;my$install_base=$ENV{PERL_LOCAL_LIB_ROOT}? $self->local_lib_target($ENV{PERL_LOCAL_LIB_ROOT}): $Config{installsitebin};if ($0 eq '-'){return}elsif ($0 !~ /^$install_base/){if ($0 =~ m!perlbrew/bin!){die <<DIE}else {die <<DIE}}}sub check_libs {my$self=shift;return if$self->{_checked}++;$self->bootstrap_local_lib}sub setup_verify {my$self=shift;my$has_modules=eval {require Module::Signature;require Digest::SHA;1};$self->{cpansign}=$self->which('cpansign');unless ($has_modules && $self->{cpansign}){warn "WARNING: Module::Signature and Digest::SHA is required for distribution verifications.\n";$self->{verify}=0}}sub parse_module_args {my($self,$module)=@_;$module =~ s/^([A-Za-z0-9_:]+)@([v\d\._]+)$/$1~== $2/;if ($module =~ /\~[v\d\._,\!<>= ]+$/){return split /\~/,$module,2}else {return$module,undef}}sub doit {my$self=shift;my$code;eval {$code=($self->_doit==0)};if (my$e=$@){warn$e;$code=1}return$code}sub _doit {my$self=shift;$self->setup_home;$self->init_tools;$self->setup_verify if$self->{verify};if (my$action=$self->{action}){$self->$action()and return 1}return$self->show_help(1)unless @{$self->{argv}}or $self->{load_from_stdin};$self->configure_mirrors;my$cwd=Cwd::cwd;my@fail;for my$module (@{$self->{argv}}){if ($module =~ s/\.pm$//i){my ($volume,$dirs,$file)=File::Spec->splitpath($module);$module=join '::',grep {$_}File::Spec->splitdir($dirs),$file}($module,my$version)=$self->parse_module_args($module);$self->chdir($cwd);if ($self->{cmd}eq 'uninstall'){$self->uninstall_module($module)or push@fail,$module}else {$self->install_module($module,0,$version)or push@fail,$module}}if ($self->{base}&& $self->{auto_cleanup}){$self->cleanup_workdirs}if ($self->{installed_dists}){my$dists=$self->{installed_dists}> 1 ? "distributions" : "distribution";$self->diag("$self->{installed_dists} $dists installed\n",1)}if ($self->{scandeps}){$self->dump_scandeps()}$self->chdir($cwd);return!@fail}sub setup_home {my$self=shift;$self->{home}=$self->env('HOME')if$self->env('HOME');unless (_writable($self->{home})){die "Can't write to cpanm home '$self->{home}': You should fix it with chown/chmod first.\n"}$self->{base}="$self->{home}/work/" .time .".$$";File::Path::mkpath([$self->{base}],0,0777);$self->{log}=File::Spec->catfile($self->{base},"build.log");my$final_log="$self->{home}/build.log";{open my$out,">$self->{log}" or die "$self->{log}: $!"}if (CAN_SYMLINK){my$build_link="$self->{home}/latest-build";unlink$build_link;symlink$self->{base},$build_link;unlink$final_log;symlink$self->{log},$final_log}else {my$log=$self->{log};my$home=$self->{home};$self->{at_exit}=sub {my$self=shift;my$temp_log="$home/build.log." .time .".$$";File::Copy::copy($log,$temp_log)&& unlink($final_log);rename($temp_log,$final_log)}}$self->chat("cpanm (App::cpanminus) $VERSION on perl $] built for $Config{archname}\n" ."Work directory is $self->{base}\n")}sub package_index_for {my ($self,$mirror)=@_;return$self->source_for($mirror)."/02packages.details.txt"}sub generate_mirror_index {my ($self,$mirror)=@_;my$file=$self->package_index_for($mirror);my$gz_file=$file .'.gz';my$index_mtime=(stat$gz_file)[9];unless (-e $file && (stat$file)[9]>= $index_mtime){$self->chat("Uncompressing index file...\n");if (eval {require Compress::Zlib}){my$gz=Compress::Zlib::gzopen($gz_file,"rb")or do {$self->diag_fail("$Compress::Zlib::gzerrno opening compressed index");return};open my$fh,'>',$file or do {$self->diag_fail("$! opening uncompressed index for write");return};my$buffer;while (my$status=$gz->gzread($buffer)){if ($status < 0){$self->diag_fail($gz->gzerror ." reading compressed index");return}print$fh $buffer}}else {if (system("gunzip -c $gz_file > $file")){$self->diag_fail("Cannot uncompress -- please install gunzip or Compress::Zlib");return}}utime$index_mtime,$index_mtime,$file}return 1}sub search_mirror_index {my ($self,$mirror,$module,$version)=@_;$self->search_mirror_index_file($self->package_index_for($mirror),$module,$version)}sub search_mirror_index_file {my($self,$file,$module,$version)=@_;open my$fh,'<',$file or return;my$found;while (<$fh>){if (m!^\Q$module\E\s+([\w\.]+)\s+(\S*)!m){$found=$self->cpan_module($module,$2,$1);last}}return$found unless$self->{cascade_search};if ($found){if ($self->satisfy_version($module,$found->{module_version},$version)){return$found}else {$self->chat("Found $module $found->{module_version} which doesn't satisfy $version.\n")}}return}sub with_version_range {my($self,$version)=@_;defined($version)&& $version =~ /(?:<|!=|==)/}sub encode_json {my($self,$data)=@_;require JSON::PP;my$json=JSON::PP::encode_json($data);$self->uri_escape($json)}sub decode_json {my($self,$json)=@_;require JSON::PP;JSON::PP::decode_json($json)}sub uri_escape {my($self,$fragment)=@_;$fragment =~ s/([^A-Za-z0-9\-\._~])/uc sprintf("%%%02X", ord($1))/eg;$fragment}sub uri_params {my($self,@params)=@_;my@param_strings;while (my$key=shift@params){my$value=shift@params;push@param_strings,join '=',map$self->uri_escape($_),$key,$value}return join '&',@param_strings}sub numify_ver {my($self,$ver)=@_;eval version->new($ver)->numify}sub search_metacpan {my($self,$module,$version,$dev_release)=@_;my$metacpan_uri='http://fastapi.metacpan.org/v1/download_url/';my$url=$metacpan_uri .$module;my$query=$self->uri_params(($version ? (version=>$version): ()),($dev_release ? (dev=>1): ()),);$url .= '?' .$query if length$query;my$dist_json=$self->get($url);my$dist_meta=eval {$self->decode_json($dist_json)};if ($dist_meta && $dist_meta->{download_url}){(my$distfile=$dist_meta->{download_url})=~ s!.+/authors/id/!!;local$self->{mirrors}=$self->{mirrors};$self->{mirrors}=['http://cpan.metacpan.org' ];return$self->cpan_module($module,$distfile,$dist_meta->{version})}$self->chat("! Could not find a release matching $module".($version?" ($version)":'')." on MetaCPAN.\n");return}sub search_database {my($self,$module,$version)=@_;my$found;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}}sub search_cpanmetadb {my($self,$module,$version,$dev_release)=@_;$self->chat("Searching $module ($version) on cpanmetadb ...\n");if ($self->with_version_range($version)){return$self->search_cpanmetadb_history($module,$version,$dev_release)}else {return$self->search_cpanmetadb_package($module,$version,$dev_release)}}sub search_cpanmetadb_package {my($self,$module,$version,$dev_release)=@_;require CPAN::Meta::YAML;(my$uri=$self->{cpanmetadb})=~ s{/?$}{/package/$module};my$yaml=$self->get($uri);my$meta=eval {CPAN::Meta::YAML::Load($yaml)};if ($meta && $meta->{distfile}){return$self->cpan_module($module,$meta->{distfile},$meta->{version})}$self->diag_fail("Finding $module on cpanmetadb failed.");return}sub search_cpanmetadb_history {my($self,$module,$version)=@_;(my$uri=$self->{cpanmetadb})=~ s{/?$}{/history/$module};my$content=$self->get($uri)or return;my@found;for my$line (split /\r?\n/,$content){if ($line =~ /^$module\s+(\S+)\s+(\S+)$/){push@found,{version=>$1,version_obj=>version::->parse($1),distfile=>$2,}}}return unless@found;$found[-1]->{latest}=1;my$match;for my$try (sort {$b->{version_obj}cmp $a->{version_obj}}@found){if ($self->satisfy_version($module,$try->{version_obj},$version)){local$self->{mirrors}=$self->{mirrors};unshift @{$self->{mirrors}},'http://backpan.perl.org' unless$try->{latest};return$self->cpan_module($module,$try->{distfile},$try->{version})}}$self->diag_fail("Finding $module ($version) on cpanmetadb failed.");return}sub search_module {my($self,$module,$version)=@_;if ($self->{mirror_index}){$self->mask_output(chat=>"Searching $module on mirror index $self->{mirror_index} ...\n");my$pkg=$self->search_mirror_index_file($self->{mirror_index},$module,$version);return$pkg if$pkg;unless ($self->{cascade_search}){$self->mask_output(diag_fail=>"Finding $module ($version) on mirror index $self->{mirror_index} failed.");return}}unless ($self->{mirror_only}){my$found=$self->search_database($module,$version);return$found if$found}MIRROR: for my$mirror (@{$self->{mirrors}}){$self->mask_output(chat=>"Searching $module on mirror $mirror ...\n");my$name='02packages.details.txt.gz';my$uri="$mirror/modules/$name";my$gz_file=$self->package_index_for($mirror).'.gz';unless ($self->{pkgs}{$uri}){$self->mask_output(chat=>"Downloading index file $uri ...\n");$self->mirror($uri,$gz_file);$self->generate_mirror_index($mirror)or next MIRROR;$self->{pkgs}{$uri}="!!retrieved!!"}my$pkg=$self->search_mirror_index($mirror,$module,$version);return$pkg if$pkg;$self->mask_output(diag_fail=>"Finding $module ($version) on mirror $mirror failed.")}return}sub source_for {my($self,$mirror)=@_;$mirror =~ s/[^\w\.\-]+/%/g;my$dir="$self->{home}/sources/$mirror";File::Path::mkpath([$dir ],0,0777);return$dir}sub load_argv_from_fh {my($self,$fh)=@_;my@argv;while(defined(my$line=<$fh>)){chomp$line;$line =~ s/#.+$//;$line =~ s/^\s+//;$line =~ s/\s+$//;push@argv,split ' ',$line if$line}return@argv}sub show_version {my$self=shift;print "cpanm (App::cpanminus) version $VERSION ($0)\n";print "perl version $] ($^X)\n\n";print " \%Config:\n";for my$key (qw(archname installsitelib installsitebin installman1dir installman3dir sitearchexp sitelibexp vendorarch vendorlibexp archlibexp privlibexp)){print " $key=$Config{$key}\n" if$Config{$key}}print " \%ENV:\n";for my$key (grep /^PERL/,sort keys%ENV){print " $key=$ENV{$key}\n"}print " \@INC:\n";for my$inc (@INC){print " $inc\n" unless ref($inc)eq 'CODE'}return 1}sub show_help {my$self=shift;if ($_[0]){print <<USAGE;return}print <<HELP;return 1}sub _writable {my$dir=shift;my@dir=File::Spec->splitdir($dir);while (@dir){$dir=File::Spec->catdir(@dir);if (-e $dir){return -w _}pop@dir}return}sub maybe_abs {my($self,$lib)=@_;if ($lib eq '_' or $lib =~ /^~/ or File::Spec->file_name_is_absolute($lib)){return$lib}else {return File::Spec->canonpath(File::Spec->catdir(Cwd::cwd(),$lib))}}sub local_lib_target {my($self,$root)=@_;(grep {$_ ne ''}split /\Q$Config{path_sep}/,$root)[0]}sub bootstrap_local_lib {my$self=shift;if ($self->{local_lib}){return$self->setup_local_lib($self->{local_lib})}if ($ENV{PERL_LOCAL_LIB_ROOT}&& $ENV{PERL_MM_OPT}){return$self->setup_local_lib($self->local_lib_target($ENV{PERL_LOCAL_LIB_ROOT}),1)}return if$self->{sudo}or (_writable($Config{installsitelib})and _writable($Config{installsitebin}));if ($ENV{PERL_MM_OPT}and ($ENV{MODULEBUILDRC}or $ENV{PERL_MB_OPT})){return}$self->setup_local_lib;$self->diag(<<DIAG,1);sleep 2}sub upgrade_toolchain {my($self,$config_deps)=@_;my%deps=map {$_->module=>$_}@$config_deps;my$reqs=CPAN::Meta::Requirements->from_string_hash({'Module::Build'=>'0.38','ExtUtils::MakeMaker'=>'6.58','ExtUtils::Install'=>'1.46',});if ($deps{"ExtUtils::MakeMaker"}){$deps{"ExtUtils::MakeMaker"}->merge_with($reqs)}elsif ($deps{"Module::Build"}){$deps{"Module::Build"}->merge_with($reqs);$deps{"ExtUtils::Install"}||= App::cpanminus::Dependency->new("ExtUtils::Install",0,'configure');$deps{"ExtUtils::Install"}->merge_with($reqs)}@$config_deps=values%deps}sub _core_only_inc {my($self,$base)=@_;require local::lib;(local::lib->resolve_path(local::lib->install_base_arch_path($base)),local::lib->resolve_path(local::lib->install_base_perl_path($base)),(!$self->{exclude_vendor}? grep {$_}@Config{qw(vendorarch vendorlibexp)}: ()),@Config{qw(archlibexp privlibexp)},)}sub _diff {my($self,$old,$new)=@_;my@diff;my%old=map {$_=>1}@$old;for my$n (@$new){push@diff,$n unless exists$old{$n}}@diff}sub _setup_local_lib_env {my($self,$base)=@_;$self->diag(<<WARN,1)if$base =~ /\s/;local$SIG{__WARN__}=sub {};local::lib->setup_env_hash_for($base,0)}sub setup_local_lib {my($self,$base,$no_env)=@_;$base=undef if$base eq '_';require local::lib;{local $0='cpanm';$base ||= "~/perl5";$base=local::lib->resolve_path($base);if ($self->{self_contained}){my@inc=$self->_core_only_inc($base);$self->{search_inc}=[@inc ]}else {$self->{search_inc}=[local::lib->install_base_arch_path($base),local::lib->install_base_perl_path($base),@INC,]}$self->_setup_local_lib_env($base)unless$no_env;$self->{local_lib}=$base}}sub prompt_bool {my($self,$mess,$def)=@_;my$val=$self->prompt($mess,$def);return lc$val eq 'y'}sub prompt {my($self,$mess,$def)=@_;my$isa_tty=-t STDIN && (-t STDOUT ||!(-f STDOUT || -c STDOUT));my$dispdef=defined$def ? "[$def] " : " ";$def=defined$def ? $def : "";if (!$self->{prompt}|| (!$isa_tty && eof STDIN)){return$def}local $|=1;local $\;my$ans;eval {local$SIG{ALRM}=sub {undef$ans;die "alarm\n"};print STDOUT "$mess $dispdef";alarm$self->{prompt_timeout}if$self->{prompt_timeout};$ans=<STDIN>;alarm 0};if (defined$ans){chomp$ans}else {print STDOUT "\n"}return (!defined$ans || $ans eq '')? $def : $ans}sub diag_ok {my($self,$msg)=@_;chomp$msg;$msg ||= "OK";if ($self->{in_progress}){$self->_diag("$msg\n");$self->{in_progress}=0}$self->log("-> $msg\n")}sub diag_fail {my($self,$msg,$always)=@_;chomp$msg;if ($self->{in_progress}){$self->_diag("FAIL\n");$self->{in_progress}=0}if ($msg){$self->_diag("! $msg\n",$always,1);$self->log("-> FAIL $msg\n")}}sub diag_progress {my($self,$msg)=@_;chomp$msg;$self->{in_progress}=1;$self->_diag("$msg ... ");$self->log("$msg\n")}sub _diag {my($self,$msg,$always,$error)=@_;my$fh=$error ? *STDERR : *STDOUT;print {$fh}$msg if$always or $self->{verbose}or!$self->{quiet}}sub diag {my($self,$msg,$always)=@_;$self->_diag($msg,$always);$self->log($msg)}sub chat {my$self=shift;print STDERR @_ if$self->{verbose};$self->log(@_)}sub mask_output {my$self=shift;my$method=shift;$self->$method($self->mask_uri_passwords(@_))}sub log {my$self=shift;open my$out,">>$self->{log}";print$out @_}sub run {my($self,$cmd)=@_;if (WIN32){$cmd=$self->shell_quote(@$cmd)if ref$cmd eq 'ARRAY';unless ($self->{verbose}){$cmd .= " >> " .$self->shell_quote($self->{log})." 2>&1"}!system$cmd}else {my$pid=fork;if ($pid){waitpid$pid,0;return!$?}else {$self->run_exec($cmd)}}}sub run_exec {my($self,$cmd)=@_;if (ref$cmd eq 'ARRAY'){unless ($self->{verbose}){open my$logfh,">>",$self->{log};open STDERR,'>&',$logfh;open STDOUT,'>&',$logfh;close$logfh}exec @$cmd}else {unless ($self->{verbose}){$cmd .= " >> " .$self->shell_quote($self->{log})." 2>&1"}exec$cmd}}sub run_timeout {my($self,$cmd,$timeout)=@_;return$self->run($cmd)if WIN32 || $self->{verbose}||!$timeout;my$pid=fork;if ($pid){eval {local$SIG{ALRM}=sub {die "alarm\n"};alarm$timeout;waitpid$pid,0;alarm 0};if ($@ && $@ eq "alarm\n"){$self->diag_fail("Timed out (> ${timeout}s). Use --verbose to retry.");local$SIG{TERM}='IGNORE';kill TERM=>0;waitpid$pid,0;return}return!$?}elsif ($pid==0){$self->run_exec($cmd)}else {$self->chat("! fork failed: falling back to system()\n");$self->run($cmd)}}sub append_args {my($self,$cmd,$phase)=@_;if (my$args=$self->{build_args}{$phase}){$cmd=join ' ',$self->shell_quote(@$cmd),$args}$cmd}sub configure {my($self,$cmd,$depth)=@_;local$ENV{PERL5_CPAN_IS_RUNNING}=local$ENV{PERL5_CPANPLUS_IS_RUNNING}=$$;local$ENV{PERL5_CPANM_IS_RUNNING}=$$;my$use_default=!$self->{interactive};local$ENV{PERL_MM_USE_DEFAULT}=$use_default;local$ENV{PERL_MM_OPT}=$ENV{PERL_MM_OPT};local$ENV{PERL_MB_OPT}=$ENV{PERL_MB_OPT};unless ($self->{pod2man}){$ENV{PERL_MM_OPT}.= " INSTALLMAN1DIR=none INSTALLMAN3DIR=none";$ENV{PERL_MB_OPT}.= " --config installman1dir= --config installsiteman1dir= --config installman3dir= --config installsiteman3dir="}if ($self->{pure_perl}){$ENV{PERL_MM_OPT}.= " PUREPERL_ONLY=1";$ENV{PERL_MB_OPT}.= " --pureperl-only"}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};local$ENV{PERL_MM_USE_DEFAULT}=!$self->{interactive};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){system("$pager < $self->{log}")}else {$self->diag_fail("You don't seem to have a PAGER :/")}}sub chdir {my$self=shift;Cwd::chdir(File::Spec->canonpath($_[0]))or die "$_[0]: $!"}sub configure_mirrors {my$self=shift;unless (@{$self->{mirrors}}){$self->{mirrors}=['http://www.cpan.org' ]}for (@{$self->{mirrors}}){s!^/!file:///!;s!/$!!}}sub self_upgrade {my$self=shift;$self->check_upgrade;$self->{argv}=['App::cpanminus' ];return}sub install_module {my($self,$module,$depth,$version)=@_;$self->check_libs;if ($self->{seen}{$module}++){$self->chat("Already tried $module. Skipping.\n");return 1}if ($self->{skip_satisfied}){my($ok,$local)=$self->check_module($module,$version || 0);if ($ok){$self->diag("You have $module ($local)\n",1);return 1}}my$dist=$self->resolve_name($module,$version);unless ($dist){my$what=$module .($version ? " ($version)" : "");$self->diag_fail("Couldn't find module or a distribution $what",1);return}if ($dist->{distvname}&& $self->{seen}{$dist->{distvname}}++){$self->chat("Already tried $dist->{distvname}. Skipping.\n");return 1}if ($self->{cmd}eq 'info'){print$self->format_dist($dist),"\n";return 1}$dist->{depth}=$depth;if ($dist->{module}){unless ($self->satisfy_version($dist->{module},$dist->{module_version},$version)){$self->diag("Found $dist->{module} $dist->{module_version} which doesn't satisfy $version.\n",1);return}my$cmp=$version ? "==" : "";my$requirement=$dist->{module_version}? "$cmp$dist->{module_version}" : 0;my($ok,$local)=$self->check_module($dist->{module},$requirement);if ($self->{skip_installed}&& $ok){$self->diag("$dist->{module} is up to date. ($local)\n",1);return 1}}if ($dist->{dist}eq 'perl'){$self->diag("skipping $dist->{pathname}\n");return 1}$self->diag("--> Working on $module\n");$dist->{dir}||= $self->fetch_module($dist);unless ($dist->{dir}){$self->diag_fail("Failed to fetch distribution $dist->{distvname}",1);return}$self->chat("Entering $dist->{dir}\n");$self->chdir($self->{base});$self->chdir($dist->{dir});if ($self->{cmd}eq 'look'){$self->look;return 1}return$self->build_stuff($module,$dist,$depth)}sub uninstall_search_path {my$self=shift;$self->{local_lib}? (local::lib->install_base_arch_path($self->{local_lib}),local::lib->install_base_perl_path($self->{local_lib})): @Config{qw(installsitearch installsitelib)}}sub uninstall_module {my ($self,$module)=@_;$self->check_libs;my@inc=$self->uninstall_search_path;my($metadata,$packlist)=$self->packlists_containing($module,\@inc);unless ($packlist){$self->diag_fail(<<DIAG,1);return}my@uninst_files=$self->uninstall_target($metadata,$packlist);$self->ask_permission($module,\@uninst_files)or return;$self->uninstall_files(@uninst_files,$packlist);$self->diag("Successfully uninstalled $module\n",1);return 1}sub packlists_containing {my($self,$module,$inc)=@_;require Module::Metadata;my$metadata=Module::Metadata->new_from_module($module,inc=>$inc)or return;my$packlist;my$wanted=sub {return unless $_ eq '.packlist' && -f $_;for my$file ($self->unpack_packlist($File::Find::name)){$packlist ||= $File::Find::name if$file eq $metadata->filename}};{require File::pushd;my$pushd=File::pushd::pushd();my@search=grep -d $_,map File::Spec->catdir($_,'auto'),@$inc;File::Find::find($wanted,@search)}return$metadata,$packlist}sub uninstall_target {my($self,$metadata,$packlist)=@_;if ($self->has_shadow_install($metadata)or $self->{local_lib}){grep$self->should_unlink($_),$self->unpack_packlist($packlist)}else {$self->unpack_packlist($packlist)}}sub has_shadow_install {my($self,$metadata)=@_;my@shadow=grep defined,map Module::Metadata->new_from_module($metadata->name,inc=>[$_]),@INC;@shadow >= 2}sub should_unlink {my($self,$file)=@_;if ($self->{local_lib}){$file =~ /^\Q$self->{local_lib}\E/}else {!(grep$file =~ /^\Q$_\E/,@Config{qw(installbin installscript installman1dir installman3dir)})}}sub ask_permission {my ($self,$module,$files)=@_;$self->diag("$module contains the following files:\n\n");for my$file (@$files){$self->diag(" $file\n")}$self->diag("\n");return 'force uninstall' if$self->{force};local$self->{prompt}=1;return$self->prompt_bool("Are you sure you want to uninstall $module?",'y')}sub unpack_packlist {my ($self,$packlist)=@_;open my$fh,'<',$packlist or die "$packlist: $!";map {chomp;$_}<$fh>}sub uninstall_files {my ($self,@files)=@_;$self->diag("\n");for my$file (@files){$self->diag("Unlink: $file\n");unlink$file or $self->diag_fail("$!: $file")}$self->diag("\n");return 1}sub format_dist {my($self,$dist)=@_;return "$dist->{cpanid}/$dist->{filename}"}sub trim {local $_=shift;tr/\n/ /d;s/^\s*|\s*$//g;$_}sub fetch_module {my($self,$dist)=@_;$self->chdir($self->{base});for my$uri (@{$dist->{uris}}){$self->mask_output(diag_progress=>"Fetching $uri");my$filename=$dist->{filename}|| $uri;my$name=File::Basename::basename($filename);my$cancelled;my$fetch=sub {my$file;eval {local$SIG{INT}=sub {$cancelled=1;die "SIGINT\n"};$self->mirror($uri,$name);$file=$name if -e $name};$self->diag("ERROR: " .trim("$@")."\n",1)if $@ && $@ ne "SIGINT\n";return$file};my($try,$file);while ($try++ < 3){$file=$fetch->();last if$cancelled or $file;$self->mask_output(diag_fail=>"Download $uri failed. Retrying ... ")}if ($cancelled){$self->diag_fail("Download cancelled.");return}unless ($file){$self->mask_output(diag_fail=>"Failed to download $uri");next}$self->diag_ok;$dist->{local_path}=File::Spec->rel2abs($name);my$dir=$self->unpack($file,$uri,$dist);next unless$dir;if (my$save=$self->{save_dists}){my$path=$dist->{pathname}? "$save/authors/id/$dist->{pathname}" : "$save/vendor/$file";$self->chat("Copying $name to $path\n");File::Path::mkpath([File::Basename::dirname($path)],0,0777);File::Copy::copy($file,$path)or warn $!}return$dist,$dir}}sub unpack {my($self,$file,$uri,$dist)=@_;if ($self->{verify}){$self->verify_archive($file,$uri,$dist)or return}$self->chat("Unpacking $file\n");my$dir=$file =~ /\.zip/i ? $self->unzip($file): $self->untar($file);unless ($dir){$self->diag_fail("Failed to unpack $file: no directory")}return$dir}sub verify_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_checksum($file,$chk_file)}sub verify_checksum {my($self,$file,$chk_file)=@_;$self->chat("Verifying the SHA1 for $file\n");open my$fh,"<$chk_file" or die "$chk_file: $!";my$data=join '',<$fh>;$data =~ s/\015?\012/\n/g;require Safe;my$chksum=Safe->new->reval($data);if (!ref$chksum or ref$chksum ne 'HASH'){$self->diag_fail("! Checksum file downloaded from $chk_file is broken.\n");return}if (my$sha=$chksum->{$file}{sha256}){my$hex=$self->sha1_for($file);if ($hex eq $sha){$self->chat("Checksum for $file: Verified!\n")}else {$self->diag_fail("Checksum mismatch for $file\n");return}}else {$self->chat("Checksum for $file not found in CHECKSUMS.\n");return}}sub sha1_for {my($self,$file)=@_;require Digest::SHA;open my$fh,"<",$file or die "$file: $!";my$dg=Digest::SHA->new(256);my($data);while (read($fh,$data,4096)){$dg->add($data)}return$dg->hexdigest}sub verify_signature {my($self,$dist)=@_;$self->diag_progress("Verifying the SIGNATURE file");my$out=`$self->{cpansign} -v --skip 2>&1`;$self->log($out);if ($out =~ /Signature verified OK/){$self->diag_ok("Verified OK");return 1}else {$self->diag_fail("SIGNATURE verification for $dist->{filename} failed\n");return}}sub resolve_name {my($self,$module,$version)=@_;if ($module =~ /(?:^git:|\.git(?:@.+)?$)/){return$self->git_uri($module)}if ($module =~ /^(ftp|https?|file):/){if ($module =~ m!authors/id/(.*)!){return$self->cpan_dist($1,$module)}else {return {uris=>[$module ]}}}if ($module =~ m!^[\./]! && -d $module){return {source=>'local',dir=>Cwd::abs_path($module),}}if (-f $module){return {source=>'local',uris=>["file://" .Cwd::abs_path($module)],}}if ($module =~ s!^cpan:///distfile/!!){return$self->cpan_dist($module)}if ($module =~ m!^(?:[A-Z]/[A-Z]{2}/)?([A-Z]{2}[\-A-Z0-9]*/.*)$!){return$self->cpan_dist($1)}return$self->search_module($module,$version)}sub cpan_module {my($self,$module,$dist_file,$version)=@_;my$dist=$self->cpan_dist($dist_file);$dist->{module}=$module;$dist->{module_version}=$version if$version && $version ne 'undef';return$dist}sub cpan_dist {my($self,$dist,$url)=@_;$dist =~ s!^([A-Z]{2})!substr($1,0,1)."/".substr($1,0,2)."/".$1!e;require CPAN::DistnameInfo;my$d=CPAN::DistnameInfo->new($dist);if ($url){$url=[$url ]unless ref$url eq 'ARRAY'}else {my$id=$d->cpanid;my$fn=substr($id,0,1)."/" .substr($id,0,2)."/" .$id ."/" .$d->filename;my@mirrors=@{$self->{mirrors}};my@urls=map "$_/authors/id/$fn",@mirrors;$url=\@urls,}return {$d->properties,source=>'cpan',uris=>$url,}}sub git_uri {my ($self,$uri)=@_;($uri,my$commitish)=split /(?<=\.git)@/i,$uri,2;my$dir=File::Temp::tempdir(CLEANUP=>1);$self->mask_output(diag_progress=>"Cloning $uri");$self->run(['git','clone',$uri,$dir ]);unless (-e "$dir/.git"){$self->diag_fail("Failed cloning git repository $uri",1);return}if ($commitish){require File::pushd;my$dir=File::pushd::pushd($dir);unless ($self->run(['git','checkout',$commitish ])){$self->diag_fail("Failed to checkout '$commitish' in git repository $uri\n");return}}$self->diag_ok;return {source=>'local',dir=>$dir,}}sub setup_module_build_patch {my$self=shift;open my$out,">$self->{base}/ModuleBuildSkipMan.pm" or die $!;print$out <<EOF}sub core_version_for {my($self,$module)=@_;require Module::CoreList;unless (exists$Module::CoreList::version{$]+0}){die sprintf("Module::CoreList %s (loaded from %s) doesn't seem to have entries for perl $]. " ."You're strongly recommended to upgrade Module::CoreList from CPAN.\n",$Module::CoreList::VERSION,$INC{"Module/CoreList.pm"})}unless (exists$Module::CoreList::version{$]+0}{$module}){return -1}return$Module::CoreList::version{$]+0}{$module}}sub search_inc {my$self=shift;$self->{search_inc}||= do {if (defined$::Bin){[grep!/^\Q$::Bin\E\/..\/(?:fat)?lib$/,@INC]}else {[@INC]}}}sub check_module {my($self,$mod,$want_ver)=@_;require Module::Metadata;my$meta=Module::Metadata->new_from_module($mod,inc=>$self->search_inc)or return 0,undef;my$version=$meta->version;if ($self->{self_contained}&& $self->loaded_from_perl_lib($meta)){$version=$self->core_version_for($mod);return 0,undef if$version && $version==-1}$self->{local_versions}{$mod}=$version;if ($self->is_deprecated($meta)){return 0,$version}elsif ($self->satisfy_version($mod,$version,$want_ver)){return 1,($version || 'undef')}else {return 0,$version}}sub satisfy_version {my($self,$mod,$version,$want_ver)=@_;$want_ver='0' unless defined($want_ver)&& length($want_ver);require CPAN::Meta::Requirements;my$requirements=CPAN::Meta::Requirements->new;$requirements->add_string_requirement($mod,$want_ver);$requirements->accepts_module($mod,$version)}sub unsatisfy_how {my($self,$ver,$want_ver)=@_;if ($want_ver =~ /^[v0-9\.\_]+$/){return "$ver < $want_ver"}else {return "$ver doesn't satisfy $want_ver"}}sub is_deprecated {my($self,$meta)=@_;my$deprecated=eval {require Module::CoreList;Module::CoreList::is_deprecated($meta->{module})};return$deprecated && $self->loaded_from_perl_lib($meta)}sub loaded_from_perl_lib {my($self,$meta)=@_;require Config;my@dirs=qw(archlibexp privlibexp);if ($self->{self_contained}&&!$self->{exclude_vendor}&& $Config{vendorarch}){unshift@dirs,qw(vendorarch vendorlibexp)}for my$dir (@dirs){my$confdir=$Config{$dir};if ($confdir eq substr($meta->filename,0,length($confdir))){return 1}}return}sub should_install {my($self,$mod,$ver)=@_;$self->chat("Checking if you have $mod $ver ... ");my($ok,$local)=$self->check_module($mod,$ver);if ($ok){$self->chat("Yes ($local)\n")}elsif ($local){$self->chat("No (" .$self->unsatisfy_how($local,$ver).")\n")}else {$self->chat("No\n")}return$mod unless$ok;return}sub check_perl_version {my($self,$version)=@_;require CPAN::Meta::Requirements;my$req=CPAN::Meta::Requirements->from_string_hash({perl=>$version });$req->accepts_module(perl=>$])}sub install_deps {my($self,$dir,$depth,@deps)=@_;my(@install,%seen,@fail);for my$dep (@deps){next if$seen{$dep->module};if ($dep->module eq 'perl'){if ($dep->is_requirement &&!$self->check_perl_version($dep->version)){$self->diag("Needs perl @{[$dep->version]}, you have $]\n");push@fail,'perl'}}elsif ($self->should_install($dep->module,$dep->version)){push@install,$dep;$seen{$dep->module}=1}}if (@install){$self->diag("==> Found dependencies: " .join(", ",map $_->module,@install)."\n")}for my$dep (@install){$self->install_module($dep->module,$depth + 1,$dep->version)}$self->chdir($self->{base});$self->chdir($dir)if$dir;if ($self->{scandeps}){return 1}my@not_ok=$self->unsatisfied_deps(@deps);if (@not_ok){return 0,\@not_ok}else {return 1}}sub unsatisfied_deps {my($self,@deps)=@_;require CPAN::Meta::Check;require CPAN::Meta::Requirements;my$reqs=CPAN::Meta::Requirements->new;for my$dep (grep $_->is_requirement,@deps){$reqs->add_string_requirement($dep->module=>$dep->requires_version || '0')}my$ret=CPAN::Meta::Check::check_requirements($reqs,'requires',$self->{search_inc});grep defined,values %$ret}sub install_deps_bailout {my($self,$target,$dir,$depth,@deps)=@_;my($ok,$fail)=$self->install_deps($dir,$depth,@deps);if (!$ok){$self->diag_fail("Installing the dependencies failed: " .join(", ",@$fail),1);unless ($self->prompt_bool("Do you want to continue building $target anyway?","n")){$self->diag_fail("Bailing out the installation for $target.",1);return}}return 1}sub build_stuff {my($self,$stuff,$dist,$depth)=@_;if ($self->{verify}&& -e 'SIGNATURE'){$self->verify_signature($dist)or return}require CPAN::Meta;my($meta_file)=grep -f,qw(META.json META.yml);if ($meta_file){$self->chat("Checking configure dependencies from $meta_file\n");$dist->{cpanmeta}=eval {CPAN::Meta->load_file($meta_file)}}elsif ($dist->{dist}&& $dist->{version}){$self->chat("META.yml/json not found. Creating skeleton for it.\n");$dist->{cpanmeta}=CPAN::Meta->new({name=>$dist->{dist},version=>$dist->{version}})}$dist->{meta}=$dist->{cpanmeta}? $dist->{cpanmeta}->as_struct : {};my@config_deps;if ($dist->{cpanmeta}){push@config_deps,App::cpanminus::Dependency->from_prereqs($dist->{cpanmeta}->effective_prereqs,['configure'],$self->{install_types},)}if (-e 'Build.PL' &&!$self->should_use_mm($dist->{dist})&&!@config_deps){push@config_deps,App::cpanminus::Dependency->from_versions({'Module::Build'=>'0.38' },'configure',)}$self->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},".")}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;if (@config_deps){my@tree=@{$self->{scandeps_tree}};$diag .= "!\n" .join("",map "! * $_->[0]{module}\n",@tree[0..$#tree-1])if@tree}$self->diag("!\n$diag!\n",1)}$walkup->();return 1}if ($self->{installdeps}&& $depth==0){if ($configure_state->{configured_ok}){$self->diag("<== Installed dependencies for $stuff. Finishing.\n");return 1}else {$self->diag("! Configuring $distname failed. See $self->{log} for details.\n",1);return}}my$installed;if ($configure_state->{use_module_build}&& -e 'Build' && -f _){$self->diag_progress("Building " .($self->{notest}? "" : "and testing ").$distname);$self->build([$self->{perl},"./Build" ],$distname,$depth)&& $self->test([$self->{perl},"./Build","test" ],$distname,$depth)&& $self->install([$self->{perl},"./Build","install" ],["--uninst",1 ],$depth)&& $installed++}elsif ($self->{make}&& -e 'Makefile'){$self->diag_progress("Building " .($self->{notest}? "" : "and testing ").$distname);$self->build([$self->{make}],$distname,$depth)&& $self->test([$self->{make},"test" ],$distname,$depth)&& $self->install([$self->{make},"install" ],["UNINST=1" ],$depth)&& $installed++}else {my$why;my$configure_failed=$configure_state->{configured}&&!$configure_state->{configured_ok};if ($configure_failed){$why="Configure failed for $distname."}elsif ($self->{make}){$why="The distribution doesn't have a proper Makefile.PL/Build.PL"}else {$why="Can't configure the distribution. You probably need to have 'make'."}$self->diag_fail("$why See $self->{log} for details.",1);return}if ($installed && $self->{test_only}){$self->diag_ok;$self->diag("Successfully tested $distname\n",1)}elsif ($installed){my$local=$self->{local_versions}{$dist->{module}|| ''};my$version=$dist->{module_version}|| $dist->{meta}{version}|| $dist->{version};my$reinstall=$local && ($local eq $version);my$action=$local &&!$reinstall ? $self->numify_ver($version)< $self->numify_ver($local)? "downgraded" : "upgraded" : undef;my$how=$reinstall ? "reinstalled $distname" : $local ? "installed $distname ($action from $local)" : "installed $distname" ;my$msg="Successfully $how";$self->diag_ok;$self->diag("$msg\n",1);$self->{installed_dists}++;$self->save_meta($stuff,$dist,$module_name,\@config_deps,\@deps);return 1}else {my$what=$self->{test_only}? "Testing" : "Installing";$self->diag_fail("$what $stuff failed. See $self->{log} for details. Retry with --force to force install it.",1);return}}sub perl_requirements {my($self,@requires)=@_;my@perl;for my$requires (grep defined,@requires){if (exists$requires->{perl}){push@perl,App::cpanminus::Dependency->new(perl=>$requires->{perl})}}return@perl}sub should_use_mm {my($self,$dist)=@_;my%should_use_mm=map {$_=>1}qw(version ExtUtils-ParseXS ExtUtils-Install ExtUtils-Manifest);$should_use_mm{$dist}}sub configure_this {my($self,$dist,$depth)=@_;if (-e $self->{cpanfile_path}&& $self->{installdeps}&& $depth==0){require Module::CPANfile;$dist->{cpanfile}=eval {Module::CPANfile->load($self->{cpanfile_path})};$self->diag_fail($@,1)if $@;return {configured=>1,configured_ok=>!!$dist->{cpanfile},use_module_build=>0,}}if ($self->{skip_configure}){my$eumm=-e 'Makefile';my$mb=-e 'Build' && -f _;return {configured=>1,configured_ok=>$eumm || $mb,use_module_build=>$mb,}}my$state={};my$try_eumm=sub {if (-e 'Makefile.PL'){$self->chat("Running Makefile.PL\n");if ($self->configure([$self->{perl},"Makefile.PL" ],$depth)){$state->{configured_ok}=-e 'Makefile'}$state->{configured}++}};my$try_mb=sub {if (-e 'Build.PL'){$self->chat("Running Build.PL\n");if ($self->configure([$self->{perl},"Build.PL" ],$depth)){$state->{configured_ok}=-e 'Build' && -f _}$state->{use_module_build}++;$state->{configured}++}};my@try;if ($dist->{dist}&& $self->should_use_mm($dist->{dist})){@try=($try_eumm,$try_mb)}else {@try=($try_mb,$try_eumm)}for my$try (@try){$try->();last if$state->{configured_ok}}unless ($state->{configured_ok}){while (1){my$ans=lc$self->prompt("Configuring $dist->{dist} failed.\nYou can s)kip, r)etry, e)xamine build log, or l)ook ?","s");last if$ans eq 's';return$self->configure_this($dist,$depth)if$ans eq 'r';$self->show_build_log if$ans eq 'e';$self->look if$ans eq 'l'}}return$state}sub find_module_name {my($self,$state)=@_;return unless$state->{configured_ok};if ($state->{use_module_build}&& -e "_build/build_params"){my$params=do {open my$in,"_build/build_params";$self->safe_eval(join "",<$in>)};return eval {$params->[2]{module_name}}|| undef}elsif (-e "Makefile"){open my$mf,"Makefile";while (<$mf>){if (/^\#\s+NAME\s+=>\s+(.*)/){return$self->safe_eval($1)}}}return}sub list_files {my$self=shift;if (-e 'MANIFEST'){require ExtUtils::Manifest;my$manifest=eval {ExtUtils::Manifest::manifind()}|| {};return sort {lc$a cmp lc$b}keys %$manifest}else {require File::Find;my@files;my$finder=sub {my$name=$File::Find::name;$name =~ s!\.[/\\]!!;push@files,$name};File::Find::find($finder,".");return sort {lc$a cmp lc$b}@files}}sub extract_packages {my($self,$meta,$dir)=@_;my$try=sub {my$file=shift;return 0 if$file =~ m!^(?:x?t|inc|local|perl5|fatlib|_build)/!;return 1 unless$meta->{no_index};return 0 if grep {$file =~ m!^$_/!}@{$meta->{no_index}{directory}|| []};return 0 if grep {$file eq $_}@{$meta->{no_index}{file}|| []};return 1};require Parse::PMFile;my@files=grep {/\.pm(?:\.PL)?$/ && $try->($_)}$self->list_files;my$provides={};for my$file (@files){my$parser=Parse::PMFile->new($meta,{UNSAFE=>1,ALLOW_DEV_VERSION=>1 });my$packages=$parser->parse($file);while (my($package,$meta)=each %$packages){$provides->{$package}||= {file=>$meta->{infile},($meta->{version}eq 'undef')? (): (version=>$meta->{version}),}}}return$provides}sub save_meta {my($self,$module,$dist,$module_name,$config_deps,$build_deps)=@_;return unless$dist->{distvname}&& $dist->{source}eq 'cpan';my$base=($ENV{PERL_MM_OPT}|| '')=~ /INSTALL_BASE=/ ? ($self->install_base($ENV{PERL_MM_OPT})."/lib/perl5"): $Config{sitelibexp};my$provides=$dist->{provides};File::Path::mkpath("blib/meta",0,0777);my$local={name=>$module_name,target=>$module,version=>exists$provides->{$module_name}? ($provides->{$module_name}{version}|| $dist->{version}): $dist->{version},dist=>$dist->{distvname},pathname=>$dist->{pathname},provides=>$provides,};require JSON::PP;open my$fh,">","blib/meta/install.json" or die $!;print$fh JSON::PP::encode_json($local);if (-e "MYMETA.json"){File::Copy::copy("MYMETA.json","blib/meta/MYMETA.json")}my@cmd=(($self->{sudo}? 'sudo' : ()),$^X,'-MExtUtils::Install=install','-e',qq[install({ 'blib/meta' => '$base/$Config{archname}/.meta/$dist->{distvname}' })],);$self->run(\@cmd)}sub _merge_hashref {my($self,@hashrefs)=@_;my%hash;for my$h (@hashrefs){%hash=(%hash,%$h)}return \%hash}sub install_base {my($self,$mm_opt)=@_;$mm_opt =~ /INSTALL_BASE=(\S+)/ and return $1;die "Your PERL_MM_OPT doesn't contain INSTALL_BASE"}sub safe_eval {my($self,$code)=@_;eval$code}sub configure_features {my($self,$dist,@features)=@_;map $_->identifier,grep {$self->effective_feature($dist,$_)}@features}sub effective_feature {my($self,$dist,$feature)=@_;if ($dist->{depth}==0){my$value=$self->{features}{$feature->identifier};return$value if defined$value;return 1 if$self->{features}{__all}}if ($self->{interactive}){require CPAN::Meta::Requirements;$self->diag("[@{[ $feature->description ]}]\n",1);my$req=CPAN::Meta::Requirements->new;for my$phase (@{$dist->{want_phases}}){for my$type (@{$self->{install_types}}){$req->add_requirements($feature->prereqs->requirements_for($phase,$type))}}my$reqs=$req->as_string_hash;my@missing;for my$module (keys %$reqs){if ($self->should_install($module,$req->{$module})){push@missing,$module}}if (@missing){my$howmany=@missing;$self->diag("==> Found missing dependencies: " .join(", ",@missing)."\n",1);local$self->{prompt}=1;return$self->prompt_bool("Install the $howmany optional module(s)?","y")}}return}sub find_prereqs {my($self,$dist)=@_;my@deps=$self->extract_meta_prereqs($dist);if ($dist->{module}=~ /^Bundle::/i){push@deps,$self->bundle_deps($dist)}$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);$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})}sub soften_makemaker_prereqs {my($self,$prereqs)=@_;return$prereqs unless -e "inc/Module/Install.pm";for my$phase (qw(build test runtime)){my$reqs=$prereqs->requirements_for($phase,'requires');if ($reqs->requirements_for_module('ExtUtils::MakeMaker')){$reqs->clear_requirement('ExtUtils::MakeMaker');$reqs->add_minimum('ExtUtils::MakeMaker'=>0)}}$prereqs}sub cleanup_workdirs {my$self=shift;my$expire=time - 24 * 60 * 60 * $self->{auto_cleanup};my@targets;opendir my$dh,"$self->{home}/work";while (my$e=readdir$dh){next if$e !~ /^(\d+)\.\d+$/;my$time=$1;if ($time < $expire){push@targets,"$self->{home}/work/$e"}}if (@targets){if (@targets >= 64){$self->diag("Expiring " .scalar(@targets)." work directories. This might take a while...\n")}else {$self->chat("Expiring " .scalar(@targets)." work directories.\n")}File::Path::rmtree(\@targets,0,0)}}sub scandeps_append_child {my($self,$dist)=@_;my$new_node=[$dist,[]];my$curr_node=$self->{scandeps_current}|| [undef,$self->{scandeps_tree}];push @{$curr_node->[1]},$new_node;$self->{scandeps_current}=$new_node;return sub {$self->{scandeps_current}=$curr_node}}sub dump_scandeps {my$self=shift;if ($self->{format}eq 'tree'){$self->walk_down(sub {my($dist,$depth)=@_;if ($depth==0){print "$dist->{distvname}\n"}else {print " " x ($depth - 1);print "\\_ $dist->{distvname}\n"}},1)}elsif ($self->{format}=~ /^dists?$/){$self->walk_down(sub {my($dist,$depth)=@_;print$self->format_dist($dist),"\n"},0)}elsif ($self->{format}eq 'json'){require JSON::PP;print JSON::PP::encode_json($self->{scandeps_tree})}elsif ($self->{format}eq 'yaml'){require YAML;print YAML::Dump($self->{scandeps_tree})}else {$self->diag("Unknown format: $self->{format}\n")}}sub walk_down {my($self,$cb,$pre)=@_;$self->_do_walk_down($self->{scandeps_tree},$cb,0,$pre)}sub _do_walk_down {my($self,$children,$cb,$depth,$pre)=@_;for my$node (@$children){$cb->($node->[0],$depth)if$pre;$self->_do_walk_down($node->[1],$cb,$depth + 1,$pre);$cb->($node->[0],$depth)unless$pre}}sub DESTROY {my$self=shift;$self->{at_exit}->($self)if$self->{at_exit}}sub shell_quote {my($self,@stuff)=@_;if (WIN32){join ' ',map {/^${quote}.+${quote}$/ ? $_ : ($quote .$_ .$quote)}@stuff}else {String::ShellQuote::shell_quote_best_effort(@stuff)}}sub which {my($self,$name)=@_;if (File::Spec->file_name_is_absolute($name)){if (-x $name &&!-d _){return$name}}my$exe_ext=$Config{_exe};for my$dir (File::Spec->path){my$fullpath=File::Spec->catfile($dir,$name);if ((-x $fullpath || -x ($fullpath .= $exe_ext))&&!-d _){if ($fullpath =~ /\s/){$fullpath=$self->shell_quote($fullpath)}return$fullpath}}return}sub get {my($self,$uri)=@_;if ($uri =~ /^file:/){$self->file_get($uri)}else {$self->{_backends}{get}->(@_)}}sub mirror {my($self,$uri,$local)=@_;if ($uri =~ /^file:/){$self->file_mirror($uri,$local)}else {$self->{_backends}{mirror}->(@_)}}sub untar {$_[0]->{_backends}{untar}->(@_)};sub unzip {$_[0]->{_backends}{unzip}->(@_)};sub uri_to_file {my($self,$uri)=@_;if ($uri =~ s!file:/+!!){$uri="/$uri" unless$uri =~ m![a-zA-Z]:!}return$uri}sub file_get {my($self,$uri)=@_;my$file=$self->uri_to_file($uri);open my$fh,"<$file" or return;join '',<$fh>}sub file_mirror {my($self,$uri,$path)=@_;my$file=$self->uri_to_file($uri);my$source_mtime=(stat$file)[9];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;LWP::UserAgent->VERSION(5.802);require LWP::Protocol::https if$https;1}}sub init_tools {my$self=shift;return if$self->{initialized}++;if ($self->{make}=$self->which($Config{make})){$self->chat("You have make $self->{make}\n")}if ($self->{try_lwp}&& $self->has_working_lwp($self->{mirrors})){$self->chat("You have LWP $LWP::VERSION\n");my$ua=sub {LWP::UserAgent->new(parse_head=>0,env_proxy=>1,agent=>$self->agent,timeout=>30,@_,)};$self->{_backends}{get}=sub {my$self=shift;my$res=$ua->()->request(HTTP::Request->new(GET=>$_[0]));return unless$res->is_success;return$res->decoded_content};$self->{_backends}{mirror}=sub {my$self=shift;my$res=$ua->()->mirror(@_);die$res->content if$res->code==501;$res->code}}elsif ($self->{try_wget}and my$wget=$self->which('wget')){$self->chat("You have $wget\n");my@common=('--user-agent',$self->agent,'--retry-connrefused',($self->{verbose}? (): ('-q')),);$self->{_backends}{get}=sub {my($self,$uri)=@_;$self->safeexec(my$fh,$wget,$uri,@common,'-O','-')or die "wget $uri: $!";local $/;<$fh>};$self->{_backends}{mirror}=sub {my($self,$uri,$path)=@_;$self->safeexec(my$fh,$wget,$uri,@common,'-O',$path)or die "wget $uri: $!";local $/;<$fh>}}elsif ($self->{try_curl}and my$curl=$self->which('curl')){$self->chat("You have $curl\n");my@common=('--location','--user-agent',$self->agent,($self->{verbose}? (): '-s'),);$self->{_backends}{get}=sub {my($self,$uri)=@_;$self->safeexec(my$fh,$curl,@common,$uri)or die "curl $uri: $!";local $/;<$fh>};$self->{_backends}{mirror}=sub {my($self,$uri,$path)=@_;$self->safeexec(my$fh,$curl,@common,$uri,'-#','-o',$path)or die "curl $uri: $!";local $/;<$fh>}}else {require HTTP::Tiny;$self->chat("Falling back to HTTP::Tiny $HTTP::Tiny::VERSION\n");my%common=(agent=>$self->agent,);$self->{_backends}{get}=sub {my$self=shift;my$res=HTTP::Tiny->new(%common)->get($_[0]);return unless$res->{success};return$res->{content}};$self->{_backends}{mirror}=sub {my$self=shift;my$res=HTTP::Tiny->new(%common)->mirror(@_);return$res->{status}}}my$tar=$self->which('tar');my$tar_ver;my$maybe_bad_tar=sub {WIN32 || BAD_TAR || (($tar_ver=`$tar --version 2>/dev/null`)=~ /GNU.*1\.13/i)};if ($tar &&!$maybe_bad_tar->()){chomp$tar_ver;$self->chat("You have $tar: $tar_ver\n");$self->{_backends}{untar}=sub {my($self,$tarfile)=@_;my$xf=($self->{verbose}? 'v' : '')."xf";my$ar=$tarfile =~ /bz2$/ ? 'j' : 'z';my($root,@others)=`$tar ${ar}tf $tarfile` or return undef;FILE: {chomp$root;$root =~ s!^\./!!;$root =~ s{^(.+?)/.*$}{$1};if (!length($root)){$root=shift(@others);redo FILE if$root}}system "$tar $ar$xf $tarfile";return$root if -d $root;$self->diag_fail("Bad archive: $tarfile");return undef}}elsif ($tar and my$gzip=$self->which('gzip')and my$bzip2=$self->which('bzip2')){$self->chat("You have $tar, $gzip and $bzip2\n");$self->{_backends}{untar}=sub {my($self,$tarfile)=@_;my$x="x" .($self->{verbose}? 'v' : '')."f -";my$ar=$tarfile =~ /bz2$/ ? $bzip2 : $gzip;my($root,@others)=`$ar -dc $tarfile | $tar tf -` or return undef;FILE: {chomp$root;$root =~ s!^\./!!;$root =~ s{^(.+?)/.*$}{$1};if (!length($root)){$root=shift(@others);redo FILE if$root}}system "$ar -dc $tarfile | $tar $x";return$root if -d $root;$self->diag_fail("Bad archive: $tarfile");return undef}}elsif (eval {require Archive::Tar}){$self->chat("Falling back to Archive::Tar $Archive::Tar::VERSION\n");$self->{_backends}{untar}=sub {my$self=shift;my$t=Archive::Tar->new($_[0]);my($root,@others)=$t->list_files;FILE: {$root =~ s!^\./!!;$root =~ s{^(.+?)/.*$}{$1};if (!length($root)){$root=shift(@others);redo FILE if$root}}$t->extract;return -d $root ? $root : undef}}else {$self->{_backends}{untar}=sub {die "Failed to extract $_[1] - You need to have tar or Archive::Tar installed.\n"}}if (my$unzip=$self->which('unzip')){$self->chat("You have $unzip\n");$self->{_backends}{unzip}=sub {my($self,$zipfile)=@_;my$opt=$self->{verbose}? '' : '-q';my(undef,$root,@others)=`$unzip -t $zipfile` or return undef;FILE: {chomp$root;if ($root !~ s{^\s+testing:\s+([^/]+)/.*?\s+OK$}{$1}){$root=shift(@others);redo FILE if$root}}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; 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 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 Usage: cpanm [options] Module [...] Try `cpanm --help` or `man cpanm` for more options. USAGE 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 ! ! 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 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 $module is not found in the following directories and can't be uninstalled. @{[ join(" \n", map " $_", @inc) ]} DIAG package ModuleBuildSkipMan; CHECK { if (%Module::Build::) { no warnings 'redefine'; *Module::Build::Base::ACTION_manpages = sub {}; *Module::Build::Base::ACTION_docs = sub {}; } } 1; EOF ! Configuring $distname failed. See $self->{log} for details. ! You might have to install the following modules first to get --scandeps working correctly. DIAG 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//}$version =~ s/-withoutworldwriteables$//;if ($version =~ /^(-[Vv].*)-(\d.*)/){$dist .= $1;$version=$2}if ($version =~ /(.+_.*)-(\d.*)/){$dist .= $1;$version=$2}$dist =~ s{\.pm$}{};$version=$1 if!length$version and $dist =~ s/-(\d+\w)$//;$version=$1 .$version if$version =~ /^\d+$/ and $dist =~ s/-(\w+)$//;if ($version =~ /\d\.\d/){$version =~ s/^[-_.]+//}else {$version =~ s/^[-_]+//}my$dev;if (length$version){if ($file =~ /^perl-?\d+\.(\d+)(?:\D(\d+))?(-(?:TRIAL|RC)\d+)?$/){$dev=1 if (($1 > 6 and $1 & 1)or ($2 and $2 >= 50))or $3}elsif ($version =~ /\d\D\d+_\d/ or $version =~ /-TRIAL/){$dev=1}}else {$version=undef}($dist,$version,$dev)}sub new {my$class=shift;my$distfile=shift;$distfile =~ s,//+,/,g;my%info=(pathname=>$distfile);($info{filename}=$distfile)=~ s,^(((.*?/)?authors/)?id/)?([A-Z])/(\4[A-Z])/(\5[-A-Z0-9]*)/,, and $info{cpanid}=$6;if ($distfile =~ m,([^/]+)\.(tar\.(?:g?z|bz2)|zip|tgz)$,i){$info{distvname}=$1;$info{extension}=$2}@info{qw(dist version beta)}=distname_info($info{distvname});$info{maturity}=delete$info{beta}? 'developer' : 'released';return bless \%info,$class}sub dist {shift->{dist}}sub version {shift->{version}}sub maturity {shift->{maturity}}sub filename {shift->{filename}}sub cpanid {shift->{cpanid}}sub distvname {shift->{distvname}}sub extension {shift->{extension}}sub pathname {shift->{pathname}}sub properties {%{$_[0]}}1; CPAN_DISTNAMEINFO $fatpacked{"CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META'; use 5.006;use strict;use warnings;package CPAN::Meta;our$VERSION='2.150005';use Carp qw(carp croak);use CPAN::Meta::Feature;use CPAN::Meta::Prereqs;use CPAN::Meta::Converter;use CPAN::Meta::Validator;use Parse::CPAN::Meta 1.4414 ();BEGIN {*_dclone=\&CPAN::Meta::Converter::_dclone}BEGIN {my@STRING_READERS=qw(abstract description dynamic_config generated_by name release_status version);no strict 'refs';for my$attr (@STRING_READERS){*$attr=sub {$_[0]{$attr }}}}BEGIN {my@LIST_READERS=qw(author keywords license);no strict 'refs';for my$attr (@LIST_READERS){*$attr=sub {my$value=$_[0]{$attr };croak "$attr must be called in list context" unless wantarray;return @{_dclone($value)}if ref$value;return$value}}}sub authors {$_[0]->author}sub licenses {$_[0]->license}BEGIN {my@MAP_READERS=qw(meta-spec resources provides no_index prereqs optional_features);no strict 'refs';for my$attr (@MAP_READERS){(my$subname=$attr)=~ s/-/_/;*$subname=sub {my$value=$_[0]{$attr };return _dclone($value)if$value;return {}}}}sub custom_keys {return grep {/^x_/i}keys %{$_[0]}}sub custom {my ($self,$attr)=@_;my$value=$self->{$attr};return _dclone($value)if ref$value;return$value}sub _new {my ($class,$struct,$options)=@_;my$self;if ($options->{lazy_validation}){my$cmc=CPAN::Meta::Converter->new($struct);$self=$cmc->convert(version=>2);return bless$self,$class}else {my$cmv=CPAN::Meta::Validator->new($struct);unless ($cmv->is_valid){die "Invalid metadata structure. Errors: " .join(", ",$cmv->errors)."\n"}}my$version=$struct->{'meta-spec'}{version}|| '1.0';if ($version==2){$self=$struct}else {my$cmc=CPAN::Meta::Converter->new($struct);$self=$cmc->convert(version=>2)}return bless$self,$class}sub new {my ($class,$struct,$options)=@_;my$self=eval {$class->_new($struct,$options)};croak($@)if $@;return$self}sub create {my ($class,$struct,$options)=@_;my$version=__PACKAGE__->VERSION || 2;$struct->{generated_by}||= __PACKAGE__ ." version $version" ;$struct->{'meta-spec'}{version}||= int($version);my$self=eval {$class->_new($struct,$options)};croak ($@)if $@;return$self}sub load_file {my ($class,$file,$options)=@_;$options->{lazy_validation}=1 unless exists$options->{lazy_validation};croak "load_file() requires a valid, readable filename" unless -r $file;my$self;eval {my$struct=Parse::CPAN::Meta->load_file($file);$self=$class->_new($struct,$options)};croak($@)if $@;return$self}sub load_yaml_string {my ($class,$yaml,$options)=@_;$options->{lazy_validation}=1 unless exists$options->{lazy_validation};my$self;eval {my ($struct)=Parse::CPAN::Meta->load_yaml_string($yaml);$self=$class->_new($struct,$options)};croak($@)if $@;return$self}sub load_json_string {my ($class,$json,$options)=@_;$options->{lazy_validation}=1 unless exists$options->{lazy_validation};my$self;eval {my$struct=Parse::CPAN::Meta->load_json_string($json);$self=$class->_new($struct,$options)};croak($@)if $@;return$self}sub load_string {my ($class,$string,$options)=@_;$options->{lazy_validation}=1 unless exists$options->{lazy_validation};my$self;eval {my$struct=Parse::CPAN::Meta->load_string($string);$self=$class->_new($struct,$options)};croak($@)if $@;return$self}sub save {my ($self,$file,$options)=@_;my$version=$options->{version}|| '2';my$layer=$] ge '5.008001' ? ':utf8' : '';if ($version ge '2'){carp "'$file' should end in '.json'" unless$file =~ m{\.json$}}else {carp "'$file' should end in '.yml'" unless$file =~ m{\.yml$}}my$data=$self->as_string($options);open my$fh,">$layer",$file or die "Error opening '$file' for writing: $!\n";print {$fh}$data;close$fh or die "Error closing '$file': $!\n";return 1}sub meta_spec_version {my ($self)=@_;return$self->meta_spec->{version}}sub effective_prereqs {my ($self,$features)=@_;$features ||= [];my$prereq=CPAN::Meta::Prereqs->new($self->prereqs);return$prereq unless @$features;my@other=map {;$self->feature($_)->prereqs}@$features;return$prereq->with_merged_prereqs(\@other)}sub should_index_file {my ($self,$filename)=@_;for my$no_index_file (@{$self->no_index->{file}|| []}){return if$filename eq $no_index_file}for my$no_index_dir (@{$self->no_index->{directory}}){$no_index_dir =~ s{$}{/} unless$no_index_dir =~ m{/\z};return if index($filename,$no_index_dir)==0}return 1}sub should_index_package {my ($self,$package)=@_;for my$no_index_pkg (@{$self->no_index->{package}|| []}){return if$package eq $no_index_pkg}for my$no_index_ns (@{$self->no_index->{namespace}}){return if index($package,"${no_index_ns}::")==0}return 1}sub features {my ($self)=@_;my$opt_f=$self->optional_features;my@features=map {;CPAN::Meta::Feature->new($_=>$opt_f->{$_ })}keys %$opt_f;return@features}sub feature {my ($self,$ident)=@_;croak "no feature named $ident" unless my$f=$self->optional_features->{$ident };return CPAN::Meta::Feature->new($ident,$f)}sub as_struct {my ($self,$options)=@_;my$struct=_dclone($self);if ($options->{version}){my$cmc=CPAN::Meta::Converter->new($struct);$struct=$cmc->convert(version=>$options->{version})}return$struct}sub as_string {my ($self,$options)=@_;my$version=$options->{version}|| '2';my$struct;if ($self->meta_spec_version ne $version){my$cmc=CPAN::Meta::Converter->new($self->as_struct);$struct=$cmc->convert(version=>$version)}else {$struct=$self->as_struct}my ($data,$backend);if ($version ge '2'){$backend=Parse::CPAN::Meta->json_backend();local$struct->{x_serialization_backend}=sprintf '%s version %s',$backend,$backend->VERSION;$data=$backend->new->pretty->canonical->encode($struct)}else {$backend=Parse::CPAN::Meta->yaml_backend();local$struct->{x_serialization_backend}=sprintf '%s version %s',$backend,$backend->VERSION;$data=eval {no strict 'refs';&{"$backend\::Dump"}($struct)};if ($@){croak$backend->can('errstr')? $backend->errstr : $@}}return$data}sub TO_JSON {return {%{$_[0]}}}1; CPAN_META $fatpacked{"CPAN/Meta/Check.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_CHECK'; package CPAN::Meta::Check;$CPAN::Meta::Check::VERSION='0.018';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)=@_;return$reqs->accepts_module($module,$])? (): sprintf "Your Perl (%s) is not in the range '%s'",$],$reqs->requirements_for_module($module)if$module eq 'perl';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; CPAN_META_CHECK $fatpacked{"CPAN/Meta/Converter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_CONVERTER'; use 5.006;use strict;use warnings;package CPAN::Meta::Converter;our$VERSION='2.150005';use CPAN::Meta::Validator;use CPAN::Meta::Requirements;use Parse::CPAN::Meta 1.4400 ();BEGIN {eval "use version ()";if (my$err=$@){eval "use ExtUtils::MakeMaker::version" or die$err}}*_is_qv=version->can('is_qv')? sub {$_[0]->is_qv}: sub {exists $_[0]->{qv}};sub _dclone {my$ref=shift;no warnings 'once';no warnings 'redefine';local*UNIVERSAL::TO_JSON=sub {"$_[0]"};my$json=Parse::CPAN::Meta->json_backend()->new ->utf8 ->allow_blessed ->convert_blessed;$json->decode($json->encode($ref))}my%known_specs=('2'=>'http://search.cpan.org/perldoc?CPAN::Meta::Spec','1.4'=>'http://module-build.sourceforge.net/META-spec-v1.4.html','1.3'=>'http://module-build.sourceforge.net/META-spec-v1.3.html','1.2'=>'http://module-build.sourceforge.net/META-spec-v1.2.html','1.1'=>'http://module-build.sourceforge.net/META-spec-v1.1.html','1.0'=>'http://module-build.sourceforge.net/META-spec-v1.0.html');my@spec_list=sort {$a <=> $b}keys%known_specs;my ($LOWEST,$HIGHEST)=@spec_list[0,-1];sub _keep {$_[0]}sub _keep_or_one {defined($_[0])? $_[0]: 1}sub _keep_or_zero {defined($_[0])? $_[0]: 0}sub _keep_or_unknown {defined($_[0])&& length($_[0])? $_[0]: "unknown"}sub _generated_by {my$gen=shift;my$sig=__PACKAGE__ ." version " .(__PACKAGE__->VERSION || "<dev>");return$sig unless defined$gen and length$gen;return$gen if$gen =~ /\Q$sig/;return "$gen, $sig"}sub _listify {!defined $_[0]? undef : ref $_[0]eq 'ARRAY' ? $_[0]: [$_[0]]}sub _prefix_custom {my$key=shift;$key =~ s/^(?!x_) # Unless it already starts with x_ (?:x-?)? # Remove leading x- or x (if present) /x_/ix;return$key}sub _ucfirst_custom {my$key=shift;$key=ucfirst$key unless$key =~ /[A-Z]/;return$key}sub _no_prefix_ucfirst_custom {my$key=shift;$key =~ s/^x_//;return _ucfirst_custom($key)}sub _change_meta_spec {my ($element,undef,undef,$version)=@_;return {version=>$version,url=>$known_specs{$version},}}my@open_source=('perl','gpl','apache','artistic','artistic_2','lgpl','bsd','gpl','mit','mozilla','open_source',);my%is_open_source=map {;$_=>1}@open_source;my@valid_licenses_1=(@open_source,'unrestricted','restrictive','unknown',);my%license_map_1=((map {$_=>$_}@valid_licenses_1),artistic2=>'artistic_2',);sub _license_1 {my ($element)=@_;return 'unknown' unless defined$element;if ($license_map_1{lc$element}){return$license_map_1{lc$element}}else {return 'unknown'}}my@valid_licenses_2=qw(agpl_3 apache_1_1 apache_2_0 artistic_1 artistic_2 bsd freebsd gfdl_1_2 gfdl_1_3 gpl_1 gpl_2 gpl_3 lgpl_2_1 lgpl_3_0 mit mozilla_1_0 mozilla_1_1 openssl perl_5 qpl_1_0 ssleay sun zlib open_source restricted unrestricted unknown);my%license_map_2=((map {$_=>$_}@valid_licenses_2),apache=>'apache_2_0',artistic=>'artistic_1',artistic2=>'artistic_2',gpl=>'open_source',lgpl=>'open_source',mozilla=>'open_source',perl=>'perl_5',restrictive=>'restricted',);sub _license_2 {my ($element)=@_;return ['unknown' ]unless defined$element;$element=[$element ]unless ref$element eq 'ARRAY';my@new_list;for my$lic (@$element){next unless defined$lic;if (my$new=$license_map_2{lc$lic}){push@new_list,$new}}return@new_list ? \@new_list : ['unknown' ]}my%license_downgrade_map=qw(agpl_3 open_source apache_1_1 apache apache_2_0 apache artistic_1 artistic artistic_2 artistic_2 bsd bsd freebsd open_source gfdl_1_2 open_source gfdl_1_3 open_source gpl_1 gpl gpl_2 gpl gpl_3 gpl lgpl_2_1 lgpl lgpl_3_0 lgpl mit mit mozilla_1_0 mozilla mozilla_1_1 mozilla openssl open_source perl_5 perl qpl_1_0 open_source ssleay open_source sun open_source zlib open_source open_source open_source restricted restrictive unrestricted unrestricted unknown unknown);sub _downgrade_license {my ($element)=@_;if (!defined$element){return "unknown"}elsif(ref$element eq 'ARRAY'){if (@$element > 1){if (grep {!$is_open_source{$license_downgrade_map{lc $_}|| 'unknown' }}@$element){return 'unknown'}else {return 'open_source'}}elsif (@$element==1){return$license_downgrade_map{lc$element->[0]}|| "unknown"}}elsif (!ref$element){return$license_downgrade_map{lc$element}|| "unknown"}return "unknown"}my$no_index_spec_1_2={'file'=>\&_listify,'dir'=>\&_listify,'package'=>\&_listify,'namespace'=>\&_listify,};my$no_index_spec_1_3={'file'=>\&_listify,'directory'=>\&_listify,'package'=>\&_listify,'namespace'=>\&_listify,};my$no_index_spec_2={'file'=>\&_listify,'directory'=>\&_listify,'package'=>\&_listify,'namespace'=>\&_listify,':custom'=>\&_prefix_custom,};sub _no_index_1_2 {my (undef,undef,$meta)=@_;my$no_index=$meta->{no_index}|| $meta->{private};return unless$no_index;if (!ref$no_index){my$item=$no_index;$no_index={dir=>[$item ],file=>[$item ]}}elsif (ref$no_index eq 'ARRAY'){my$list=$no_index;$no_index={dir=>[@$list ],file=>[@$list ]}}if (exists$no_index->{files}){$no_index->{file}=delete$no_index->{files}}if (exists$no_index->{modules}){$no_index->{module}=delete$no_index->{modules}}return _convert($no_index,$no_index_spec_1_2)}sub _no_index_directory {my ($element,$key,$meta,$version)=@_;return unless$element;if (!ref$element){my$item=$element;$element={directory=>[$item ],file=>[$item ]}}elsif (ref$element eq 'ARRAY'){my$list=$element;$element={directory=>[@$list ],file=>[@$list ]}}if (exists$element->{dir}){$element->{directory}=delete$element->{dir}}if (exists$element->{files}){$element->{file}=delete$element->{files}}if (exists$element->{modules}){$element->{module}=delete$element->{modules}}my$spec=$version==2 ? $no_index_spec_2 : $no_index_spec_1_3;return _convert($element,$spec)}sub _is_module_name {my$mod=shift;return unless defined$mod && length$mod;return$mod =~ m{^[A-Za-z][A-Za-z0-9_]*(?:::[A-Za-z0-9_]+)*$}}sub _clean_version {my ($element)=@_;return 0 if!defined$element;$element =~ s{^\s*}{};$element =~ s{\s*$}{};$element =~ s{^\.}{0.};return 0 if!length$element;return 0 if ($element eq 'undef' || $element eq '<undef>');my$v=eval {version->new($element)};if (defined$v){return _is_qv($v)? $v->normal : $element}else {return 0}}sub _bad_version_hook {my ($v)=@_;$v =~ s{^\s*}{};$v =~ s{\s*$}{};$v =~ s{[a-z]+$}{};my$vobj=eval {version->new($v)};return defined($vobj)? $vobj : version->new(0)}sub _version_map {my ($element)=@_;return unless defined$element;if (ref$element eq 'HASH'){my$new_map=CPAN::Meta::Requirements->new({bad_version_hook=>\&_bad_version_hook });while (my ($k,$v)=each %$element){next unless _is_module_name($k);if (!defined($v)||!length($v)|| $v eq 'undef' || $v eq '<undef>'){$v=0}if (_is_module_name($v)&&!version::is_lax($v)){$new_map->add_minimum($k=>0);$new_map->add_minimum($v=>0)}$new_map->add_string_requirement($k=>$v)}return$new_map->as_string_hash}elsif (ref$element eq 'ARRAY'){my$hashref={map {$_=>0}@$element };return _version_map($hashref)}elsif (ref$element eq '' && length$element){return {$element=>0 }}return}sub _prereqs_from_1 {my (undef,undef,$meta)=@_;my$prereqs={};for my$phase (qw/build configure/){my$key="${phase}_requires";$prereqs->{$phase}{requires}=_version_map($meta->{$key})if$meta->{$key}}for my$rel (qw/requires recommends conflicts/){$prereqs->{runtime}{$rel}=_version_map($meta->{$rel})if$meta->{$rel}}return$prereqs}my$prereqs_spec={configure=>\&_prereqs_rel,build=>\&_prereqs_rel,test=>\&_prereqs_rel,runtime=>\&_prereqs_rel,develop=>\&_prereqs_rel,':custom'=>\&_prefix_custom,};my$relation_spec={requires=>\&_version_map,recommends=>\&_version_map,suggests=>\&_version_map,conflicts=>\&_version_map,':custom'=>\&_prefix_custom,};sub _cleanup_prereqs {my ($prereqs,$key,$meta,$to_version)=@_;return unless$prereqs && ref$prereqs eq 'HASH';return _convert($prereqs,$prereqs_spec,$to_version)}sub _prereqs_rel {my ($relation,$key,$meta,$to_version)=@_;return unless$relation && ref$relation eq 'HASH';return _convert($relation,$relation_spec,$to_version)}BEGIN {my@old_prereqs=qw(requires configure_requires recommends conflicts);for (@old_prereqs){my$sub="_get_$_";my ($phase,$type)=split qr/_/,$_;if (!defined$type){$type=$phase;$phase='runtime'}no strict 'refs';*{$sub}=sub {_extract_prereqs($_[2]->{prereqs},$phase,$type)}}}sub _get_build_requires {my ($data,$key,$meta)=@_;my$test_h=_extract_prereqs($_[2]->{prereqs},qw(test requires))|| {};my$build_h=_extract_prereqs($_[2]->{prereqs},qw(build requires))|| {};my$test_req=CPAN::Meta::Requirements->from_string_hash($test_h);my$build_req=CPAN::Meta::Requirements->from_string_hash($build_h);$test_req->add_requirements($build_req)->as_string_hash}sub _extract_prereqs {my ($prereqs,$phase,$type)=@_;return unless ref$prereqs eq 'HASH';return scalar _version_map($prereqs->{$phase}{$type})}sub _downgrade_optional_features {my (undef,undef,$meta)=@_;return unless exists$meta->{optional_features};my$origin=$meta->{optional_features};my$features={};for my$name (keys %$origin){$features->{$name}={description=>$origin->{$name}{description},requires=>_extract_prereqs($origin->{$name}{prereqs},'runtime','requires'),configure_requires=>_extract_prereqs($origin->{$name}{prereqs},'runtime','configure_requires'),build_requires=>_extract_prereqs($origin->{$name}{prereqs},'runtime','build_requires'),recommends=>_extract_prereqs($origin->{$name}{prereqs},'runtime','recommends'),conflicts=>_extract_prereqs($origin->{$name}{prereqs},'runtime','conflicts'),};for my$k (keys %{$features->{$name}}){delete$features->{$name}{$k}unless defined$features->{$name}{$k}}}return$features}sub _upgrade_optional_features {my (undef,undef,$meta)=@_;return unless exists$meta->{optional_features};my$origin=$meta->{optional_features};my$features={};for my$name (keys %$origin){$features->{$name}={description=>$origin->{$name}{description},prereqs=>_prereqs_from_1(undef,undef,$origin->{$name}),};delete$features->{$name}{prereqs}{configure}}return$features}my$optional_features_2_spec={description=>\&_keep,prereqs=>\&_cleanup_prereqs,':custom'=>\&_prefix_custom,};sub _feature_2 {my ($element,$key,$meta,$to_version)=@_;return unless$element && ref$element eq 'HASH';_convert($element,$optional_features_2_spec,$to_version)}sub _cleanup_optional_features_2 {my ($element,$key,$meta,$to_version)=@_;return unless$element && ref$element eq 'HASH';my$new_data={};for my$k (keys %$element){$new_data->{$k}=_feature_2($element->{$k},$k,$meta,$to_version)}return unless keys %$new_data;return$new_data}sub _optional_features_1_4 {my ($element)=@_;return unless$element;$element=_optional_features_as_map($element);for my$name (keys %$element){for my$drop (qw/requires_packages requires_os excluded_os/){delete$element->{$name}{$drop}}}return$element}sub _optional_features_as_map {my ($element)=@_;return unless$element;if (ref$element eq 'ARRAY'){my%map;for my$feature (@$element){my (@parts)=%$feature;$map{$parts[0]}=$parts[1]}$element=\%map}return$element}sub _is_urlish {defined $_[0]&& $_[0]=~ m{\A[-+.a-z0-9]+:.+}i}sub _url_or_drop {my ($element)=@_;return$element if _is_urlish($element);return}sub _url_list {my ($element)=@_;return unless$element;$element=_listify($element);$element=[grep {_is_urlish($_)}@$element ];return unless @$element;return$element}sub _author_list {my ($element)=@_;return ['unknown' ]unless$element;$element=_listify($element);$element=[map {defined $_ && length $_ ? $_ : 'unknown'}@$element ];return ['unknown' ]unless @$element;return$element}my$resource2_upgrade={license=>sub {return _is_urlish($_[0])? _listify($_[0]): undef},homepage=>\&_url_or_drop,bugtracker=>sub {my ($item)=@_;return unless$item;if ($item =~ m{^mailto:(.*)$}){return {mailto=>$1 }}elsif(_is_urlish($item)){return {web=>$item }}else {return}},repository=>sub {return _is_urlish($_[0])? {url=>$_[0]}: undef},':custom'=>\&_prefix_custom,};sub _upgrade_resources_2 {my (undef,undef,$meta,$version)=@_;return unless exists$meta->{resources};return _convert($meta->{resources},$resource2_upgrade)}my$bugtracker2_spec={web=>\&_url_or_drop,mailto=>\&_keep,':custom'=>\&_prefix_custom,};sub _repo_type {my ($element,$key,$meta,$to_version)=@_;return$element if defined$element;return unless exists$meta->{url};my$repo_url=$meta->{url};for my$type (qw/git svn/){return$type if$repo_url =~ m{\A$type}}return}my$repository2_spec={web=>\&_url_or_drop,url=>\&_url_or_drop,type=>\&_repo_type,':custom'=>\&_prefix_custom,};my$resources2_cleanup={license=>\&_url_list,homepage=>\&_url_or_drop,bugtracker=>sub {ref $_[0]? _convert($_[0],$bugtracker2_spec): undef},repository=>sub {my$data=shift;ref$data ? _convert($data,$repository2_spec): undef},':custom'=>\&_prefix_custom,};sub _cleanup_resources_2 {my ($resources,$key,$meta,$to_version)=@_;return unless$resources && ref$resources eq 'HASH';return _convert($resources,$resources2_cleanup,$to_version)}my$resource1_spec={license=>\&_url_or_drop,homepage=>\&_url_or_drop,bugtracker=>\&_url_or_drop,repository=>\&_url_or_drop,':custom'=>\&_keep,};sub _resources_1_3 {my (undef,undef,$meta,$version)=@_;return unless exists$meta->{resources};return _convert($meta->{resources},$resource1_spec)}*_resources_1_4=*_resources_1_3;sub _resources_1_2 {my (undef,undef,$meta)=@_;my$resources=$meta->{resources}|| {};if ($meta->{license_url}&&!$resources->{license}){$resources->{license}=$meta->{license_url}if _is_urlish($meta->{license_url})}return unless keys %$resources;return _convert($resources,$resource1_spec)}my$resource_downgrade_spec={license=>sub {return ref $_[0]? $_[0]->[0]: $_[0]},homepage=>\&_url_or_drop,bugtracker=>sub {return $_[0]->{web}},repository=>sub {return $_[0]->{url}|| $_[0]->{web}},':custom'=>\&_no_prefix_ucfirst_custom,};sub _downgrade_resources {my (undef,undef,$meta,$version)=@_;return unless exists$meta->{resources};return _convert($meta->{resources},$resource_downgrade_spec)}sub _release_status {my ($element,undef,$meta)=@_;return$element if$element && $element =~ m{\A(?:stable|testing|unstable)\z};return _release_status_from_version(undef,undef,$meta)}sub _release_status_from_version {my (undef,undef,$meta)=@_;my$version=$meta->{version}|| '';return ($version =~ /_/)? 'testing' : 'stable'}my$provides_spec={file=>\&_keep,version=>\&_keep,};my$provides_spec_2={file=>\&_keep,version=>\&_keep,':custom'=>\&_prefix_custom,};sub _provides {my ($element,$key,$meta,$to_version)=@_;return unless defined$element && ref$element eq 'HASH';my$spec=$to_version==2 ? $provides_spec_2 : $provides_spec;my$new_data={};for my$k (keys %$element){$new_data->{$k}=_convert($element->{$k},$spec,$to_version);$new_data->{$k}{version}=_clean_version($element->{$k}{version})if exists$element->{$k}{version}}return$new_data}sub _convert {my ($data,$spec,$to_version,$is_fragment)=@_;my$new_data={};for my$key (keys %$spec){next if$key eq ':custom' || $key eq ':drop';next unless my$fcn=$spec->{$key};if ($is_fragment && $key eq 'generated_by'){$fcn=\&_keep}die "spec for '$key' is not a coderef" unless ref$fcn && ref$fcn eq 'CODE';my$new_value=$fcn->($data->{$key},$key,$data,$to_version);$new_data->{$key}=$new_value if defined$new_value}my$drop_list=$spec->{':drop'};my$customizer=$spec->{':custom'}|| \&_keep;for my$key (keys %$data){next if$drop_list && grep {$key eq $_}@$drop_list;next if exists$spec->{$key};$new_data->{$customizer->($key)}=$data->{$key}}return$new_data}my%up_convert=('2-from-1.4'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_2,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'release_status'=>\&_release_status,'keywords'=>\&_keep,'no_index'=>\&_no_index_directory,'optional_features'=>\&_upgrade_optional_features,'provides'=>\&_provides,'resources'=>\&_upgrade_resources_2,'description'=>\&_keep,'prereqs'=>\&_prereqs_from_1,':drop'=>[qw(build_requires configure_requires conflicts distribution_type license_url private recommends requires) ],':custom'=>\&_prefix_custom,},'1.4-from-1.3'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'keywords'=>\&_keep,'no_index'=>\&_no_index_directory,'optional_features'=>\&_optional_features_1_4,'provides'=>\&_provides,'recommends'=>\&_version_map,'requires'=>\&_version_map,'resources'=>\&_resources_1_4,'configure_requires'=>\&_keep,':drop'=>[qw(license_url private)],':custom'=>\&_keep },'1.3-from-1.2'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'keywords'=>\&_keep,'no_index'=>\&_no_index_directory,'optional_features'=>\&_optional_features_as_map,'provides'=>\&_provides,'recommends'=>\&_version_map,'requires'=>\&_version_map,'resources'=>\&_resources_1_3,':drop'=>[qw(license_url private)],':custom'=>\&_keep },'1.2-from-1.1'=>{'version'=>\&_keep,'license'=>\&_license_1,'name'=>\&_keep,'generated_by'=>\&_generated_by,'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'meta-spec'=>\&_change_meta_spec,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'recommends'=>\&_version_map,'requires'=>\&_version_map,'keywords'=>\&_keep,'no_index'=>\&_no_index_1_2,'optional_features'=>\&_optional_features_as_map,'provides'=>\&_provides,'resources'=>\&_resources_1_2,':drop'=>[qw(license_url private)],':custom'=>\&_keep },'1.1-from-1.0'=>{'version'=>\&_keep,'name'=>\&_keep,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'recommends'=>\&_version_map,'requires'=>\&_version_map,'license_url'=>\&_url_or_drop,'private'=>\&_keep,':custom'=>\&_keep },);my%down_convert=('1.4-from-2'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_downgrade_license,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'build_requires'=>\&_get_build_requires,'configure_requires'=>\&_get_configure_requires,'conflicts'=>\&_get_conflicts,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'keywords'=>\&_keep,'no_index'=>\&_no_index_directory,'optional_features'=>\&_downgrade_optional_features,'provides'=>\&_provides,'recommends'=>\&_get_recommends,'requires'=>\&_get_requires,'resources'=>\&_downgrade_resources,':drop'=>[qw(description prereqs release_status)],':custom'=>\&_keep },'1.3-from-1.4'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'keywords'=>\&_keep,'no_index'=>\&_no_index_directory,'optional_features'=>\&_optional_features_as_map,'provides'=>\&_provides,'recommends'=>\&_version_map,'requires'=>\&_version_map,'resources'=>\&_resources_1_3,':drop'=>[qw(configure_requires)],':custom'=>\&_keep,},'1.2-from-1.3'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'keywords'=>\&_keep,'no_index'=>\&_no_index_1_2,'optional_features'=>\&_optional_features_as_map,'provides'=>\&_provides,'recommends'=>\&_version_map,'requires'=>\&_version_map,'resources'=>\&_resources_1_3,':custom'=>\&_keep,},'1.1-from-1.2'=>{'version'=>\&_keep,'name'=>\&_keep,'meta-spec'=>\&_change_meta_spec,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'private'=>\&_keep,'recommends'=>\&_version_map,'requires'=>\&_version_map,':drop'=>[qw(abstract author provides no_index keywords resources)],':custom'=>\&_keep,},'1.0-from-1.1'=>{'name'=>\&_keep,'meta-spec'=>\&_change_meta_spec,'version'=>\&_keep,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'recommends'=>\&_version_map,'requires'=>\&_version_map,':custom'=>\&_keep,},);my%cleanup=('2'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_2,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'release_status'=>\&_release_status,'keywords'=>\&_keep,'no_index'=>\&_no_index_directory,'optional_features'=>\&_cleanup_optional_features_2,'provides'=>\&_provides,'resources'=>\&_cleanup_resources_2,'description'=>\&_keep,'prereqs'=>\&_cleanup_prereqs,':drop'=>[qw(build_requires configure_requires conflicts distribution_type license_url private recommends requires) ],':custom'=>\&_prefix_custom,},'1.4'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'keywords'=>\&_keep,'no_index'=>\&_no_index_directory,'optional_features'=>\&_optional_features_1_4,'provides'=>\&_provides,'recommends'=>\&_version_map,'requires'=>\&_version_map,'resources'=>\&_resources_1_4,'configure_requires'=>\&_keep,':custom'=>\&_keep },'1.3'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'keywords'=>\&_keep,'no_index'=>\&_no_index_directory,'optional_features'=>\&_optional_features_as_map,'provides'=>\&_provides,'recommends'=>\&_version_map,'requires'=>\&_version_map,'resources'=>\&_resources_1_3,':custom'=>\&_keep },'1.2'=>{'version'=>\&_keep,'license'=>\&_license_1,'name'=>\&_keep,'generated_by'=>\&_generated_by,'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'meta-spec'=>\&_change_meta_spec,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'recommends'=>\&_version_map,'requires'=>\&_version_map,'keywords'=>\&_keep,'no_index'=>\&_no_index_1_2,'optional_features'=>\&_optional_features_as_map,'provides'=>\&_provides,'resources'=>\&_resources_1_2,':custom'=>\&_keep },'1.1'=>{'version'=>\&_keep,'name'=>\&_keep,'meta-spec'=>\&_change_meta_spec,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'recommends'=>\&_version_map,'requires'=>\&_version_map,'license_url'=>\&_url_or_drop,'private'=>\&_keep,':custom'=>\&_keep },'1.0'=>{'name'=>\&_keep,'meta-spec'=>\&_change_meta_spec,'version'=>\&_keep,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'recommends'=>\&_version_map,'requires'=>\&_version_map,':custom'=>\&_keep,},);my%fragments_generate=('2'=>{'abstract'=>'abstract','author'=>'author','generated_by'=>'generated_by','license'=>'license','name'=>'name','version'=>'version','dynamic_config'=>'dynamic_config','release_status'=>'release_status','keywords'=>'keywords','no_index'=>'no_index','optional_features'=>'optional_features','provides'=>'provides','resources'=>'resources','description'=>'description','prereqs'=>'prereqs',},'1.4'=>{'abstract'=>'abstract','author'=>'author','generated_by'=>'generated_by','license'=>'license','name'=>'name','version'=>'version','build_requires'=>'prereqs','conflicts'=>'prereqs','distribution_type'=>'distribution_type','dynamic_config'=>'dynamic_config','keywords'=>'keywords','no_index'=>'no_index','optional_features'=>'optional_features','provides'=>'provides','recommends'=>'prereqs','requires'=>'prereqs','resources'=>'resources','configure_requires'=>'prereqs',},);$fragments_generate{$_}=$fragments_generate{'1.4'}for qw/1.3 1.2 1.1 1.0/;sub new {my ($class,$data,%args)=@_;my$self={'data'=>$data,'spec'=>_extract_spec_version($data,$args{default_version}),};return bless$self,$class}sub _extract_spec_version {my ($data,$default)=@_;my$spec=$data->{'meta-spec'};return($default || "1.0")unless defined$spec && ref$spec eq 'HASH';my$v=$spec->{version};if (defined$v && $v =~ /^\d+(?:\.\d+)?$/){return$v if defined$v && grep {$v eq $_}keys%known_specs;return$v+0 if defined$v && grep {$v==$_}keys%known_specs}return "2" if exists$data->{prereqs};return "1.4" if exists$data->{configure_requires};return($default || "1.2")}sub convert {my ($self,%args)=@_;my$args={%args };my$new_version=$args->{version}|| $HIGHEST;my$is_fragment=$args->{is_fragment};my ($old_version)=$self->{spec};my$converted=_dclone($self->{data});if ($old_version==$new_version){$converted=_convert($converted,$cleanup{$old_version},$old_version,$is_fragment);unless ($args->{is_fragment}){my$cmv=CPAN::Meta::Validator->new($converted);unless ($cmv->is_valid){my$errs=join("\n",$cmv->errors);die "Failed to clean-up $old_version metadata. Errors:\n$errs\n"}}return$converted}elsif ($old_version > $new_version){my@vers=sort {$b <=> $a}keys%known_specs;for my$i (0 .. $#vers-1){next if$vers[$i]> $old_version;last if$vers[$i+1]< $new_version;my$spec_string="$vers[$i+1]-from-$vers[$i]";$converted=_convert($converted,$down_convert{$spec_string},$vers[$i+1],$is_fragment);unless ($args->{is_fragment}){my$cmv=CPAN::Meta::Validator->new($converted);unless ($cmv->is_valid){my$errs=join("\n",$cmv->errors);die "Failed to downconvert metadata to $vers[$i+1]. Errors:\n$errs\n"}}}return$converted}else {my@vers=sort {$a <=> $b}keys%known_specs;for my$i (0 .. $#vers-1){next if$vers[$i]< $old_version;last if$vers[$i+1]> $new_version;my$spec_string="$vers[$i+1]-from-$vers[$i]";$converted=_convert($converted,$up_convert{$spec_string},$vers[$i+1],$is_fragment);unless ($args->{is_fragment}){my$cmv=CPAN::Meta::Validator->new($converted);unless ($cmv->is_valid){my$errs=join("\n",$cmv->errors);die "Failed to upconvert metadata to $vers[$i+1]. Errors:\n$errs\n"}}}return$converted}}sub upgrade_fragment {my ($self)=@_;my ($old_version)=$self->{spec};my%expected=map {;$_=>1}grep {defined}map {$fragments_generate{$old_version}{$_}}keys %{$self->{data}};my$converted=$self->convert(version=>$HIGHEST,is_fragment=>1);for my$key (keys %$converted){next if$key =~ /^x_/i || $key eq 'meta-spec';delete$converted->{$key}unless$expected{$key}}return$converted}1; 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;sub new {my ($class,$identifier,$spec)=@_;my%guts=(identifier=>$identifier,description=>$spec->{description},prereqs=>CPAN::Meta::Prereqs->new($spec->{prereqs}),);bless \%guts=>$class}sub identifier {$_[0]{identifier}}sub description {$_[0]{description}}sub prereqs {$_[0]{prereqs}}1; CPAN_META_FEATURE $fatpacked{"CPAN/Meta/History.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_HISTORY'; use 5.006;use strict;use warnings;package CPAN::Meta::History;our$VERSION='2.150005';1; 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)|| (defined$left and defined$right and $left eq $right)}sub _identical {my ($left,$right,$path)=@_;croak sprintf "Can't merge attribute %s: '%s' does not equal '%s'",join('.',@{$path}),$left,$right unless _is_identical($left,$right);return$left}sub _merge {my ($current,$next,$mergers,$path)=@_;for my$key (keys %{$next}){if (not exists$current->{$key}){$current->{$key}=$next->{$key}}elsif (my$merger=$mergers->{$key}){$current->{$key}=$merger->($current->{$key},$next->{$key},[@{$path},$key ])}elsif ($merger=$mergers->{':default'}){$current->{$key}=$merger->($current->{$key},$next->{$key},[@{$path},$key ])}else {croak sprintf "Can't merge unknown attribute '%s'",join '.',@{$path},$key}}return$current}sub _uniq {my%seen=();return grep {not $seen{$_}++}@_}sub _set_addition {my ($left,$right)=@_;return [+_uniq(@{$left},@{$right})]}sub _uniq_map {my ($left,$right,$path)=@_;for my$key (keys %{$right}){if (not exists$left->{$key}){$left->{$key}=$right->{$key}}elsif (_is_identical($left->{$key},$right->{$key})){1}elsif (ref$left->{$key}eq 'HASH' and ref$right->{$key}eq 'HASH'){$left->{$key}=_uniq_map($left->{$key},$right->{$key},[@{$path},$key ])}else {croak 'Duplication of element ' .join '.',@{$path},$key}}return$left}sub _improvize {my ($left,$right,$path)=@_;my ($name)=reverse @{$path};if ($name =~ /^x_/){if (ref($left)eq 'ARRAY'){return _set_addition($left,$right,$path)}elsif (ref($left)eq 'HASH'){return _uniq_map($left,$right,$path)}else {return _identical($left,$right,$path)}}croak sprintf "Can't merge '%s'",join '.',@{$path}}sub _optional_features {my ($left,$right,$path)=@_;for my$key (keys %{$right}){if (not exists$left->{$key}){$left->{$key}=$right->{$key}}else {for my$subkey (keys %{$right->{$key}}){next if$subkey eq 'prereqs';if (not exists$left->{$key}{$subkey}){$left->{$key}{$subkey}=$right->{$key}{$subkey}}else {Carp::croak "Cannot merge two optional_features named '$key' with different '$subkey' values" if do {no warnings 'uninitialized';$left->{$key}{$subkey}ne $right->{$key}{$subkey}}}}require CPAN::Meta::Prereqs;$left->{$key}{prereqs}=CPAN::Meta::Prereqs->new($left->{$key}{prereqs})->with_merged_prereqs(CPAN::Meta::Prereqs->new($right->{$key}{prereqs}))->as_string_hash}}return$left}my%default=(abstract=>\&_identical,author=>\&_set_addition,dynamic_config=>sub {my ($left,$right)=@_;return$left || $right},generated_by=>sub {my ($left,$right)=@_;return join ', ',_uniq(split(/, /,$left),split(/, /,$right))},license=>\&_set_addition,'meta-spec'=>{version=>\&_identical,url=>\&_identical },name=>\&_identical,release_status=>\&_identical,version=>\&_identical,description=>\&_identical,keywords=>\&_set_addition,no_index=>{map {($_=>\&_set_addition)}qw/file directory package namespace/ },optional_features=>\&_optional_features,prereqs=>sub {require CPAN::Meta::Prereqs;my ($left,$right)=map {CPAN::Meta::Prereqs->new($_)}@_[0,1];return$left->with_merged_prereqs($right)->as_string_hash},provides=>\&_uniq_map,resources=>{license=>\&_set_addition,homepage=>\&_identical,bugtracker=>\&_uniq_map,repository=>\&_uniq_map,':default'=>\&_improvize,},':default'=>\&_improvize,);sub new {my ($class,%arguments)=@_;croak 'default version required' if not exists$arguments{default_version};my%mapping=%default;my%extra=%{$arguments{extra_mappings}|| {}};for my$key (keys%extra){if (ref($mapping{$key})eq 'HASH'){$mapping{$key}={%{$mapping{$key}},%{$extra{$key}}}}else {$mapping{$key}=$extra{$key}}}return bless {default_version=>$arguments{default_version},mapping=>_coerce_mapping(\%mapping,[]),},$class}my%coderef_for=(set_addition=>\&_set_addition,uniq_map=>\&_uniq_map,identical=>\&_identical,improvize=>\&_improvize,);sub _coerce_mapping {my ($orig,$map_path)=@_;my%ret;for my$key (keys %{$orig}){my$value=$orig->{$key};if (ref($orig->{$key})eq 'CODE'){$ret{$key}=$value}elsif (ref($value)eq 'HASH'){my$mapping=_coerce_mapping($value,[@{$map_path},$key ]);$ret{$key}=sub {my ($left,$right,$path)=@_;return _merge($left,$right,$mapping,[@{$path}])}}elsif ($coderef_for{$value}){$ret{$key}=$coderef_for{$value}}else {croak "Don't know what to do with " .join '.',@{$map_path},$key}}return \%ret}sub merge {my ($self,@items)=@_;my$current={};for my$next (@items){if (blessed($next)&& $next->isa('CPAN::Meta')){$next=$next->as_struct}elsif (ref($next)eq 'HASH'){my$cmc=CPAN::Meta::Converter->new($next,default_version=>$self->{default_version});$next=$cmc->upgrade_fragment}else {croak "Don't know how to merge '$next'"}$current=_merge($current,$next,$self->{mapping},[])}return$current}1; CPAN_META_MERGE $fatpacked{"CPAN/Meta/Prereqs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_PREREQS'; use 5.006;use strict;use warnings;package CPAN::Meta::Prereqs;our$VERSION='2.150005';use Carp qw(confess);use Scalar::Util qw(blessed);use CPAN::Meta::Requirements 2.121;sub __legal_phases {qw(configure build test runtime develop)}sub __legal_types {qw(requires recommends suggests conflicts)}sub new {my ($class,$prereq_spec)=@_;$prereq_spec ||= {};my%is_legal_phase=map {;$_=>1}$class->__legal_phases;my%is_legal_type=map {;$_=>1}$class->__legal_types;my%guts;PHASE: for my$phase (keys %$prereq_spec){next PHASE unless$phase =~ /\Ax_/i or $is_legal_phase{$phase};my$phase_spec=$prereq_spec->{$phase };next PHASE unless keys %$phase_spec;TYPE: for my$type (keys %$phase_spec){next TYPE unless$type =~ /\Ax_/i or $is_legal_type{$type};my$spec=$phase_spec->{$type };next TYPE unless keys %$spec;$guts{prereqs}{$phase}{$type}=CPAN::Meta::Requirements->from_string_hash($spec)}}return bless \%guts=>$class}sub requirements_for {my ($self,$phase,$type)=@_;confess "requirements_for called without phase" unless defined$phase;confess "requirements_for called without type" unless defined$type;unless ($phase =~ /\Ax_/i or grep {$phase eq $_}$self->__legal_phases){confess "requested requirements for unknown phase: $phase"}unless ($type =~ /\Ax_/i or grep {$type eq $_}$self->__legal_types){confess "requested requirements for unknown type: $type"}my$req=($self->{prereqs}{$phase}{$type}||= CPAN::Meta::Requirements->new);$req->finalize if$self->is_finalized;return$req}sub with_merged_prereqs {my ($self,$other)=@_;my@other=blessed($other)? $other : @$other;my@prereq_objs=($self,@other);my%new_arg;for my$phase ($self->__legal_phases){for my$type ($self->__legal_types){my$req=CPAN::Meta::Requirements->new;for my$prereq (@prereq_objs){my$this_req=$prereq->requirements_for($phase,$type);next unless$this_req->required_modules;$req->add_requirements($this_req)}next unless$req->required_modules;$new_arg{$phase }{$type }=$req->as_string_hash}}return (ref$self)->new(\%new_arg)}sub merged_requirements {my ($self,$phases,$types)=@_;$phases=[qw/runtime build test/]unless defined$phases;$types=[qw/requires recommends/]unless defined$types;confess "merged_requirements phases argument must be an arrayref" unless ref$phases eq 'ARRAY';confess "merged_requirements types argument must be an arrayref" unless ref$types eq 'ARRAY';my$req=CPAN::Meta::Requirements->new;for my$phase (@$phases){unless ($phase =~ /\Ax_/i or grep {$phase eq $_}$self->__legal_phases){confess "requested requirements for unknown phase: $phase"}for my$type (@$types){unless ($type =~ /\Ax_/i or grep {$type eq $_}$self->__legal_types){confess "requested requirements for unknown type: $type"}$req->add_requirements($self->requirements_for($phase,$type))}}$req->finalize if$self->is_finalized;return$req}sub as_string_hash {my ($self)=@_;my%hash;for my$phase ($self->__legal_phases){for my$type ($self->__legal_types){my$req=$self->requirements_for($phase,$type);next unless$req->required_modules;$hash{$phase }{$type }=$req->as_string_hash}}return \%hash}sub is_finalized {$_[0]{finalized}}sub finalize {my ($self)=@_;$self->{finalized}=1;for my$phase (keys %{$self->{prereqs}}){$_->finalize for values %{$self->{prereqs}{$phase}}}}sub clone {my ($self)=@_;my$clone=(ref$self)->new($self->as_string_hash)}1; CPAN_META_PREREQS $fatpacked{"CPAN/Meta/Requirements.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_REQUIREMENTS'; use strict;use warnings;package CPAN::Meta::Requirements;our$VERSION='2.133';use Carp ();BEGIN {eval "use version ()";if (my$err=$@){eval "use ExtUtils::MakeMaker::version" or die$err}}*_is_qv=version->can('is_qv')? sub {$_[0]->is_qv}: sub {exists $_[0]->{qv}};my$V0=version->new(0);my@valid_options=qw(bad_version_hook);sub new {my ($class,$options)=@_;$options ||= {};Carp::croak "Argument to $class\->new() must be a hash reference" unless ref$options eq 'HASH';my%self=map {;$_=>$options->{$_}}@valid_options;return bless \%self=>$class}sub _find_magic_vstring {my$value=shift;my$tvalue='';require B;my$sv=B::svref_2object(\$value);my$magic=ref($sv)eq 'B::PVMG' ? $sv->MAGIC : undef;while ($magic){if ($magic->TYPE eq 'V'){$tvalue=$magic->PTR;$tvalue =~ s/^v?(.+)$/v$1/;last}else {$magic=$magic->MOREMAGIC}}return$tvalue}sub _isa_version {UNIVERSAL::isa($_[0],'UNIVERSAL')&& $_[0]->isa('version')}sub _version_object {my ($self,$module,$version)=@_;my ($vobj,$err);if (not defined$version or (!ref($version)&& $version eq '0')){return$V0}elsif (ref($version)eq 'version' || _isa_version($version)){$vobj=$version}else {if ($INC{'version/vpp.pm'}|| $INC{'ExtUtils/MakeMaker/version/vpp.pm'}){my$magic=_find_magic_vstring($version);$version=$magic if length$magic}eval {local$SIG{__WARN__}=sub {die "Invalid version: $_[0]"};$vobj=version->new($version)};if (my$err=$@){my$hook=$self->{bad_version_hook};$vobj=eval {$hook->($version,$module)}if ref$hook eq 'CODE';unless (eval {$vobj->isa("version")}){$err =~ s{ at .* line \d+.*$}{};die "Can't convert '$version': $err"}}}if ($vobj =~ m{\A\.}){$vobj=version->new("0$vobj")}if (_is_qv($vobj)){$vobj=version->new($vobj->normal)}return$vobj}BEGIN {for my$type (qw(maximum exclusion exact_version)){my$method="with_$type";my$to_add=$type eq 'exact_version' ? $type : "add_$type";my$code=sub {my ($self,$name,$version)=@_;$version=$self->_version_object($name,$version);$self->__modify_entry_for($name,$method,$version);return$self};no strict 'refs';*$to_add=$code}}sub add_minimum {my ($self,$name,$version)=@_;if (not defined$version or "$version" eq '0'){return$self if$self->__entry_for($name);Carp::confess("can't add new requirements to finalized requirements")if$self->is_finalized;$self->{requirements}{$name }=CPAN::Meta::Requirements::_Range::Range->with_minimum($V0)}else {$version=$self->_version_object($name,$version);$self->__modify_entry_for($name,'with_minimum',$version)}return$self}sub add_requirements {my ($self,$req)=@_;for my$module ($req->required_modules){my$modifiers=$req->__entry_for($module)->as_modifiers;for my$modifier (@$modifiers){my ($method,@args)=@$modifier;$self->$method($module=>@args)}}return$self}sub accepts_module {my ($self,$module,$version)=@_;$version=$self->_version_object($module,$version);return 1 unless my$range=$self->__entry_for($module);return$range->_accepts($version)}sub clear_requirement {my ($self,$module)=@_;return$self unless$self->__entry_for($module);Carp::confess("can't clear requirements on finalized requirements")if$self->is_finalized;delete$self->{requirements}{$module };return$self}sub requirements_for_module {my ($self,$module)=@_;my$entry=$self->__entry_for($module);return unless$entry;return$entry->as_string}sub required_modules {keys %{$_[0]{requirements}}}sub clone {my ($self)=@_;my$new=(ref$self)->new;return$new->add_requirements($self)}sub __entry_for {$_[0]{requirements}{$_[1]}}sub __modify_entry_for {my ($self,$name,$method,$version)=@_;my$fin=$self->is_finalized;my$old=$self->__entry_for($name);Carp::confess("can't add new requirements to finalized requirements")if$fin and not $old;my$new=($old || 'CPAN::Meta::Requirements::_Range::Range')->$method($version);Carp::confess("can't modify finalized requirements")if$fin and $old->as_string ne $new->as_string;$self->{requirements}{$name }=$new}sub is_simple {my ($self)=@_;for my$module ($self->required_modules){return if$self->__entry_for($module)->as_string =~ /\s/}return 1}sub is_finalized {$_[0]{finalized}}sub finalize {$_[0]{finalized}=1}sub as_string_hash {my ($self)=@_;my%hash=map {;$_=>$self->{requirements}{$_}->as_string}$self->required_modules;return \%hash}my%methods_for_op=('=='=>[qw(exact_version) ],'!='=>[qw(add_exclusion) ],'>='=>[qw(add_minimum) ],'<='=>[qw(add_maximum) ],'>'=>[qw(add_minimum add_exclusion) ],'<'=>[qw(add_maximum add_exclusion) ],);sub add_string_requirement {my ($self,$module,$req)=@_;unless (defined$req && length$req){$req=0;$self->_blank_carp($module)}my$magic=_find_magic_vstring($req);if (length$magic){$self->add_minimum($module=>$magic);return}my@parts=split qr{\s*,\s*},$req;for my$part (@parts){my ($op,$ver)=$part =~ m{\A\s*(==|>=|>|<=|<|!=)\s*(.*)\z};if (!defined$op){$self->add_minimum($module=>$part)}else {Carp::confess("illegal requirement string: $req")unless my$methods=$methods_for_op{$op };$self->$_($module=>$ver)for @$methods}}}sub _blank_carp {my ($self,$module)=@_;Carp::carp("Undefined requirement for $module treated as '0'")}sub from_string_hash {my ($class,$hash,$options)=@_;my$self=$class->new($options);for my$module (keys %$hash){my$req=$hash->{$module};unless (defined$req && length$req){$req=0;$class->_blank_carp($module)}$self->add_string_requirement($module,$req)}return$self}{package CPAN::Meta::Requirements::_Range::Exact;sub _new {bless {version=>$_[1]}=>$_[0]}sub _accepts {return $_[0]{version}==$_[1]}sub as_string {return "== $_[0]{version}"}sub as_modifiers {return [[exact_version=>$_[0]{version}]]}sub _clone {(ref $_[0])->_new(version->new($_[0]{version}))}sub with_exact_version {my ($self,$version)=@_;return$self->_clone if$self->_accepts($version);Carp::confess("illegal requirements: unequal exact version specified")}sub with_minimum {my ($self,$minimum)=@_;return$self->_clone if$self->{version}>= $minimum;Carp::confess("illegal requirements: minimum above exact specification")}sub with_maximum {my ($self,$maximum)=@_;return$self->_clone if$self->{version}<= $maximum;Carp::confess("illegal requirements: maximum below exact specification")}sub with_exclusion {my ($self,$exclusion)=@_;return$self->_clone unless$exclusion==$self->{version};Carp::confess("illegal requirements: excluded exact specification")}}{package CPAN::Meta::Requirements::_Range::Range;sub _self {ref($_[0])? $_[0]: (bless {}=>$_[0])}sub _clone {return (bless {}=>$_[0])unless ref $_[0];my ($s)=@_;my%guts=((exists$s->{minimum}? (minimum=>version->new($s->{minimum})): ()),(exists$s->{maximum}? (maximum=>version->new($s->{maximum})): ()),(exists$s->{exclusions}? (exclusions=>[map {version->new($_)}@{$s->{exclusions}}]): ()),);bless \%guts=>ref($s)}sub as_modifiers {my ($self)=@_;my@mods;push@mods,[add_minimum=>$self->{minimum}]if exists$self->{minimum};push@mods,[add_maximum=>$self->{maximum}]if exists$self->{maximum};push@mods,map {;[add_exclusion=>$_ ]}@{$self->{exclusions}|| []};return \@mods}sub as_string {my ($self)=@_;return 0 if!keys %$self;return "$self->{minimum}" if (keys %$self)==1 and exists$self->{minimum};my@exclusions=@{$self->{exclusions}|| []};my@parts;for my$pair ([qw(>= > minimum) ],[qw(<= < maximum) ],){my ($op,$e_op,$k)=@$pair;if (exists$self->{$k}){my@new_exclusions=grep {$_!=$self->{$k }}@exclusions;if (@new_exclusions==@exclusions){push@parts,"$op $self->{ $k }"}else {push@parts,"$e_op $self->{ $k }";@exclusions=@new_exclusions}}}push@parts,map {;"!= $_"}@exclusions;return join q{, },@parts}sub with_exact_version {my ($self,$version)=@_;$self=$self->_clone;Carp::confess("illegal requirements: exact specification outside of range")unless$self->_accepts($version);return CPAN::Meta::Requirements::_Range::Exact->_new($version)}sub _simplify {my ($self)=@_;if (defined$self->{minimum}and defined$self->{maximum}){if ($self->{minimum}==$self->{maximum}){Carp::confess("illegal requirements: excluded all values")if grep {$_==$self->{minimum}}@{$self->{exclusions}|| []};return CPAN::Meta::Requirements::_Range::Exact->_new($self->{minimum})}Carp::confess("illegal requirements: minimum exceeds maximum")if$self->{minimum}> $self->{maximum}}if ($self->{exclusions}){my%seen;@{$self->{exclusions}}=grep {(!defined$self->{minimum}or $_ >= $self->{minimum})and (!defined$self->{maximum}or $_ <= $self->{maximum})and !$seen{$_}++}@{$self->{exclusions}}}return$self}sub with_minimum {my ($self,$minimum)=@_;$self=$self->_clone;if (defined (my$old_min=$self->{minimum})){$self->{minimum}=(sort {$b cmp $a}($minimum,$old_min))[0]}else {$self->{minimum}=$minimum}return$self->_simplify}sub with_maximum {my ($self,$maximum)=@_;$self=$self->_clone;if (defined (my$old_max=$self->{maximum})){$self->{maximum}=(sort {$a cmp $b}($maximum,$old_max))[0]}else {$self->{maximum}=$maximum}return$self->_simplify}sub with_exclusion {my ($self,$exclusion)=@_;$self=$self->_clone;push @{$self->{exclusions}||= []},$exclusion;return$self->_simplify}sub _accepts {my ($self,$version)=@_;return if defined$self->{minimum}and $version < $self->{minimum};return if defined$self->{maximum}and $version > $self->{maximum};return if defined$self->{exclusions}and grep {$version==$_}@{$self->{exclusions}};return 1}}1; CPAN_META_REQUIREMENTS $fatpacked{"CPAN/Meta/Spec.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_SPEC'; use 5.006;use strict;use warnings;package CPAN::Meta::Spec;our$VERSION='2.150005';1; 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';my%known_specs=('1.4'=>'http://module-build.sourceforge.net/META-spec-v1.4.html','1.3'=>'http://module-build.sourceforge.net/META-spec-v1.3.html','1.2'=>'http://module-build.sourceforge.net/META-spec-v1.2.html','1.1'=>'http://module-build.sourceforge.net/META-spec-v1.1.html','1.0'=>'http://module-build.sourceforge.net/META-spec-v1.0.html');my%known_urls=map {$known_specs{$_}=>$_}keys%known_specs;my$module_map1={'map'=>{':key'=>{name=>\&module,value=>\&exversion }}};my$module_map2={'map'=>{':key'=>{name=>\&module,value=>\&version }}};my$no_index_2={'map'=>{file=>{list=>{value=>\&string }},directory=>{list=>{value=>\&string }},'package'=>{list=>{value=>\&string }},namespace=>{list=>{value=>\&string }},':key'=>{name=>\&custom_2,value=>\&anything },}};my$no_index_1_3={'map'=>{file=>{list=>{value=>\&string }},directory=>{list=>{value=>\&string }},'package'=>{list=>{value=>\&string }},namespace=>{list=>{value=>\&string }},':key'=>{name=>\&string,value=>\&anything },}};my$no_index_1_2={'map'=>{file=>{list=>{value=>\&string }},dir=>{list=>{value=>\&string }},'package'=>{list=>{value=>\&string }},namespace=>{list=>{value=>\&string }},':key'=>{name=>\&string,value=>\&anything },}};my$no_index_1_1={'map'=>{':key'=>{name=>\&string,list=>{value=>\&string }},}};my$prereq_map={map=>{':key'=>{name=>\&phase,'map'=>{':key'=>{name=>\&relation,%$module_map1,},},}},};my%definitions=('2'=>{'abstract'=>{mandatory=>1,value=>\&string },'author'=>{mandatory=>1,list=>{value=>\&string }},'dynamic_config'=>{mandatory=>1,value=>\&boolean },'generated_by'=>{mandatory=>1,value=>\&string },'license'=>{mandatory=>1,list=>{value=>\&license }},'meta-spec'=>{mandatory=>1,'map'=>{version=>{mandatory=>1,value=>\&version},url=>{value=>\&url },':key'=>{name=>\&custom_2,value=>\&anything },}},'name'=>{mandatory=>1,value=>\&string },'release_status'=>{mandatory=>1,value=>\&release_status },'version'=>{mandatory=>1,value=>\&version },'description'=>{value=>\&string },'keywords'=>{list=>{value=>\&string }},'no_index'=>$no_index_2,'optional_features'=>{'map'=>{':key'=>{name=>\&string,'map'=>{description=>{value=>\&string },prereqs=>$prereq_map,':key'=>{name=>\&custom_2,value=>\&anything },}}}},'prereqs'=>$prereq_map,'provides'=>{'map'=>{':key'=>{name=>\&module,'map'=>{file=>{mandatory=>1,value=>\&file },version=>{value=>\&version },':key'=>{name=>\&custom_2,value=>\&anything },}}}},'resources'=>{'map'=>{license=>{list=>{value=>\&url }},homepage=>{value=>\&url },bugtracker=>{'map'=>{web=>{value=>\&url },mailto=>{value=>\&string},':key'=>{name=>\&custom_2,value=>\&anything },}},repository=>{'map'=>{web=>{value=>\&url },url=>{value=>\&url },type=>{value=>\&string },':key'=>{name=>\&custom_2,value=>\&anything },}},':key'=>{value=>\&string,name=>\&custom_2 },}},':key'=>{name=>\&custom_2,value=>\&anything },},'1.4'=>{'meta-spec'=>{mandatory=>1,'map'=>{version=>{mandatory=>1,value=>\&version},url=>{mandatory=>1,value=>\&urlspec },':key'=>{name=>\&string,value=>\&anything },},},'name'=>{mandatory=>1,value=>\&string },'version'=>{mandatory=>1,value=>\&version },'abstract'=>{mandatory=>1,value=>\&string },'author'=>{mandatory=>1,list=>{value=>\&string }},'license'=>{mandatory=>1,value=>\&license },'generated_by'=>{mandatory=>1,value=>\&string },'distribution_type'=>{value=>\&string },'dynamic_config'=>{value=>\&boolean },'requires'=>$module_map1,'recommends'=>$module_map1,'build_requires'=>$module_map1,'configure_requires'=>$module_map1,'conflicts'=>$module_map2,'optional_features'=>{'map'=>{':key'=>{name=>\&string,'map'=>{description=>{value=>\&string },requires=>$module_map1,recommends=>$module_map1,build_requires=>$module_map1,conflicts=>$module_map2,':key'=>{name=>\&string,value=>\&anything },}}}},'provides'=>{'map'=>{':key'=>{name=>\&module,'map'=>{file=>{mandatory=>1,value=>\&file },version=>{value=>\&version },':key'=>{name=>\&string,value=>\&anything },}}}},'no_index'=>$no_index_1_3,'private'=>$no_index_1_3,'keywords'=>{list=>{value=>\&string }},'resources'=>{'map'=>{license=>{value=>\&url },homepage=>{value=>\&url },bugtracker=>{value=>\&url },repository=>{value=>\&url },':key'=>{value=>\&string,name=>\&custom_1 },}},':key'=>{name=>\&string,value=>\&anything },},'1.3'=>{'meta-spec'=>{mandatory=>1,'map'=>{version=>{mandatory=>1,value=>\&version},url=>{mandatory=>1,value=>\&urlspec },':key'=>{name=>\&string,value=>\&anything },},},'name'=>{mandatory=>1,value=>\&string },'version'=>{mandatory=>1,value=>\&version },'abstract'=>{mandatory=>1,value=>\&string },'author'=>{mandatory=>1,list=>{value=>\&string }},'license'=>{mandatory=>1,value=>\&license },'generated_by'=>{mandatory=>1,value=>\&string },'distribution_type'=>{value=>\&string },'dynamic_config'=>{value=>\&boolean },'requires'=>$module_map1,'recommends'=>$module_map1,'build_requires'=>$module_map1,'conflicts'=>$module_map2,'optional_features'=>{'map'=>{':key'=>{name=>\&string,'map'=>{description=>{value=>\&string },requires=>$module_map1,recommends=>$module_map1,build_requires=>$module_map1,conflicts=>$module_map2,':key'=>{name=>\&string,value=>\&anything },}}}},'provides'=>{'map'=>{':key'=>{name=>\&module,'map'=>{file=>{mandatory=>1,value=>\&file },version=>{value=>\&version },':key'=>{name=>\&string,value=>\&anything },}}}},'no_index'=>$no_index_1_3,'private'=>$no_index_1_3,'keywords'=>{list=>{value=>\&string }},'resources'=>{'map'=>{license=>{value=>\&url },homepage=>{value=>\&url },bugtracker=>{value=>\&url },repository=>{value=>\&url },':key'=>{value=>\&string,name=>\&custom_1 },}},':key'=>{name=>\&string,value=>\&anything },},'1.2'=>{'meta-spec'=>{mandatory=>1,'map'=>{version=>{mandatory=>1,value=>\&version},url=>{mandatory=>1,value=>\&urlspec },':key'=>{name=>\&string,value=>\&anything },},},'name'=>{mandatory=>1,value=>\&string },'version'=>{mandatory=>1,value=>\&version },'license'=>{mandatory=>1,value=>\&license },'generated_by'=>{mandatory=>1,value=>\&string },'author'=>{mandatory=>1,list=>{value=>\&string }},'abstract'=>{mandatory=>1,value=>\&string },'distribution_type'=>{value=>\&string },'dynamic_config'=>{value=>\&boolean },'keywords'=>{list=>{value=>\&string }},'private'=>$no_index_1_2,'$no_index'=>$no_index_1_2,'requires'=>$module_map1,'recommends'=>$module_map1,'build_requires'=>$module_map1,'conflicts'=>$module_map2,'optional_features'=>{'map'=>{':key'=>{name=>\&string,'map'=>{description=>{value=>\&string },requires=>$module_map1,recommends=>$module_map1,build_requires=>$module_map1,conflicts=>$module_map2,':key'=>{name=>\&string,value=>\&anything },}}}},'provides'=>{'map'=>{':key'=>{name=>\&module,'map'=>{file=>{mandatory=>1,value=>\&file },version=>{value=>\&version },':key'=>{name=>\&string,value=>\&anything },}}}},'resources'=>{'map'=>{license=>{value=>\&url },homepage=>{value=>\&url },bugtracker=>{value=>\&url },repository=>{value=>\&url },':key'=>{value=>\&string,name=>\&custom_1 },}},':key'=>{name=>\&string,value=>\&anything },},'1.1'=>{'name'=>{value=>\&string },'version'=>{mandatory=>1,value=>\&version },'license'=>{value=>\&license },'generated_by'=>{value=>\&string },'license_uri'=>{value=>\&url },'distribution_type'=>{value=>\&string },'dynamic_config'=>{value=>\&boolean },'private'=>$no_index_1_1,'requires'=>$module_map1,'recommends'=>$module_map1,'build_requires'=>$module_map1,'conflicts'=>$module_map2,':key'=>{name=>\&string,value=>\&anything },},'1.0'=>{'name'=>{value=>\&string },'version'=>{mandatory=>1,value=>\&version },'license'=>{value=>\&license },'generated_by'=>{value=>\&string },'license_uri'=>{value=>\&url },'distribution_type'=>{value=>\&string },'dynamic_config'=>{value=>\&boolean },'requires'=>$module_map1,'recommends'=>$module_map1,'build_requires'=>$module_map1,'conflicts'=>$module_map2,':key'=>{name=>\&string,value=>\&anything },},);sub new {my ($class,$data)=@_;my$self={'data'=>$data,'spec'=>eval {$data->{'meta-spec'}{'version'}}|| "1.0",'errors'=>undef,};return bless$self,$class}sub is_valid {my$self=shift;my$data=$self->{data};my$spec_version=$self->{spec};$self->check_map($definitions{$spec_version},$data);return!$self->errors}sub errors {my$self=shift;return ()unless(defined$self->{errors});return @{$self->{errors}}}my$spec_error="Missing validation action in specification. " ."Must be one of 'map', 'list', or 'value'";sub check_map {my ($self,$spec,$data)=@_;if(ref($spec)ne 'HASH'){$self->_error("Unknown META specification, cannot validate.");return}if(ref($data)ne 'HASH'){$self->_error("Expected a map structure from string or file.");return}for my$key (keys %$spec){next unless($spec->{$key}->{mandatory});next if(defined$data->{$key});push @{$self->{stack}},$key;$self->_error("Missing mandatory field, '$key'");pop @{$self->{stack}}}for my$key (keys %$data){push @{$self->{stack}},$key;if($spec->{$key}){if($spec->{$key}{value}){$spec->{$key}{value}->($self,$key,$data->{$key})}elsif($spec->{$key}{'map'}){$self->check_map($spec->{$key}{'map'},$data->{$key})}elsif($spec->{$key}{'list'}){$self->check_list($spec->{$key}{'list'},$data->{$key})}else {$self->_error("$spec_error for '$key'")}}elsif ($spec->{':key'}){$spec->{':key'}{name}->($self,$key,$key);if($spec->{':key'}{value}){$spec->{':key'}{value}->($self,$key,$data->{$key})}elsif($spec->{':key'}{'map'}){$self->check_map($spec->{':key'}{'map'},$data->{$key})}elsif($spec->{':key'}{'list'}){$self->check_list($spec->{':key'}{'list'},$data->{$key})}else {$self->_error("$spec_error for ':key'")}}else {$self->_error("Unknown key, '$key', found in map structure")}pop @{$self->{stack}}}}sub check_list {my ($self,$spec,$data)=@_;if(ref($data)ne 'ARRAY'){$self->_error("Expected a list structure");return}if(defined$spec->{mandatory}){if(!defined$data->[0]){$self->_error("Missing entries from mandatory list")}}for my$value (@$data){push @{$self->{stack}},$value || "<undef>";if(defined$spec->{value}){$spec->{value}->($self,'list',$value)}elsif(defined$spec->{'map'}){$self->check_map($spec->{'map'},$value)}elsif(defined$spec->{'list'}){$self->check_list($spec->{'list'},$value)}elsif ($spec->{':key'}){$self->check_map($spec,$value)}else {$self->_error("$spec_error associated with '$self->{stack}[-2]'")}pop @{$self->{stack}}}}sub header {my ($self,$key,$value)=@_;if(defined$value){return 1 if($value && $value =~ /^--- #YAML:1.0/)}$self->_error("file does not have a valid YAML header.");return 0}sub release_status {my ($self,$key,$value)=@_;if(defined$value){my$version=$self->{data}{version}|| '';if ($version =~ /_/){return 1 if ($value =~ /\A(?:testing|unstable)\z/);$self->_error("'$value' for '$key' is invalid for version '$version'")}else {return 1 if ($value =~ /\A(?:stable|testing|unstable)\z/);$self->_error("'$value' for '$key' is invalid")}}else {$self->_error("'$key' is not defined")}return 0}sub _uri_split {return $_[0]=~ m,(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?,}sub url {my ($self,$key,$value)=@_;if(defined$value){my ($scheme,$auth,$path,$query,$frag)=_uri_split($value);unless (defined$scheme && length$scheme){$self->_error("'$value' for '$key' does not have a URL scheme");return 0}unless (defined$auth && length$auth){$self->_error("'$value' for '$key' does not have a URL authority");return 0}return 1}$value ||= '';$self->_error("'$value' for '$key' is not a valid URL.");return 0}sub urlspec {my ($self,$key,$value)=@_;if(defined$value){return 1 if($value && $known_specs{$self->{spec}}eq $value);if($value && $known_urls{$value}){$self->_error('META specification URL does not match version');return 0}}$self->_error('Unknown META specification');return 0}sub anything {return 1}sub string {my ($self,$key,$value)=@_;if(defined$value){return 1 if($value || $value =~ /^0$/)}$self->_error("value is an undefined string");return 0}sub string_or_undef {my ($self,$key,$value)=@_;return 1 unless(defined$value);return 1 if($value || $value =~ /^0$/);$self->_error("No string defined for '$key'");return 0}sub file {my ($self,$key,$value)=@_;return 1 if(defined$value);$self->_error("No file defined for '$key'");return 0}sub exversion {my ($self,$key,$value)=@_;if(defined$value && ($value || $value =~ /0/)){my$pass=1;for(split(",",$value)){$self->version($key,$_)or ($pass=0)}return$pass}$value='<undef>' unless(defined$value);$self->_error("'$value' for '$key' is not a valid version.");return 0}sub version {my ($self,$key,$value)=@_;if(defined$value){return 0 unless($value || $value =~ /0/);return 1 if($value =~ /^\s*((<|<=|>=|>|!=|==)\s*)?v?\d+((\.\d+((_|\.)\d+)?)?)/)}else {$value='<undef>'}$self->_error("'$value' for '$key' is not a valid version.");return 0}sub boolean {my ($self,$key,$value)=@_;if(defined$value){return 1 if($value =~ /^(0|1|true|false)$/)}else {$value='<undef>'}$self->_error("'$value' for '$key' is not a boolean value.");return 0}my%v1_licenses=('perl'=>'http://dev.perl.org/licenses/','gpl'=>'http://www.opensource.org/licenses/gpl-license.php','apache'=>'http://apache.org/licenses/LICENSE-2.0','artistic'=>'http://opensource.org/licenses/artistic-license.php','artistic_2'=>'http://opensource.org/licenses/artistic-license-2.0.php','lgpl'=>'http://www.opensource.org/licenses/lgpl-license.php','bsd'=>'http://www.opensource.org/licenses/bsd-license.php','gpl'=>'http://www.opensource.org/licenses/gpl-license.php','mit'=>'http://opensource.org/licenses/mit-license.php','mozilla'=>'http://opensource.org/licenses/mozilla1.1.php','open_source'=>undef,'unrestricted'=>undef,'restrictive'=>undef,'unknown'=>undef,);my%v2_licenses=map {$_=>1}qw(agpl_3 apache_1_1 apache_2_0 artistic_1 artistic_2 bsd freebsd gfdl_1_2 gfdl_1_3 gpl_1 gpl_2 gpl_3 lgpl_2_1 lgpl_3_0 mit mozilla_1_0 mozilla_1_1 openssl perl_5 qpl_1_0 ssleay sun zlib open_source restricted unrestricted unknown);sub license {my ($self,$key,$value)=@_;my$licenses=$self->{spec}< 2 ? \%v1_licenses : \%v2_licenses;if(defined$value){return 1 if($value && exists$licenses->{$value})}else {$value='<undef>'}$self->_error("License '$value' is invalid");return 0}sub custom_1 {my ($self,$key)=@_;if(defined$key){return 1 if($key && $key =~ /^[_a-z]+$/i && $key =~ /[A-Z]/)}else {$key='<undef>'}$self->_error("Custom resource '$key' must be in CamelCase.");return 0}sub custom_2 {my ($self,$key)=@_;if(defined$key){return 1 if($key && $key =~ /^x_/i)}else {$key='<undef>'}$self->_error("Custom key '$key' must begin with 'x_' or 'X_'.");return 0}sub identifier {my ($self,$key)=@_;if(defined$key){return 1 if($key && $key =~ /^([a-z][_a-z]+)$/i)}else {$key='<undef>'}$self->_error("Key '$key' is not a legal identifier.");return 0}sub module {my ($self,$key)=@_;if(defined$key){return 1 if($key && $key =~ /^[A-Za-z0-9_]+(::[A-Za-z0-9_]+)*$/)}else {$key='<undef>'}$self->_error("Key '$key' is not a legal module name.");return 0}my@valid_phases=qw/configure build test runtime develop/;sub phase {my ($self,$key)=@_;if(defined$key){return 1 if(length$key && grep {$key eq $_}@valid_phases);return 1 if$key =~ /x_/i}else {$key='<undef>'}$self->_error("Key '$key' is not a legal phase.");return 0}my@valid_relations=qw/requires recommends suggests conflicts/;sub relation {my ($self,$key)=@_;if(defined$key){return 1 if(length$key && grep {$key eq $_}@valid_relations);return 1 if$key =~ /x_/i}else {$key='<undef>'}$self->_error("Key '$key' is not a legal prereq relationship.");return 0}sub _error {my$self=shift;my$mess=shift;$mess .= ' ('.join(' -> ',@{$self->{stack}}).')' if($self->{stack});$mess .= " [Validation: $self->{spec}]";push @{$self->{errors}},$mess}1; CPAN_META_VALIDATOR $fatpacked{"CPAN/Meta/YAML.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_YAML'; use 5.008001;use strict;use warnings;package CPAN::Meta::YAML;$CPAN::Meta::YAML::VERSION='0.016';;use Exporter;our@ISA=qw{Exporter};our@EXPORT=qw{Load Dump};our@EXPORT_OK=qw{LoadFile DumpFile freeze thaw};sub Dump {return CPAN::Meta::YAML->new(@_)->_dump_string}sub Load {my$self=CPAN::Meta::YAML->_load_string(@_);if (wantarray){return @$self}else {return$self->[-1]}}BEGIN {*freeze=\&Dump;*thaw=\&Load}sub DumpFile {my$file=shift;return CPAN::Meta::YAML->new(@_)->_dump_file($file)}sub LoadFile {my$file=shift;my$self=CPAN::Meta::YAML->_load_file($file);if (wantarray){return @$self}else {return$self->[-1]}}sub new {my$class=shift;bless [@_ ],$class}sub read_string {my$self=shift;$self->_load_string(@_)}sub write_string {my$self=shift;$self->_dump_string(@_)}sub read {my$self=shift;$self->_load_file(@_)}sub write {my$self=shift;$self->_dump_file(@_)}my@UNPRINTABLE=qw(0 x01 x02 x03 x04 x05 x06 a b t n v f r x0E x0F x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x1A e x1C x1D x1E x1F);my%UNESCAPES=(0=>"\x00",z=>"\x00",N=>"\x85",a=>"\x07",b=>"\x08",t=>"\x09",n=>"\x0a",v=>"\x0b",f=>"\x0c",r=>"\x0d",e=>"\x1b",'\\'=>'\\',);my%QUOTE=map {$_=>1}qw{null true false};my$re_capture_double_quoted=qr/\"([^\\"]*(?:\\.[^\\"]*)*)\"/;my$re_capture_single_quoted=qr/\'([^\']*(?:\'\'[^\']*)*)\'/;my$re_capture_unquoted_key=qr/([^:]+(?::+\S(?:[^:]*|.*?(?=:)))*)(?=\s*\:(?:\s+|$))/;my$re_trailing_comment=qr/(?:\s+\#.*)?/;my$re_key_value_separator=qr/\s*:(?:\s+(?:\#.*)?|$)/;sub _load_file {my$class=ref $_[0]? ref shift : shift;my$file=shift or $class->_error('You did not specify a file name');$class->_error("File '$file' does not exist")unless -e $file;$class->_error("'$file' is a directory, not a file")unless -f _;$class->_error("Insufficient permissions to read '$file'")unless -r _;open(my$fh,"<:unix:encoding(UTF-8)",$file);unless ($fh){$class->_error("Failed to open file '$file': $!")}if (_can_flock()){flock($fh,Fcntl::LOCK_SH())or warn "Couldn't lock '$file' for reading: $!"}my$contents=eval {use warnings FATAL=>'utf8';local $/;<$fh>};if (my$err=$@){$class->_error("Error reading from file '$file': $err")}unless (close$fh){$class->_error("Failed to close file '$file': $!")}$class->_load_string($contents)}sub _load_string {my$class=ref $_[0]? ref shift : shift;my$self=bless [],$class;my$string=$_[0];eval {unless (defined$string){die \"Did not provide a string to load"}if (utf8::is_utf8($string)&&!utf8::valid($string)){die \<<'...'}utf8::upgrade($string);$string =~ s/^\x{FEFF}//;return$self unless length$string;my@lines=grep {!/^\s*(?:\#.*)?\z/}split /(?:\015{1,2}\012|\015|\012)/,$string;@lines and $lines[0]=~ /^\%YAML[: ][\d\.]+.*\z/ and shift@lines;my$in_document=0;while (@lines){if ($lines[0]=~ /^---\s*(?:(.+)\s*)?\z/){shift@lines;if (defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/){push @$self,$self->_load_scalar("$1",[undef ],\@lines);next}$in_document=1}if (!@lines or $lines[0]=~ /^(?:---|\.\.\.)/){push @$self,undef;while (@lines and $lines[0]!~ /^---/){shift@lines}$in_document=0}elsif (!$in_document && @$self){die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'"}elsif ($lines[0]=~ /^\s*\-(?:\s|$|-+$)/){my$document=[];push @$self,$document;$self->_load_array($document,[0 ],\@lines)}elsif ($lines[0]=~ /^(\s*)\S/){my$document={};push @$self,$document;$self->_load_hash($document,[length($1)],\@lines)}else {die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'"}}};my$err=$@;if (ref$err eq 'SCALAR'){$self->_error(${$err})}elsif ($err){$self->_error($err)}return$self}sub _unquote_single {my ($self,$string)=@_;return '' unless length$string;$string =~ s/\'\'/\'/g;return$string}sub _unquote_double {my ($self,$string)=@_;return '' unless length$string;$string =~ s/\\"/"/g;$string =~ s{\\([Nnever\\fartz0b]|x([0-9a-fA-F]{2}))} 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)"? ... {(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}}gex;return$string}sub _load_scalar {my ($self,$string,$indent,$lines)=@_;$string =~ s/\s*\z//;return undef if$string eq '~';if ($string =~ /^$re_capture_single_quoted$re_trailing_comment\z/){return$self->_unquote_single($1)}if ($string =~ /^$re_capture_double_quoted$re_trailing_comment\z/){return$self->_unquote_double($1)}if ($string =~ /^[\'\"!&]/){die \"CPAN::Meta::YAML does not support a feature in line '$string'"}return {}if$string =~ /^{}(?:\s+\#.*)?\z/;return []if$string =~ /^\[\](?:\s+\#.*)?\z/;if ($string !~ /^[>|]/){die \"CPAN::Meta::YAML found illegal characters in plain scalar: '$string'" if$string =~ /^(?:-(?:\s|$)|[\@\%\`])/ or $string =~ /:(?:\s|$)/;$string =~ s/\s+#.*\z//;return$string}die \"CPAN::Meta::YAML failed to find multi-line scalar content" unless @$lines;$lines->[0]=~ /^(\s*)/;$indent->[-1]=length("$1");if (defined$indent->[-2]and $indent->[-1]<= $indent->[-2]){die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'"}my@multiline=();while (@$lines){$lines->[0]=~ /^(\s*)/;last unless length($1)>= $indent->[-1];push@multiline,substr(shift(@$lines),length($1))}my$j=(substr($string,0,1)eq '>')? ' ' : "\n";my$t=(substr($string,1,1)eq '-')? '' : "\n";return join($j,@multiline).$t}sub _load_array {my ($self,$array,$indent,$lines)=@_;while (@$lines){if ($lines->[0]=~ /^(?:---|\.\.\.)/){while (@$lines and $lines->[0]!~ /^---/){shift @$lines}return 1}$lines->[0]=~ /^(\s*)/;if (length($1)< $indent->[-1]){return 1}elsif (length($1)> $indent->[-1]){die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'"}if ($lines->[0]=~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/){my$indent2=length("$1");$lines->[0]=~ s/-/ /;push @$array,{};$self->_load_hash($array->[-1],[@$indent,$indent2 ],$lines)}elsif ($lines->[0]=~ /^\s*\-\s*\z/){shift @$lines;unless (@$lines){push @$array,undef;return 1}if ($lines->[0]=~ /^(\s*)\-/){my$indent2=length("$1");if ($indent->[-1]==$indent2){push @$array,undef}else {push @$array,[];$self->_load_array($array->[-1],[@$indent,$indent2 ],$lines)}}elsif ($lines->[0]=~ /^(\s*)\S/){push @$array,{};$self->_load_hash($array->[-1],[@$indent,length("$1")],$lines)}else {die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'"}}elsif ($lines->[0]=~ /^\s*\-(\s*)(.+?)\s*\z/){shift @$lines;push @$array,$self->_load_scalar("$2",[@$indent,undef ],$lines)}elsif (defined$indent->[-2]and $indent->[-1]==$indent->[-2]){return 1}else {die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'"}}return 1}sub _load_hash {my ($self,$hash,$indent,$lines)=@_;while (@$lines){if ($lines->[0]=~ /^(?:---|\.\.\.)/){while (@$lines and $lines->[0]!~ /^---/){shift @$lines}return 1}$lines->[0]=~ /^(\s*)/;if (length($1)< $indent->[-1]){return 1}elsif (length($1)> $indent->[-1]){die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'"}my$key;if ($lines->[0]=~ s/^\s*$re_capture_single_quoted$re_key_value_separator//){$key=$self->_unquote_single($1)}elsif ($lines->[0]=~ s/^\s*$re_capture_double_quoted$re_key_value_separator//){$key=$self->_unquote_double($1)}elsif ($lines->[0]=~ s/^\s*$re_capture_unquoted_key$re_key_value_separator//){$key=$1;$key =~ s/\s+$//}elsif ($lines->[0]=~ /^\s*\?/){die \"CPAN::Meta::YAML does not support a feature in line '$lines->[0]'"}else {die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'"}if (exists$hash->{$key}){warn "CPAN::Meta::YAML found a duplicate key '$key' in line '$lines->[0]'"}if (length$lines->[0]){$hash->{$key}=$self->_load_scalar(shift(@$lines),[@$indent,undef ],$lines)}else {shift @$lines;unless (@$lines){$hash->{$key}=undef;return 1}if ($lines->[0]=~ /^(\s*)-/){$hash->{$key}=[];$self->_load_array($hash->{$key},[@$indent,length($1)],$lines)}elsif ($lines->[0]=~ /^(\s*)./){my$indent2=length("$1");if ($indent->[-1]>= $indent2){$hash->{$key}=undef}else {$hash->{$key}={};$self->_load_hash($hash->{$key},[@$indent,length($1)],$lines)}}}}return 1}sub _dump_file {my$self=shift;require Fcntl;my$file=shift or $self->_error('You did not specify a file name');my$fh;if (_can_flock()){my$flags=Fcntl::O_WRONLY()|Fcntl::O_CREAT();sysopen($fh,$file,$flags);unless ($fh){$self->_error("Failed to open file '$file' for writing: $!")}binmode($fh,":raw:encoding(UTF-8)");flock($fh,Fcntl::LOCK_EX())or warn "Couldn't lock '$file' for reading: $!";truncate$fh,0;seek$fh,0,0}else {open$fh,">:unix:encoding(UTF-8)",$file}print {$fh}$self->_dump_string;unless (close$fh){$self->_error("Failed to close file '$file': $!")}return 1}sub _dump_string {my$self=shift;return '' unless ref$self && @$self;my$indent=0;my@lines=();eval {for my$cursor (@$self){push@lines,'---';if (!defined$cursor){}elsif (!ref$cursor){$lines[-1].= ' ' .$self->_dump_scalar($cursor)}elsif (ref$cursor eq 'ARRAY'){unless (@$cursor){$lines[-1].= ' []';next}push@lines,$self->_dump_array($cursor,$indent,{})}elsif (ref$cursor eq 'HASH'){unless (%$cursor){$lines[-1].= ' {}';next}push@lines,$self->_dump_hash($cursor,$indent,{})}else {die \("Cannot serialize " .ref($cursor))}}};if (ref $@ eq 'SCALAR'){$self->_error(${$@})}elsif ($@){$self->_error($@)}join '',map {"$_\n"}@lines}sub _has_internal_string_value {my$value=shift;my$b_obj=B::svref_2object(\$value);return$b_obj->FLAGS & B::SVf_POK()}sub _dump_scalar {my$string=$_[1];my$is_key=$_[2];my$has_string_flag=_has_internal_string_value($string);return '~' unless defined$string;return "''" unless length$string;if (Scalar::Util::looks_like_number($string)){if ($is_key || $has_string_flag){return qq['$string']}else {return$string}}if ($string =~ /[\x00-\x09\x0b-\x0d\x0e-\x1f\x7f-\x9f\'\n]/){$string =~ s/\\/\\\\/g;$string =~ s/"/\\"/g;$string =~ s/\n/\\n/g;$string =~ s/[\x85]/\\N/g;$string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g;$string =~ s/([\x7f-\x9f])/'\x' . sprintf("%X",ord($1))/ge;return qq|"$string"|}if ($string =~ /(?:^[~!@#%&*|>?:,'"`{}\[\]]|^-+$|\s|:\z)/ or $QUOTE{$string}){return "'$string'"}return$string}sub _dump_array {my ($self,$array,$indent,$seen)=@_;if ($seen->{refaddr($array)}++){die \"CPAN::Meta::YAML does not support circular references"}my@lines=();for my$el (@$array){my$line=(' ' x $indent).'-';my$type=ref$el;if (!$type){$line .= ' ' .$self->_dump_scalar($el);push@lines,$line}elsif ($type eq 'ARRAY'){if (@$el){push@lines,$line;push@lines,$self->_dump_array($el,$indent + 1,$seen)}else {$line .= ' []';push@lines,$line}}elsif ($type eq 'HASH'){if (keys %$el){push@lines,$line;push@lines,$self->_dump_hash($el,$indent + 1,$seen)}else {$line .= ' {}';push@lines,$line}}else {die \"CPAN::Meta::YAML does not support $type references"}}@lines}sub _dump_hash {my ($self,$hash,$indent,$seen)=@_;if ($seen->{refaddr($hash)}++){die \"CPAN::Meta::YAML does not support circular references"}my@lines=();for my$name (sort keys %$hash){my$el=$hash->{$name};my$line=(' ' x $indent).$self->_dump_scalar($name,1).":";my$type=ref$el;if (!$type){$line .= ' ' .$self->_dump_scalar($el);push@lines,$line}elsif ($type eq 'ARRAY'){if (@$el){push@lines,$line;push@lines,$self->_dump_array($el,$indent + 1,$seen)}else {$line .= ' []';push@lines,$line}}elsif ($type eq 'HASH'){if (keys %$el){push@lines,$line;push@lines,$self->_dump_hash($el,$indent + 1,$seen)}else {$line .= ' {}';push@lines,$line}}else {die \"CPAN::Meta::YAML does not support $type references"}}@lines}our$errstr='';sub _error {require Carp;$errstr=$_[1];$errstr =~ s/ at \S+ line \d+.*//;Carp::croak($errstr)}my$errstr_warned;sub errstr {require Carp;Carp::carp("CPAN::Meta::YAML->errstr and \$CPAN::Meta::YAML::errstr is deprecated")unless$errstr_warned++;$errstr}use B;my$HAS_FLOCK;sub _can_flock {if (defined$HAS_FLOCK){return$HAS_FLOCK}else {require Config;my$c=\%Config::Config;$HAS_FLOCK=grep {$c->{$_}}qw/d_flock d_fcntl_can_lock d_lockf/;require Fcntl if$HAS_FLOCK;return$HAS_FLOCK}}use Scalar::Util ();BEGIN {local $@;if (eval {Scalar::Util->VERSION(1.18)}){*refaddr=*Scalar::Util::refaddr}else {eval <<'END_PERL'}}delete$CPAN::Meta::YAML::{refaddr};1; # 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 CPAN_META_YAML $fatpacked{"Exporter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXPORTER'; package Exporter;require 5.006;our$Debug=0;our$ExportLevel=0;our$Verbose ||= 0;our$VERSION='5.70';our (%Cache);sub as_heavy {require Exporter::Heavy;my$c=(caller(1))[3];$c =~ s/.*:://;\&{"Exporter::Heavy::heavy_$c"}}sub export {goto &{as_heavy()}}sub import {my$pkg=shift;my$callpkg=caller($ExportLevel);if ($pkg eq "Exporter" and @_ and $_[0]eq "import"){*{$callpkg."::import"}=\&import;return}my$exports=\@{"$pkg\::EXPORT"};my$fail=${$pkg .'::'}{EXPORT_FAIL}&& \@{"$pkg\::EXPORT_FAIL"};return export$pkg,$callpkg,@_ if$Verbose or $Debug or $fail && @$fail > 1;my$export_cache=($Cache{$pkg}||= {});my$args=@_ or @_=@$exports;if ($args and not %$export_cache){s/^&//,$export_cache->{$_}=1 foreach (@$exports,@{"$pkg\::EXPORT_OK"})}my$heavy;if ($args or $fail){($heavy=(/\W/ or $args and not exists$export_cache->{$_}or $fail and @$fail and $_ eq $fail->[0]))and last foreach (@_)}else {($heavy=/\W/)and last foreach (@_)}return export$pkg,$callpkg,($args ? @_ : ())if$heavy;local$SIG{__WARN__}=sub {require Carp;&Carp::carp}if not $SIG{__WARN__};*{"$callpkg\::$_"}=\&{"$pkg\::$_"}foreach @_}sub export_fail {my$self=shift;@_}sub export_to_level {goto &{as_heavy()}}sub export_tags {goto &{as_heavy()}}sub export_ok_tags {goto &{as_heavy()}}sub require_version {goto &{as_heavy()}}1; EXPORTER $fatpacked{"Exporter/Heavy.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXPORTER_HEAVY'; package Exporter::Heavy;use strict;no strict 'refs';require Exporter;our$VERSION=$Exporter::VERSION;sub _rebuild_cache {my ($pkg,$exports,$cache)=@_;s/^&// foreach @$exports;@{$cache}{@$exports}=(1)x @$exports;my$ok=\@{"${pkg}::EXPORT_OK"};if (@$ok){s/^&// foreach @$ok;@{$cache}{@$ok}=(1)x @$ok}}sub heavy_export {my$oldwarn=$SIG{__WARN__};local$SIG{__WARN__}=sub {local$SIG{__WARN__}=$oldwarn;my$text=shift;if ($text =~ s/ at \S*Exporter\S*.pm line \d+.*\n//){require Carp;local$Carp::CarpLevel=1;Carp::carp($text)}else {warn$text}};local$SIG{__DIE__}=sub {require Carp;local$Carp::CarpLevel=1;Carp::croak("$_[0]Illegal null symbol in \@${1}::EXPORT")if $_[0]=~ /^Unable to create sub named "(.*?)::"/};my($pkg,$callpkg,@imports)=@_;my($type,$sym,$cache_is_current,$oops);my($exports,$export_cache)=(\@{"${pkg}::EXPORT"},$Exporter::Cache{$pkg}||= {});if (@imports){if (!%$export_cache){_rebuild_cache ($pkg,$exports,$export_cache);$cache_is_current=1}if (grep m{^[/!:]},@imports){my$tagsref=\%{"${pkg}::EXPORT_TAGS"};my$tagdata;my%imports;my($remove,$spec,@names,@allexports);unshift@imports,':DEFAULT' if$imports[0]=~ m/^!/;for$spec (@imports){$remove=$spec =~ s/^!//;if ($spec =~ s/^://){if ($spec eq 'DEFAULT'){@names=@$exports}elsif ($tagdata=$tagsref->{$spec}){@names=@$tagdata}else {warn qq["$spec" is not defined in %${pkg}::EXPORT_TAGS];++$oops;next}}elsif ($spec =~ m:^/(.*)/$:){my$patn=$1;@allexports=keys %$export_cache unless@allexports;@names=grep(/$patn/,@allexports)}else {@names=($spec)}warn "Import ".($remove ? "del":"add").": @names " if$Exporter::Verbose;if ($remove){for$sym (@names){delete$imports{$sym}}}else {@imports{@names}=(1)x @names}}@imports=keys%imports}my@carp;for$sym (@imports){if (!$export_cache->{$sym}){if ($sym =~ m/^\d/){$pkg->VERSION($sym);if (@imports==1){@imports=@$exports;last}if (@imports==2 and!$imports[1]){@imports=();last}}elsif ($sym !~ s/^&// ||!$export_cache->{$sym}){unless ($cache_is_current){%$export_cache=();_rebuild_cache ($pkg,$exports,$export_cache);$cache_is_current=1}if (!$export_cache->{$sym}){push@carp,qq["$sym" is not exported by the $pkg module\n];$oops++}}}}if ($oops){require Carp;Carp::croak("@{carp}Can't continue after import errors")}}else {@imports=@$exports}my($fail,$fail_cache)=(\@{"${pkg}::EXPORT_FAIL"},$Exporter::FailCache{$pkg}||= {});if (@$fail){if (!%$fail_cache){my@expanded=map {/^\w/ ? ($_,'&'.$_): $_}@$fail;warn "${pkg}::EXPORT_FAIL cached: @expanded" if$Exporter::Verbose;@{$fail_cache}{@expanded}=(1)x @expanded}my@failed;for$sym (@imports){push(@failed,$sym)if$fail_cache->{$sym}}if (@failed){@failed=$pkg->export_fail(@failed);for$sym (@failed){require Carp;Carp::carp(qq["$sym" is not implemented by the $pkg module ],"on this architecture")}if (@failed){require Carp;Carp::croak("Can't continue after import errors")}}}warn "Importing into $callpkg from $pkg: ",join(", ",sort@imports)if$Exporter::Verbose;for$sym (@imports){(*{"${callpkg}::$sym"}=\&{"${pkg}::$sym"},next)unless$sym =~ s/^(\W)//;$type=$1;no warnings 'once';*{"${callpkg}::$sym"}=$type eq '&' ? \&{"${pkg}::$sym"}: $type eq '$' ? \${"${pkg}::$sym"}: $type eq '@' ? \@{"${pkg}::$sym"}: $type eq '%' ? \%{"${pkg}::$sym"}: $type eq '*' ? *{"${pkg}::$sym"}: do {require Carp;Carp::croak("Can't export symbol: $type$sym")}}}sub heavy_export_to_level {my$pkg=shift;my$level=shift;(undef)=shift;my$callpkg=caller($level);$pkg->export($callpkg,@_)}sub _push_tags {my($pkg,$var,$syms)=@_;my@nontag=();my$export_tags=\%{"${pkg}::EXPORT_TAGS"};push(@{"${pkg}::$var"},map {$export_tags->{$_}? @{$export_tags->{$_}}: scalar(push(@nontag,$_),$_)}(@$syms)? @$syms : keys %$export_tags);if (@nontag and $^W){require Carp;Carp::carp(join(", ",@nontag)." are not tags of $pkg")}}sub heavy_require_version {my($self,$wanted)=@_;my$pkg=ref$self || $self;return ${pkg}->VERSION($wanted)}sub heavy_export_tags {_push_tags((caller)[0],"EXPORT",\@_)}sub heavy_export_ok_tags {_push_tags((caller)[0],"EXPORT_OK",\@_)}1; EXPORTER_HEAVY $fatpacked{"File/pushd.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'FILE_PUSHD'; use strict;use warnings;package File::pushd;our$VERSION='1.009';our@EXPORT=qw(pushd tempd);our@ISA=qw(Exporter);use Exporter;use Carp;use Cwd qw(getcwd abs_path);use File::Path qw(rmtree);use File::Temp qw();use File::Spec;use overload q{""}=>sub {File::Spec->canonpath($_[0]->{_pushd})},fallback=>1;sub pushd {my ($target_dir,$options)=@_;$options->{untaint_pattern}||= qr{^([-+@\w./]+)$};$target_dir="." unless defined$target_dir;croak "Can't locate directory $target_dir" unless -d $target_dir;my$tainted_orig=getcwd;my$orig;if ($tainted_orig =~ $options->{untaint_pattern}){$orig=$1}else {$orig=$tainted_orig}my$tainted_dest;eval {$tainted_dest=$target_dir ? abs_path($target_dir): $orig};croak "Can't locate absolute path for $target_dir: $@" if $@;my$dest;if ($tainted_dest =~ $options->{untaint_pattern}){$dest=$1}else {$dest=$tainted_dest}if ($dest ne $orig){chdir$dest or croak "Can't chdir to $dest\: $!"}my$self=bless {_pushd=>$dest,_original=>$orig },__PACKAGE__;return$self}sub tempd {my ($options)=@_;my$dir;eval {$dir=pushd(File::Temp::tempdir(CLEANUP=>0),$options)};croak $@ if $@;$dir->{_tempd}=1;return$dir}sub preserve {my$self=shift;return 1 if!$self->{"_tempd"};if (@_==0){return$self->{_preserve}=1}else {return$self->{_preserve}=$_[0]? 1 : 0}}sub DESTROY {my ($self)=@_;my$orig=$self->{_original};chdir$orig if$orig;if ($self->{_tempd}&&!$self->{_preserve}){my$err=do {local $@;eval {rmtree($self->{_pushd})};$@};carp$err if$err}}1; FILE_PUSHD $fatpacked{"HTTP/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_TINY'; package HTTP::Tiny;use strict;use warnings;our$VERSION='0.056';use Carp ();my@attributes;BEGIN {@attributes=qw(cookie_jar default_headers http_proxy https_proxy keep_alive local_address max_redirect max_size proxy no_proxy timeout SSL_options verify_SSL);my%persist_ok=map {;$_=>1}qw(cookie_jar default_headers max_redirect max_size);no strict 'refs';no warnings 'uninitialized';for my$accessor (@attributes){*{$accessor}=sub {@_ > 1 ? do {delete $_[0]->{handle}if!$persist_ok{$accessor}&& $_[1]ne $_[0]->{$accessor};$_[0]->{$accessor}=$_[1]}: $_[0]->{$accessor}}}}sub agent {my($self,$agent)=@_;if(@_ > 1){$self->{agent}=(defined$agent && $agent =~ / $/)? $agent .$self->_agent : $agent}return$self->{agent}}sub new {my($class,%args)=@_;my$self={max_redirect=>5,timeout=>60,keep_alive=>1,verify_SSL=>$args{verify_SSL}|| $args{verify_ssl}|| 0,no_proxy=>$ENV{no_proxy},};bless$self,$class;$class->_validate_cookie_jar($args{cookie_jar})if$args{cookie_jar};for my$key (@attributes){$self->{$key}=$args{$key}if exists$args{$key}}$self->agent(exists$args{agent}? $args{agent}: $class->_agent);$self->_set_proxies;return$self}sub _set_proxies {my ($self)=@_;if (!exists$self->{proxy}){$self->{proxy}=$ENV{all_proxy}|| $ENV{ALL_PROXY}}if (defined$self->{proxy}){$self->_split_proxy('generic proxy'=>$self->{proxy})}else {delete$self->{proxy}}if (!exists$self->{http_proxy}){local$ENV{HTTP_PROXY}if$ENV{REQUEST_METHOD};$self->{http_proxy}=$ENV{http_proxy}|| $ENV{HTTP_PROXY}|| $self->{proxy}}if (defined$self->{http_proxy}){$self->_split_proxy(http_proxy=>$self->{http_proxy});$self->{_has_proxy}{http}=1}else {delete$self->{http_proxy}}if (!exists$self->{https_proxy}){$self->{https_proxy}=$ENV{https_proxy}|| $ENV{HTTPS_PROXY}|| $self->{proxy}}if ($self->{https_proxy}){$self->_split_proxy(https_proxy=>$self->{https_proxy});$self->{_has_proxy}{https}=1}else {delete$self->{https_proxy}}unless (ref$self->{no_proxy}eq 'ARRAY'){$self->{no_proxy}=(defined$self->{no_proxy})? [split /\s*,\s*/,$self->{no_proxy}]: []}return}for my$sub_name (qw/get head put post delete/){my$req_method=uc$sub_name;no strict 'refs';eval <<"HERE"}sub post_form {my ($self,$url,$data,$args)=@_;(@_==3 || @_==4 && ref$args eq 'HASH')or Carp::croak(q/Usage: $http->post_form(URL, DATAREF, [HASHREF])/ ."\n");my$headers={};while (my ($key,$value)=each %{$args->{headers}|| {}}){$headers->{lc$key}=$value}delete$args->{headers};return$self->request('POST',$url,{%$args,content=>$self->www_form_urlencode($data),headers=>{%$headers,'content-type'=>'application/x-www-form-urlencoded' },})}sub mirror {my ($self,$url,$file,$args)=@_;@_==3 || (@_==4 && ref$args eq 'HASH')or Carp::croak(q/Usage: $http->mirror(URL, FILE, [HASHREF])/ ."\n");if (-e $file and my$mtime=(stat($file))[9]){$args->{headers}{'if-modified-since'}||= $self->_http_date($mtime)}my$tempfile=$file .int(rand(2**31));require Fcntl;sysopen my$fh,$tempfile,Fcntl::O_CREAT()|Fcntl::O_EXCL()|Fcntl::O_WRONLY()or Carp::croak(qq/Error: Could not create temporary file $tempfile for downloading: $!\n/);binmode$fh;$args->{data_callback}=sub {print {$fh}$_[0]};my$response=$self->request('GET',$url,$args);close$fh or Carp::croak(qq/Error: Caught error closing temporary file $tempfile: $!\n/);if ($response->{success}){rename$tempfile,$file or Carp::croak(qq/Error replacing $file with $tempfile: $!\n/);my$lm=$response->{headers}{'last-modified'};if ($lm and my$mtime=$self->_parse_http_date($lm)){utime$mtime,$mtime,$file}}$response->{success}||= $response->{status}eq '304';unlink$tempfile;return$response}my%idempotent=map {$_=>1}qw/GET HEAD PUT DELETE OPTIONS TRACE/;sub request {my ($self,$method,$url,$args)=@_;@_==3 || (@_==4 && ref$args eq 'HASH')or Carp::croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/ ."\n");$args ||= {};my$response;for (0 .. 1){$response=eval {$self->_request($method,$url,$args)};last unless $@ && $idempotent{$method}&& $@ =~ m{^(?:Socket closed|Unexpected end)}}if (my$e=$@){if (ref$e eq 'HASH' && exists$e->{status}){return$e}$e="$e";$response={url=>$url,success=>q{},status=>599,reason=>'Internal Exception',content=>$e,headers=>{'content-type'=>'text/plain','content-length'=>length$e,}}}return$response}sub www_form_urlencode {my ($self,$data)=@_;(@_==2 && ref$data)or Carp::croak(q/Usage: $http->www_form_urlencode(DATAREF)/ ."\n");(ref$data eq 'HASH' || ref$data eq 'ARRAY')or Carp::croak("form data must be a hash or array reference\n");my@params=ref$data eq 'HASH' ? %$data : @$data;@params % 2==0 or Carp::croak("form data reference must have an even number of terms\n");my@terms;while(@params){my ($key,$value)=splice(@params,0,2);if (ref$value eq 'ARRAY'){unshift@params,map {$key=>$_}@$value}else {push@terms,join("=",map {$self->_uri_escape($_)}$key,$value)}}return join("&",(ref$data eq 'ARRAY')? (@terms): (sort@terms))}sub can_ssl {my ($self)=@_;my($ok,$reason)=(1,'');unless (eval {require IO::Socket::SSL;IO::Socket::SSL->VERSION(1.42)}){$ok=0;$reason .= qq/IO::Socket::SSL 1.42 must be installed for https support\n/}unless (eval {require Net::SSLeay;Net::SSLeay->VERSION(1.49)}){$ok=0;$reason .= qq/Net::SSLeay 1.49 must be installed for https support\n/}if (ref($self)&& ($self->{verify_SSL}|| $self->{SSL_options}{SSL_verify_mode})){my$handle=HTTP::Tiny::Handle->new(SSL_options=>$self->{SSL_options},verify_SSL=>$self->{verify_SSL},);unless (eval {$handle->_find_CA_file;1}){$ok=0;$reason .= "$@"}}wantarray ? ($ok,$reason): $ok}my%DefaultPort=(http=>80,https=>443,);sub _agent {my$class=ref($_[0])|| $_[0];(my$default_agent=$class)=~ s{::}{-}g;return$default_agent ."/" .$class->VERSION}sub _request {my ($self,$method,$url,$args)=@_;my ($scheme,$host,$port,$path_query,$auth)=$self->_split_url($url);my$request={method=>$method,scheme=>$scheme,host=>$host,port=>$port,host_port=>($port==$DefaultPort{$scheme}? $host : "$host:$port"),uri=>$path_query,headers=>{},};my$handle=delete$self->{handle};if ($handle){unless ($handle->can_reuse($scheme,$host,$port)){$handle->close;undef$handle}}$handle ||= $self->_open_handle($request,$scheme,$host,$port);$self->_prepare_headers_and_cb($request,$args,$url,$auth);$handle->write_request($request);my$response;do {$response=$handle->read_response_header}until (substr($response->{status},0,1)ne '1');$self->_update_cookie_jar($url,$response)if$self->{cookie_jar};if (my@redir_args=$self->_maybe_redirect($request,$response,$args)){$handle->close;return$self->_request(@redir_args,$args)}my$known_message_length;if ($method eq 'HEAD' || $response->{status}=~ /^[23]04/){$known_message_length=1}else {my$data_cb=$self->_prepare_data_cb($response,$args);$known_message_length=$handle->read_body($data_cb,$response)}if ($self->{keep_alive}&& $known_message_length && $response->{protocol}eq 'HTTP/1.1' && ($response->{headers}{connection}|| '')ne 'close'){$self->{handle}=$handle}else {$handle->close}$response->{success}=substr($response->{status},0,1)eq '2';$response->{url}=$url;return$response}sub _open_handle {my ($self,$request,$scheme,$host,$port)=@_;my$handle=HTTP::Tiny::Handle->new(timeout=>$self->{timeout},SSL_options=>$self->{SSL_options},verify_SSL=>$self->{verify_SSL},local_address=>$self->{local_address},keep_alive=>$self->{keep_alive});if ($self->{_has_proxy}{$scheme}&&!grep {$host =~ /\Q$_\E$/}@{$self->{no_proxy}}){return$self->_proxy_connect($request,$handle)}else {return$handle->connect($scheme,$host,$port)}}sub _proxy_connect {my ($self,$request,$handle)=@_;my@proxy_vars;if ($request->{scheme}eq 'https'){Carp::croak(qq{No https_proxy defined})unless$self->{https_proxy};@proxy_vars=$self->_split_proxy(https_proxy=>$self->{https_proxy});if ($proxy_vars[0]eq 'https'){Carp::croak(qq{Can't proxy https over https: $request->{uri} via $self->{https_proxy}})}}else {Carp::croak(qq{No http_proxy defined})unless$self->{http_proxy};@proxy_vars=$self->_split_proxy(http_proxy=>$self->{http_proxy})}my ($p_scheme,$p_host,$p_port,$p_auth)=@proxy_vars;if (length$p_auth &&!defined$request->{headers}{'proxy-authorization'}){$self->_add_basic_auth_header($request,'proxy-authorization'=>$p_auth)}$handle->connect($p_scheme,$p_host,$p_port);if ($request->{scheme}eq 'https'){$self->_create_proxy_tunnel($request,$handle)}else {$request->{uri}="$request->{scheme}://$request->{host_port}$request->{uri}"}return$handle}sub _split_proxy {my ($self,$type,$proxy)=@_;my ($scheme,$host,$port,$path_query,$auth)=eval {$self->_split_url($proxy)};unless(defined($scheme)&& length($scheme)&& length($host)&& length($port)&& $path_query eq '/'){Carp::croak(qq{$type URL must be in format http[s]://[auth@]<host>:<port>/\n})}return ($scheme,$host,$port,$auth)}sub _create_proxy_tunnel {my ($self,$request,$handle)=@_;$handle->_assert_ssl;my$agent=exists($request->{headers}{'user-agent'})? $request->{headers}{'user-agent'}: $self->{agent};my$connect_request={method=>'CONNECT',uri=>"$request->{host}:$request->{port}",headers=>{host=>"$request->{host}:$request->{port}",'user-agent'=>$agent,}};if ($request->{headers}{'proxy-authorization'}){$connect_request->{headers}{'proxy-authorization'}=delete$request->{headers}{'proxy-authorization'}}$handle->write_request($connect_request);my$response;do {$response=$handle->read_response_header}until (substr($response->{status},0,1)ne '1');unless (substr($response->{status},0,1)eq '2'){die$response}$handle->start_ssl($request->{host});return}sub _prepare_headers_and_cb {my ($self,$request,$args,$url,$auth)=@_;for ($self->{default_headers},$args->{headers}){next unless defined;while (my ($k,$v)=each %$_){$request->{headers}{lc$k}=$v}}if (exists$request->{headers}{'host'}){die(qq/The 'Host' header must not be provided as header option\n/)}$request->{headers}{'host'}=$request->{host_port};$request->{headers}{'user-agent'}||= $self->{agent};$request->{headers}{'connection'}="close" unless$self->{keep_alive};if (defined$args->{content}){if (ref$args->{content}eq 'CODE'){$request->{headers}{'content-type'}||= "application/octet-stream";$request->{headers}{'transfer-encoding'}='chunked' unless$request->{headers}{'content-length'}|| $request->{headers}{'transfer-encoding'};$request->{cb}=$args->{content}}elsif (length$args->{content}){my$content=$args->{content};if ($] ge '5.008'){utf8::downgrade($content,1)or die(qq/Wide character in request message body\n/)}$request->{headers}{'content-type'}||= "application/octet-stream";$request->{headers}{'content-length'}=length$content unless$request->{headers}{'content-length'}|| $request->{headers}{'transfer-encoding'};$request->{cb}=sub {substr$content,0,length$content,''}}$request->{trailer_cb}=$args->{trailer_callback}if ref$args->{trailer_callback}eq 'CODE'}if ($self->{cookie_jar}){my$cookies=$self->cookie_jar->cookie_header($url);$request->{headers}{cookie}=$cookies if length$cookies}if (length$auth &&!defined$request->{headers}{authorization}){$self->_add_basic_auth_header($request,'authorization'=>$auth)}return}sub _add_basic_auth_header {my ($self,$request,$header,$auth)=@_;require MIME::Base64;$request->{headers}{$header}="Basic " .MIME::Base64::encode_base64($auth,"");return}sub _prepare_data_cb {my ($self,$response,$args)=@_;my$data_cb=$args->{data_callback};$response->{content}='';if (!$data_cb || $response->{status}!~ /^2/){if (defined$self->{max_size}){$data_cb=sub {$_[1]->{content}.= $_[0];die(qq/Size of response body exceeds the maximum allowed of $self->{max_size}\n/)if length $_[1]->{content}> $self->{max_size}}}else {$data_cb=sub {$_[1]->{content}.= $_[0]}}}return$data_cb}sub _update_cookie_jar {my ($self,$url,$response)=@_;my$cookies=$response->{headers}->{'set-cookie'};return unless defined$cookies;my@cookies=ref$cookies ? @$cookies : $cookies;$self->cookie_jar->add($url,$_)for@cookies;return}sub _validate_cookie_jar {my ($class,$jar)=@_;for my$method (qw/add cookie_header/){Carp::croak(qq/Cookie jar must provide the '$method' method\n/)unless ref($jar)&& ref($jar)->can($method)}return}sub _maybe_redirect {my ($self,$request,$response,$args)=@_;my$headers=$response->{headers};my ($status,$method)=($response->{status},$request->{method});if (($status eq '303' or ($status =~ /^30[1278]/ && $method =~ /^GET|HEAD$/))and $headers->{location}and ++$args->{redirects}<= $self->{max_redirect}){my$location=($headers->{location}=~ /^\//)? "$request->{scheme}://$request->{host_port}$headers->{location}" : $headers->{location};return (($status eq '303' ? 'GET' : $method),$location)}return}sub _split_url {my$url=pop;my ($scheme,$host,$path_query)=$url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)> or die(qq/Cannot parse URL: '$url'\n/);$scheme=lc$scheme;$path_query="/$path_query" unless$path_query =~ m<\A/>;my$auth='';if ((my$i=index$host,'@')!=-1){$auth=substr$host,0,$i,'';substr$host,0,1,'';$auth =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg}my$port=$host =~ s/:(\d*)\z// && length $1 ? $1 : $scheme eq 'http' ? 80 : $scheme eq 'https' ? 443 : undef;return ($scheme,(length$host ? lc$host : "localhost"),$port,$path_query,$auth)}my$DoW="Sun|Mon|Tue|Wed|Thu|Fri|Sat";my$MoY="Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec";sub _http_date {my ($sec,$min,$hour,$mday,$mon,$year,$wday)=gmtime($_[1]);return sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT",substr($DoW,$wday*4,3),$mday,substr($MoY,$mon*4,3),$year+1900,$hour,$min,$sec)}sub _parse_http_date {my ($self,$str)=@_;require Time::Local;my@tl_parts;if ($str =~ /^[SMTWF][a-z]+, +(\d{1,2}) ($MoY) +(\d\d\d\d) +(\d\d):(\d\d):(\d\d) +GMT$/){@tl_parts=($6,$5,$4,$1,(index($MoY,$2)/4),$3)}elsif ($str =~ /^[SMTWF][a-z]+, +(\d\d)-($MoY)-(\d{2,4}) +(\d\d):(\d\d):(\d\d) +GMT$/){@tl_parts=($6,$5,$4,$1,(index($MoY,$2)/4),$3)}elsif ($str =~ /^[SMTWF][a-z]+ +($MoY) +(\d{1,2}) +(\d\d):(\d\d):(\d\d) +(?:[^0-9]+ +)?(\d\d\d\d)$/){@tl_parts=($5,$4,$3,$2,(index($MoY,$1)/4),$6)}return eval {my$t=@tl_parts ? Time::Local::timegm(@tl_parts): -1;$t < 0 ? undef : $t}}my%escapes=map {chr($_)=>sprintf("%%%02X",$_)}0..255;$escapes{' '}="+";my$unsafe_char=qr/[^A-Za-z0-9\-\._~]/;sub _uri_escape {my ($self,$str)=@_;if ($] ge '5.008'){utf8::encode($str)}else {$str=pack("U*",unpack("C*",$str))if (length$str==do {use bytes;length$str});$str=pack("C*",unpack("C*",$str))}$str =~ s/($unsafe_char)/$escapes{$1}/ge;return$str}package HTTP::Tiny::Handle;use strict;use warnings;use Errno qw[EINTR EPIPE];use IO::Socket qw[SOCK_STREAM];my$SOCKET_CLASS=$ENV{PERL_HTTP_TINY_IPV4_ONLY}? 'IO::Socket::INET' : eval {require IO::Socket::IP;IO::Socket::IP->VERSION(0.25)}? 'IO::Socket::IP' : 'IO::Socket::INET';sub BUFSIZE () {32768}my$Printable=sub {local $_=shift;s/\r/\\r/g;s/\n/\\n/g;s/\t/\\t/g;s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;$_};my$Token=qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;sub new {my ($class,%args)=@_;return bless {rbuf=>'',timeout=>60,max_line_size=>16384,max_header_lines=>64,verify_SSL=>0,SSL_options=>{},%args },$class}sub connect {@_==4 || die(q/Usage: $handle->connect(scheme, host, port)/ ."\n");my ($self,$scheme,$host,$port)=@_;if ($scheme eq 'https'){$self->_assert_ssl}elsif ($scheme ne 'http'){die(qq/Unsupported URL scheme '$scheme'\n/)}$self->{fh}=$SOCKET_CLASS->new(PeerHost=>$host,PeerPort=>$port,$self->{local_address}? (LocalAddr=>$self->{local_address}): (),Proto=>'tcp',Type=>SOCK_STREAM,Timeout=>$self->{timeout},KeepAlive=>!!$self->{keep_alive})or die(qq/Could not connect to '$host:$port': $@\n/);binmode($self->{fh})or die(qq/Could not binmode() socket: '$!'\n/);$self->start_ssl($host)if$scheme eq 'https';$self->{scheme}=$scheme;$self->{host}=$host;$self->{port}=$port;$self->{pid}=$$;$self->{tid}=_get_tid();return$self}sub start_ssl {my ($self,$host)=@_;if (ref($self->{fh})eq 'IO::Socket::SSL'){unless ($self->{fh}->stop_SSL){my$ssl_err=IO::Socket::SSL->errstr;die(qq/Error halting prior SSL connection: $ssl_err/)}}my$ssl_args=$self->_ssl_args($host);IO::Socket::SSL->start_SSL($self->{fh},%$ssl_args,SSL_create_ctx_callback=>sub {my$ctx=shift;Net::SSLeay::CTX_set_mode($ctx,Net::SSLeay::MODE_AUTO_RETRY())},);unless (ref($self->{fh})eq 'IO::Socket::SSL'){my$ssl_err=IO::Socket::SSL->errstr;die(qq/SSL connection failed for $host: $ssl_err\n/)}}sub close {@_==1 || die(q/Usage: $handle->close()/ ."\n");my ($self)=@_;CORE::close($self->{fh})or die(qq/Could not close socket: '$!'\n/)}sub write {@_==2 || die(q/Usage: $handle->write(buf)/ ."\n");my ($self,$buf)=@_;if ($] ge '5.008'){utf8::downgrade($buf,1)or die(qq/Wide character in write()\n/)}my$len=length$buf;my$off=0;local$SIG{PIPE}='IGNORE';while (){$self->can_write or die(qq/Timed out while waiting for socket to become ready for writing\n/);my$r=syswrite($self->{fh},$buf,$len,$off);if (defined$r){$len -= $r;$off += $r;last unless$len > 0}elsif ($!==EPIPE){die(qq/Socket closed by remote server: $!\n/)}elsif ($!!=EINTR){if ($self->{fh}->can('errstr')){my$err=$self->{fh}->errstr();die (qq/Could not write to SSL socket: '$err'\n /)}else {die(qq/Could not write to socket: '$!'\n/)}}}return$off}sub read {@_==2 || @_==3 || die(q/Usage: $handle->read(len [, allow_partial])/ ."\n");my ($self,$len,$allow_partial)=@_;my$buf='';my$got=length$self->{rbuf};if ($got){my$take=($got < $len)? $got : $len;$buf=substr($self->{rbuf},0,$take,'');$len -= $take}while ($len > 0){$self->can_read or die(q/Timed out while waiting for socket to become ready for reading/ ."\n");my$r=sysread($self->{fh},$buf,$len,length$buf);if (defined$r){last unless$r;$len -= $r}elsif ($!!=EINTR){if ($self->{fh}->can('errstr')){my$err=$self->{fh}->errstr();die (qq/Could not read from SSL socket: '$err'\n /)}else {die(qq/Could not read from socket: '$!'\n/)}}}if ($len &&!$allow_partial){die(qq/Unexpected end of stream\n/)}return$buf}sub readline {@_==1 || die(q/Usage: $handle->readline()/ ."\n");my ($self)=@_;while (){if ($self->{rbuf}=~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x){return $1}if (length$self->{rbuf}>= $self->{max_line_size}){die(qq/Line size exceeds the maximum allowed size of $self->{max_line_size}\n/)}$self->can_read or die(qq/Timed out while waiting for socket to become ready for reading\n/);my$r=sysread($self->{fh},$self->{rbuf},BUFSIZE,length$self->{rbuf});if (defined$r){last unless$r}elsif ($!!=EINTR){if ($self->{fh}->can('errstr')){my$err=$self->{fh}->errstr();die (qq/Could not read from SSL socket: '$err'\n /)}else {die(qq/Could not read from socket: '$!'\n/)}}}die(qq/Unexpected end of stream while looking for line\n/)}sub read_header_lines {@_==1 || @_==2 || die(q/Usage: $handle->read_header_lines([headers])/ ."\n");my ($self,$headers)=@_;$headers ||= {};my$lines=0;my$val;while (){my$line=$self->readline;if (++$lines >= $self->{max_header_lines}){die(qq/Header lines exceeds maximum number allowed of $self->{max_header_lines}\n/)}elsif ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x){my ($field_name)=lc $1;if (exists$headers->{$field_name}){for ($headers->{$field_name}){$_=[$_]unless ref $_ eq "ARRAY";push @$_,$2;$val=\$_->[-1]}}else {$val=\($headers->{$field_name}=$2)}}elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x){$val or die(qq/Unexpected header continuation line\n/);next unless length $1;$$val .= ' ' if length $$val;$$val .= $1}elsif ($line =~ /\A \x0D?\x0A \z/x){last}else {die(q/Malformed header line: / .$Printable->($line)."\n")}}return$headers}sub write_request {@_==2 || die(q/Usage: $handle->write_request(request)/ ."\n");my($self,$request)=@_;$self->write_request_header(@{$request}{qw/method uri headers/});$self->write_body($request)if$request->{cb};return}my%HeaderCase=('content-md5'=>'Content-MD5','etag'=>'ETag','te'=>'TE','www-authenticate'=>'WWW-Authenticate','x-xss-protection'=>'X-XSS-Protection',);sub write_header_lines {(@_==2 || @_==3 && ref $_[1]eq 'HASH')|| die(q/Usage: $handle->write_header_lines(headers[,prefix])/ ."\n");my($self,$headers,$prefix_data)=@_;my$buf=(defined$prefix_data ? $prefix_data : '');while (my ($k,$v)=each %$headers){my$field_name=lc$k;if (exists$HeaderCase{$field_name}){$field_name=$HeaderCase{$field_name}}else {$field_name =~ /\A $Token+ \z/xo or die(q/Invalid HTTP header field name: / .$Printable->($field_name)."\n");$field_name =~ s/\b(\w)/\u$1/g;$HeaderCase{lc$field_name}=$field_name}for (ref$v eq 'ARRAY' ? @$v : $v){$_='' unless defined $_;$buf .= "$field_name: $_\x0D\x0A"}}$buf .= "\x0D\x0A";return$self->write($buf)}sub read_body {@_==3 || die(q/Usage: $handle->read_body(callback, response)/ ."\n");my ($self,$cb,$response)=@_;my$te=$response->{headers}{'transfer-encoding'}|| '';my$chunked=grep {/chunked/i}(ref$te eq 'ARRAY' ? @$te : $te);return$chunked ? $self->read_chunked_body($cb,$response): $self->read_content_body($cb,$response)}sub write_body {@_==2 || die(q/Usage: $handle->write_body(request)/ ."\n");my ($self,$request)=@_;if ($request->{headers}{'content-length'}){return$self->write_content_body($request)}else {return$self->write_chunked_body($request)}}sub read_content_body {@_==3 || @_==4 || die(q/Usage: $handle->read_content_body(callback, response, [read_length])/ ."\n");my ($self,$cb,$response,$content_length)=@_;$content_length ||= $response->{headers}{'content-length'};if (defined$content_length){my$len=$content_length;while ($len > 0){my$read=($len > BUFSIZE)? BUFSIZE : $len;$cb->($self->read($read,0),$response);$len -= $read}return length($self->{rbuf})==0}my$chunk;$cb->($chunk,$response)while length($chunk=$self->read(BUFSIZE,1));return}sub write_content_body {@_==2 || die(q/Usage: $handle->write_content_body(request)/ ."\n");my ($self,$request)=@_;my ($len,$content_length)=(0,$request->{headers}{'content-length'});while (){my$data=$request->{cb}->();defined$data && length$data or last;if ($] ge '5.008'){utf8::downgrade($data,1)or die(qq/Wide character in write_content()\n/)}$len += $self->write($data)}$len==$content_length or die(qq/Content-Length mismatch (got: $len expected: $content_length)\n/);return$len}sub read_chunked_body {@_==3 || die(q/Usage: $handle->read_chunked_body(callback, $response)/ ."\n");my ($self,$cb,$response)=@_;while (){my$head=$self->readline;$head =~ /\A ([A-Fa-f0-9]+)/x or die(q/Malformed chunk head: / .$Printable->($head)."\n");my$len=hex($1)or last;$self->read_content_body($cb,$response,$len);$self->read(2)eq "\x0D\x0A" or die(qq/Malformed chunk: missing CRLF after chunk data\n/)}$self->read_header_lines($response->{headers});return 1}sub write_chunked_body {@_==2 || die(q/Usage: $handle->write_chunked_body(request)/ ."\n");my ($self,$request)=@_;my$len=0;while (){my$data=$request->{cb}->();defined$data && length$data or last;if ($] ge '5.008'){utf8::downgrade($data,1)or die(qq/Wide character in write_chunked_body()\n/)}$len += length$data;my$chunk=sprintf '%X',length$data;$chunk .= "\x0D\x0A";$chunk .= $data;$chunk .= "\x0D\x0A";$self->write($chunk)}$self->write("0\x0D\x0A");$self->write_header_lines($request->{trailer_cb}->())if ref$request->{trailer_cb}eq 'CODE';return$len}sub read_response_header {@_==1 || die(q/Usage: $handle->read_response_header()/ ."\n");my ($self)=@_;my$line=$self->readline;$line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x or die(q/Malformed Status-Line: / .$Printable->($line)."\n");my ($protocol,$version,$status,$reason)=($1,$2,$3,$4);die (qq/Unsupported HTTP protocol: $protocol\n/)unless$version =~ /0*1\.0*[01]/;return {status=>$status,reason=>$reason,headers=>$self->read_header_lines,protocol=>$protocol,}}sub write_request_header {@_==4 || die(q/Usage: $handle->write_request_header(method, request_uri, headers)/ ."\n");my ($self,$method,$request_uri,$headers)=@_;return$self->write_header_lines($headers,"$method $request_uri HTTP/1.1\x0D\x0A")}sub _do_timeout {my ($self,$type,$timeout)=@_;$timeout=$self->{timeout}unless defined$timeout && $timeout >= 0;my$fd=fileno$self->{fh};defined$fd && $fd >= 0 or die(qq/select(2): 'Bad file descriptor'\n/);my$initial=time;my$pending=$timeout;my$nfound;vec(my$fdset='',$fd,1)=1;while (){$nfound=($type eq 'read')? select($fdset,undef,undef,$pending): select(undef,$fdset,undef,$pending);if ($nfound==-1){$!==EINTR or die(qq/select(2): '$!'\n/);redo if!$timeout || ($pending=$timeout - (time - $initial))> 0;$nfound=0}last}$!=0;return$nfound}sub can_read {@_==1 || @_==2 || die(q/Usage: $handle->can_read([timeout])/ ."\n");my$self=shift;if (ref($self->{fh})eq 'IO::Socket::SSL'){return 1 if$self->{fh}->pending}return$self->_do_timeout('read',@_)}sub can_write {@_==1 || @_==2 || die(q/Usage: $handle->can_write([timeout])/ ."\n");my$self=shift;return$self->_do_timeout('write',@_)}sub _assert_ssl {my($ok,$reason)=HTTP::Tiny->can_ssl();die$reason unless$ok}sub can_reuse {my ($self,$scheme,$host,$port)=@_;return 0 if $self->{pid}!=$$ || $self->{tid}!=_get_tid()|| length($self->{rbuf})|| $scheme ne $self->{scheme}|| $host ne $self->{host}|| $port ne $self->{port}|| eval {$self->can_read(0)}|| $@ ;return 1}sub _find_CA_file {my$self=shift();if ($self->{SSL_options}->{SSL_ca_file}){unless (-r $self->{SSL_options}->{SSL_ca_file}){die qq/SSL_ca_file '$self->{SSL_options}->{SSL_ca_file}' not found or not readable\n/}return$self->{SSL_options}->{SSL_ca_file}}return Mozilla::CA::SSL_ca_file()if eval {require Mozilla::CA;1};for my$ca_bundle ("/etc/ssl/certs/ca-certificates.crt","/etc/pki/tls/certs/ca-bundle.crt","/etc/ssl/ca-bundle.pem","/etc/openssl/certs/ca-certificates.crt","/etc/ssl/cert.pem","/usr/local/share/certs/ca-root-nss.crt","/etc/pki/tls/cacert.pem","/etc/certs/ca-certificates.crt",){return$ca_bundle if -e $ca_bundle}die qq/Couldn't find a CA bundle with which to verify the SSL certificate.\n/ .qq/Try installing Mozilla::CA from CPAN\n/}sub _get_tid {no warnings 'reserved';return threads->can("tid")? threads->tid : 0}sub _ssl_args {my ($self,$host)=@_;my%ssl_args;if (Net::SSLeay::OPENSSL_VERSION_NUMBER()>= 0x01000000){$ssl_args{SSL_hostname}=$host,}if ($self->{verify_SSL}){$ssl_args{SSL_verifycn_scheme}='http';$ssl_args{SSL_verifycn_name}=$host;$ssl_args{SSL_verify_mode}=0x01;$ssl_args{SSL_ca_file}=$self->_find_CA_file}else {$ssl_args{SSL_verifycn_scheme}='none';$ssl_args{SSL_verify_mode}=0x00}for my$k (keys %{$self->{SSL_options}}){$ssl_args{$k}=$self->{SSL_options}{$k}if$k =~ m/^SSL_/}return \%ssl_args}1; 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 HTTP_TINY $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP'; package JSON::PP;use 5.005;use strict;use base qw(Exporter);use overload ();use Carp ();use B ();$JSON::PP::VERSION='2.27300';@JSON::PP::EXPORT=qw(encode_json decode_json from_json to_json);use constant P_ASCII=>0;use constant P_LATIN1=>1;use constant P_UTF8=>2;use constant P_INDENT=>3;use constant P_CANONICAL=>4;use constant P_SPACE_BEFORE=>5;use constant P_SPACE_AFTER=>6;use constant P_ALLOW_NONREF=>7;use constant P_SHRINK=>8;use constant P_ALLOW_BLESSED=>9;use constant P_CONVERT_BLESSED=>10;use constant P_RELAXED=>11;use constant P_LOOSE=>12;use constant P_ALLOW_BIGNUM=>13;use constant P_ALLOW_BAREKEY=>14;use constant P_ALLOW_SINGLEQUOTE=>15;use constant P_ESCAPE_SLASH=>16;use constant P_AS_NONBLESSED=>17;use constant P_ALLOW_UNKNOWN=>18;use constant OLD_PERL=>$] < 5.008 ? 1 : 0;BEGIN {my@xs_compati_bit_properties=qw(latin1 ascii utf8 indent canonical space_before space_after allow_nonref shrink allow_blessed convert_blessed relaxed allow_unknown);my@pp_bit_properties=qw(allow_singlequote allow_bignum loose allow_barekey escape_slash as_nonblessed);if ($] < 5.008){my$helper=$] >= 5.006 ? 'JSON::PP::Compat5006' : 'JSON::PP::Compat5005';eval qq| require $helper |;if ($@){Carp::croak $@}}for my$name (@xs_compati_bit_properties,@pp_bit_properties){my$flag_name='P_' .uc($name);eval qq/ 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 : ''; } /}}my%encode_allow_method =map {($_=>1)}qw/utf8 pretty allow_nonref latin1 self_encode escape_slash allow_blessed convert_blessed indent indent_length allow_bignum as_nonblessed/;my%decode_allow_method =map {($_=>1)}qw/utf8 allow_nonref loose allow_singlequote allow_bignum allow_barekey max_size relaxed/;my$JSON;sub encode_json ($) {($JSON ||= __PACKAGE__->new->utf8)->encode(@_)}sub decode_json {($JSON ||= __PACKAGE__->new->utf8)->decode(@_)}sub to_json($) {Carp::croak ("JSON::PP::to_json has been renamed to encode_json.")}sub from_json($) {Carp::croak ("JSON::PP::from_json has been renamed to decode_json.")}sub new {my$class=shift;my$self={max_depth=>512,max_size=>0,indent=>0,FLAGS=>0,fallback=>sub {encode_error('Invalid value. JSON can only reference.')},indent_length=>3,};bless$self,$class}sub encode {return $_[0]->PP_encode_json($_[1])}sub decode {return $_[0]->PP_decode_json($_[1],0x00000000)}sub decode_prefix {return $_[0]->PP_decode_json($_[1],0x00000001)}sub pretty {my ($self,$v)=@_;my$enable=defined$v ? $v : 1;if ($enable){$self->indent(1)->indent_length(3)->space_before(1)->space_after(1)}else {$self->indent(0)->space_before(0)->space_after(0)}$self}sub max_depth {my$max=defined $_[1]? $_[1]: 0x80000000;$_[0]->{max_depth}=$max;$_[0]}sub get_max_depth {$_[0]->{max_depth}}sub max_size {my$max=defined $_[1]? $_[1]: 0;$_[0]->{max_size}=$max;$_[0]}sub get_max_size {$_[0]->{max_size}}sub filter_json_object {$_[0]->{cb_object}=defined $_[1]? $_[1]: 0;$_[0]->{F_HOOK}=($_[0]->{cb_object}or $_[0]->{cb_sk_object})? 1 : 0;$_[0]}sub filter_json_single_key_object {if (@_ > 1){$_[0]->{cb_sk_object}->{$_[1]}=$_[2]}$_[0]->{F_HOOK}=($_[0]->{cb_object}or $_[0]->{cb_sk_object})? 1 : 0;$_[0]}sub indent_length {if (!defined $_[1]or $_[1]> 15 or $_[1]< 0){Carp::carp "The acceptable range of indent_length() is 0 to 15."}else {$_[0]->{indent_length}=$_[1]}$_[0]}sub get_indent_length {$_[0]->{indent_length}}sub sort_by {$_[0]->{sort_by}=defined $_[1]? $_[1]: 1;$_[0]}sub allow_bigint {Carp::carp("allow_bigint() is obsoleted. use allow_bignum() insted.")}{my$max_depth;my$indent;my$ascii;my$latin1;my$utf8;my$space_before;my$space_after;my$canonical;my$allow_blessed;my$convert_blessed;my$indent_length;my$escape_slash;my$bignum;my$as_nonblessed;my$depth;my$indent_count;my$keysort;sub PP_encode_json {my$self=shift;my$obj=shift;$indent_count=0;$depth=0;my$idx=$self->{PROPS};($ascii,$latin1,$utf8,$indent,$canonical,$space_before,$space_after,$allow_blessed,$convert_blessed,$escape_slash,$bignum,$as_nonblessed)=@{$idx}[P_ASCII .. P_SPACE_AFTER,P_ALLOW_BLESSED,P_CONVERT_BLESSED,P_ESCAPE_SLASH,P_ALLOW_BIGNUM,P_AS_NONBLESSED];($max_depth,$indent_length)=@{$self}{qw/max_depth indent_length/};$keysort=$canonical ? sub {$a cmp $b}: undef;if ($self->{sort_by}){$keysort=ref($self->{sort_by})eq 'CODE' ? $self->{sort_by}: $self->{sort_by}=~ /\D+/ ? $self->{sort_by}: sub {$a cmp $b}}encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)")if(!ref$obj and!$idx->[P_ALLOW_NONREF ]);my$str=$self->object_to_json($obj);$str .= "\n" if ($indent);unless ($ascii or $latin1 or $utf8){utf8::upgrade($str)}if ($idx->[P_SHRINK ]){utf8::downgrade($str,1)}return$str}sub object_to_json {my ($self,$obj)=@_;my$type=ref($obj);if($type eq 'HASH'){return$self->hash_to_json($obj)}elsif($type eq 'ARRAY'){return$self->array_to_json($obj)}elsif ($type){if (blessed($obj)){return$self->value_to_json($obj)if ($obj->isa('JSON::PP::Boolean'));if ($convert_blessed and $obj->can('TO_JSON')){my$result=$obj->TO_JSON();if (defined$result and ref($result)){if (refaddr($obj)eq refaddr($result)){encode_error(sprintf("%s::TO_JSON method returned same object as was passed instead of a new one",ref$obj))}}return$self->object_to_json($result)}return "$obj" if ($bignum and _is_bignum($obj));return$self->blessed_to_json($obj)if ($allow_blessed and $as_nonblessed);encode_error(sprintf("encountered object '%s', but neither allow_blessed " ."nor convert_blessed settings are enabled",$obj))unless ($allow_blessed);return 'null'}else {return$self->value_to_json($obj)}}else{return$self->value_to_json($obj)}}sub hash_to_json {my ($self,$obj)=@_;my@res;encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")if (++$depth > $max_depth);my ($pre,$post)=$indent ? $self->_up_indent(): ('','');my$del=($space_before ? ' ' : '').':' .($space_after ? ' ' : '');for my$k (_sort($obj)){if (OLD_PERL){utf8::decode($k)}push@res,string_to_json($self,$k).$del .($self->object_to_json($obj->{$k})|| $self->value_to_json($obj->{$k}))}--$depth;$self->_down_indent()if ($indent);return '{' .(@res ? $pre : '').(@res ? join(",$pre",@res).$post : '').'}'}sub array_to_json {my ($self,$obj)=@_;my@res;encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")if (++$depth > $max_depth);my ($pre,$post)=$indent ? $self->_up_indent(): ('','');for my$v (@$obj){push@res,$self->object_to_json($v)|| $self->value_to_json($v)}--$depth;$self->_down_indent()if ($indent);return '[' .(@res ? $pre : '').(@res ? join(",$pre",@res).$post : '').']'}sub value_to_json {my ($self,$value)=@_;return 'null' if(!defined$value);my$b_obj=B::svref_2object(\$value);my$flags=$b_obj->FLAGS;return$value if$flags & (B::SVp_IOK | B::SVp_NOK)and!($flags & B::SVp_POK);my$type=ref($value);if(!$type){return string_to_json($self,$value)}elsif(blessed($value)and $value->isa('JSON::PP::Boolean')){return $$value==1 ? 'true' : 'false'}elsif ($type){if ((overload::StrVal($value)=~ /=(\w+)/)[0]){return$self->value_to_json("$value")}if ($type eq 'SCALAR' and defined $$value){return $$value eq '1' ? 'true' : $$value eq '0' ? 'false' : $self->{PROPS}->[P_ALLOW_UNKNOWN ]? 'null' : encode_error("cannot encode reference to scalar")}if ($self->{PROPS}->[P_ALLOW_UNKNOWN ]){return 'null'}else {if ($type eq 'SCALAR' or $type eq 'REF'){encode_error("cannot encode reference to scalar")}else {encode_error("encountered $value, but JSON can only represent references to arrays or hashes")}}}else {return$self->{fallback}->($value)if ($self->{fallback}and ref($self->{fallback})eq 'CODE');return 'null'}}my%esc=("\n"=>'\n',"\r"=>'\r',"\t"=>'\t',"\f"=>'\f',"\b"=>'\b',"\""=>'\"',"\\"=>'\\\\',"\'"=>'\\\'',);sub string_to_json {my ($self,$arg)=@_;$arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g;$arg =~ s/\//\\\//g if ($escape_slash);$arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg;if ($ascii){$arg=JSON_PP_encode_ascii($arg)}if ($latin1){$arg=JSON_PP_encode_latin1($arg)}if ($utf8){utf8::encode($arg)}return '"' .$arg .'"'}sub blessed_to_json {my$reftype=reftype($_[1])|| '';if ($reftype eq 'HASH'){return $_[0]->hash_to_json($_[1])}elsif ($reftype eq 'ARRAY'){return $_[0]->array_to_json($_[1])}else {return 'null'}}sub encode_error {my$error=shift;Carp::croak "$error"}sub _sort {defined$keysort ? (sort$keysort (keys %{$_[0]})): keys %{$_[0]}}sub _up_indent {my$self=shift;my$space=' ' x $indent_length;my ($pre,$post)=('','');$post="\n" .$space x $indent_count;$indent_count++;$pre="\n" .$space x $indent_count;return ($pre,$post)}sub _down_indent {$indent_count--}sub PP_encode_box {{depth=>$depth,indent_count=>$indent_count,}}}sub _encode_ascii {join('',map {$_ <= 127 ? chr($_): $_ <= 65535 ? sprintf('\u%04x',$_): sprintf('\u%x\u%x',_encode_surrogates($_))}unpack('U*',$_[0]))}sub _encode_latin1 {join('',map {$_ <= 255 ? chr($_): $_ <= 65535 ? sprintf('\u%04x',$_): sprintf('\u%x\u%x',_encode_surrogates($_))}unpack('U*',$_[0]))}sub _encode_surrogates {my$uni=$_[0]- 0x10000;return ($uni / 0x400 + 0xD800,$uni % 0x400 + 0xDC00)}sub _is_bignum {$_[0]->isa('Math::BigInt')or $_[0]->isa('Math::BigFloat')}my$max_intsize;BEGIN {my$checkint=1111;for my$d (5..64){$checkint .= 1;my$int=eval qq| $checkint |;if ($int =~ /[eE]/){$max_intsize=$d - 1;last}}}{my%escapes=(b=>"\x8",t=>"\x9",n=>"\xA",f=>"\xC",r=>"\xD",'\\'=>'\\','"'=>'"','/'=>'/',);my$text;my$at;my$ch;my$len;my$depth;my$encoding;my$is_valid_utf8;my$utf8_len;my$utf8;my$max_depth;my$max_size;my$relaxed;my$cb_object;my$cb_sk_object;my$F_HOOK;my$allow_bigint;my$singlequote;my$loose;my$allow_barekey;sub PP_decode_json {my ($self,$opt);($self,$text,$opt)=@_;($at,$ch,$depth)=(0,'',0);if (!defined$text or ref$text){decode_error("malformed JSON string, neither array, object, number, string or atom")}my$idx=$self->{PROPS};($utf8,$relaxed,$loose,$allow_bigint,$allow_barekey,$singlequote)=@{$idx}[P_UTF8,P_RELAXED,P_LOOSE .. P_ALLOW_SINGLEQUOTE];if ($utf8){utf8::downgrade($text,1)or Carp::croak("Wide character in subroutine entry")}else {utf8::upgrade($text);utf8::encode($text)}$len=length$text;($max_depth,$max_size,$cb_object,$cb_sk_object,$F_HOOK)=@{$self}{qw/max_depth max_size cb_object cb_sk_object F_HOOK/};if ($max_size > 1){use bytes;my$bytes=length$text;decode_error(sprintf("attempted decode of JSON text of %s bytes size, but max_size is set to %s" ,$bytes,$max_size),1)if ($bytes > $max_size)}my@octets=unpack('C4',$text);$encoding=($octets[0]and $octets[1])? 'UTF-8' : (!$octets[0]and $octets[1])? 'UTF-16BE' : (!$octets[0]and!$octets[1])? 'UTF-32BE' : ($octets[2])? 'UTF-16LE' : (!$octets[2])? 'UTF-32LE' : 'unknown';white();my$valid_start=defined$ch;my$result=value();return undef if (!$result && ($opt & 0x10000000));decode_error("malformed JSON string, neither array, object, number, string or atom")unless$valid_start;if (!$idx->[P_ALLOW_NONREF ]and!ref$result){decode_error('JSON text must be an object or array (but found number, string, true, false or null,' .' use allow_nonref to allow this)',1)}Carp::croak('something wrong.')if$len < $at;my$consumed=defined$ch ? $at - 1 : $at;white();if ($ch){return ($result,$consumed)if ($opt & 0x00000001);decode_error("garbage after JSON object")}($opt & 0x00000001)? ($result,$consumed): $result}sub next_chr {return$ch=undef if($at >= $len);$ch=substr($text,$at++,1)}sub value {white();return if(!defined$ch);return object()if($ch eq '{');return array()if($ch eq '[');return string()if($ch eq '"' or ($singlequote and $ch eq "'"));return number()if($ch =~ /[0-9]/ or $ch eq '-');return word()}sub string {my ($i,$s,$t,$u);my$utf16;my$is_utf8;($is_valid_utf8,$utf8_len)=('',0);$s='';if($ch eq '"' or ($singlequote and $ch eq "'")){my$boundChar=$ch;OUTER: while(defined(next_chr())){if($ch eq $boundChar){next_chr();if ($utf16){decode_error("missing low surrogate character in surrogate pair")}utf8::decode($s)if($is_utf8);return$s}elsif($ch eq '\\'){next_chr();if(exists$escapes{$ch}){$s .= $escapes{$ch}}elsif($ch eq 'u'){my$u='';for(1..4){$ch=next_chr();last OUTER if($ch !~ /[0-9a-fA-F]/);$u .= $ch}if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/){$utf16=$u}elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/){unless (defined$utf16){decode_error("missing high surrogate character in surrogate pair")}$is_utf8=1;$s .= JSON_PP_decode_surrogates($utf16,$u)|| next;$utf16=undef}else {if (defined$utf16){decode_error("surrogate pair expected")}if ((my$hex=hex($u))> 127){$is_utf8=1;$s .= JSON_PP_decode_unicode($u)|| next}else {$s .= chr$hex}}}else{unless ($loose){$at -= 2;decode_error('illegal backslash escape sequence in string')}$s .= $ch}}else{if (ord$ch > 127){unless($ch=is_valid_utf8($ch)){$at -= 1;decode_error("malformed UTF-8 character in JSON string")}else {$at += $utf8_len - 1}$is_utf8=1}if (!$loose){if ($ch =~ /[\x00-\x1f\x22\x5c]/){$at--;decode_error('invalid character encountered while parsing JSON string')}}$s .= $ch}}}decode_error("unexpected end of string while parsing JSON string")}sub white {while(defined$ch){if($ch le ' '){next_chr()}elsif($ch eq '/'){next_chr();if(defined$ch and $ch eq '/'){1 while(defined(next_chr())and $ch ne "\n" and $ch ne "\r")}elsif(defined$ch and $ch eq '*'){next_chr();while(1){if(defined$ch){if($ch eq '*'){if(defined(next_chr())and $ch eq '/'){next_chr();last}}else{next_chr()}}else{decode_error("Unterminated comment")}}next}else{$at--;decode_error("malformed JSON string, neither array, object, number, string or atom")}}else{if ($relaxed and $ch eq '#'){pos($text)=$at;$text =~ /\G([^\n]*(?:\r\n|\r|\n|$))/g;$at=pos($text);next_chr;next}last}}}sub array {my$a=$_[0]|| [];decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')if (++$depth > $max_depth);next_chr();white();if(defined$ch and $ch eq ']'){--$depth;next_chr();return$a}else {while(defined($ch)){push @$a,value();white();if (!defined$ch){last}if($ch eq ']'){--$depth;next_chr();return$a}if($ch ne ','){last}next_chr();white();if ($relaxed and $ch eq ']'){--$depth;next_chr();return$a}}}decode_error(", or ] expected while parsing array")}sub object {my$o=$_[0]|| {};my$k;decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')if (++$depth > $max_depth);next_chr();white();if(defined$ch and $ch eq '}'){--$depth;next_chr();if ($F_HOOK){return _json_object_hook($o)}return$o}else {while (defined$ch){$k=($allow_barekey and $ch ne '"' and $ch ne "'")? bareKey(): string();white();if(!defined$ch or $ch ne ':'){$at--;decode_error("':' expected")}next_chr();$o->{$k}=value();white();last if (!defined$ch);if($ch eq '}'){--$depth;next_chr();if ($F_HOOK){return _json_object_hook($o)}return$o}if($ch ne ','){last}next_chr();white();if ($relaxed and $ch eq '}'){--$depth;next_chr();if ($F_HOOK){return _json_object_hook($o)}return$o}}}$at--;decode_error(", or } expected while parsing object/hash")}sub bareKey {my$key;while($ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){$key .= $ch;next_chr()}return$key}sub word {my$word=substr($text,$at-1,4);if($word eq 'true'){$at += 3;next_chr;return$JSON::PP::true}elsif($word eq 'null'){$at += 3;next_chr;return undef}elsif($word eq 'fals'){$at += 3;if(substr($text,$at,1)eq 'e'){$at++;next_chr;return$JSON::PP::false}}$at--;decode_error("'null' expected")if ($word =~ /^n/);decode_error("'true' expected")if ($word =~ /^t/);decode_error("'false' expected")if ($word =~ /^f/);decode_error("malformed JSON string, neither array, object, number, string or atom")}sub number {my$n='';my$v;if($ch eq '0'){my$peek=substr($text,$at,1);my$hex=$peek =~ /[xX]/;if($hex){decode_error("malformed number (leading zero must not be followed by another digit)");($n)=(substr($text,$at+1)=~ /^([0-9a-fA-F]+)/)}else{($n)=(substr($text,$at)=~ /^([0-7]+)/);if (defined$n and length$n > 1){decode_error("malformed number (leading zero must not be followed by another digit)")}}if(defined$n and length($n)){if (!$hex and length($n)==1){decode_error("malformed number (leading zero must not be followed by another digit)")}$at += length($n)+ $hex;next_chr;return$hex ? hex($n): oct($n)}}if($ch eq '-'){$n='-';next_chr;if (!defined$ch or $ch !~ /\d/){decode_error("malformed number (no digits after initial minus)")}}while(defined$ch and $ch =~ /\d/){$n .= $ch;next_chr}if(defined$ch and $ch eq '.'){$n .= '.';next_chr;if (!defined$ch or $ch !~ /\d/){decode_error("malformed number (no digits after decimal point)")}else {$n .= $ch}while(defined(next_chr)and $ch =~ /\d/){$n .= $ch}}if(defined$ch and ($ch eq 'e' or $ch eq 'E')){$n .= $ch;next_chr;if(defined($ch)and ($ch eq '+' or $ch eq '-')){$n .= $ch;next_chr;if (!defined$ch or $ch =~ /\D/){decode_error("malformed number (no digits after exp sign)")}$n .= $ch}elsif(defined($ch)and $ch =~ /\d/){$n .= $ch}else {decode_error("malformed number (no digits after exp sign)")}while(defined(next_chr)and $ch =~ /\d/){$n .= $ch}}$v .= $n;if ($v !~ /[.eE]/ and length$v > $max_intsize){if ($allow_bigint){require Math::BigInt;return Math::BigInt->new($v)}else {return "$v"}}elsif ($allow_bigint){require Math::BigFloat;return Math::BigFloat->new($v)}return 0+$v}sub is_valid_utf8 {$utf8_len=$_[0]=~ /[\x00-\x7F]/ ? 1 : $_[0]=~ /[\xC2-\xDF]/ ? 2 : $_[0]=~ /[\xE0-\xEF]/ ? 3 : $_[0]=~ /[\xF0-\xF4]/ ? 4 : 0 ;return unless$utf8_len;my$is_valid_utf8=substr($text,$at - 1,$utf8_len);return ($is_valid_utf8 =~ /^(?: [\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*' : 'C*' ;for my$c (unpack($type,$str)){$mess .= $c==0x07 ? '\a' : $c==0x09 ? '\t' : $c==0x0a ? '\n' : $c==0x0d ? '\r' : $c==0x0c ? '\f' : $c < 0x20 ? sprintf('\x{%x}',$c): $c==0x5c ? '\\\\' : $c < 0x80 ? chr($c): sprintf('\x{%x}',$c);if (length$mess >= 20){$mess .= '...';last}}unless (length$mess){$mess='(end of string)'}Carp::croak ($no_rep ? "$error" : "$error, at character offset $at (before \"$mess\")")}sub _json_object_hook {my$o=$_[0];my@ks=keys %{$o};if ($cb_sk_object and @ks==1 and exists$cb_sk_object->{$ks[0]}and ref$cb_sk_object->{$ks[0]}){my@val=$cb_sk_object->{$ks[0]}->($o->{$ks[0]});if (@val==1){return$val[0]}}my@val=$cb_object->($o)if ($cb_object);if (@val==0 or @val > 1){return$o}else {return$val[0]}}sub PP_decode_box {{text=>$text,at=>$at,ch=>$ch,len=>$len,depth=>$depth,encoding=>$encoding,is_valid_utf8=>$is_valid_utf8,}}}sub _decode_surrogates {my$uni=0x10000 + (hex($_[0])- 0xD800)* 0x400 + (hex($_[1])- 0xDC00);my$un=pack('U*',$uni);utf8::encode($un);return$un}sub _decode_unicode {my$un=pack('U',hex shift);utf8::encode($un);return$un}BEGIN {unless (defined&utf8::is_utf8){require Encode;*utf8::is_utf8=*Encode::is_utf8}if ($] >= 5.008){*JSON::PP::JSON_PP_encode_ascii=\&_encode_ascii;*JSON::PP::JSON_PP_encode_latin1=\&_encode_latin1;*JSON::PP::JSON_PP_decode_surrogates=\&_decode_surrogates;*JSON::PP::JSON_PP_decode_unicode=\&_decode_unicode}if ($] >= 5.008 and $] < 5.008003){package JSON::PP;require subs;subs->import('join');eval q| 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)}BEGIN {eval 'require Scalar::Util';unless($@){*JSON::PP::blessed=\&Scalar::Util::blessed;*JSON::PP::reftype=\&Scalar::Util::reftype;*JSON::PP::refaddr=\&Scalar::Util::refaddr}else{eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }';*JSON::PP::blessed=sub {local($@,$SIG{__DIE__},$SIG{__WARN__});ref($_[0])? eval {$_[0]->a_sub_not_likely_to_be_here}: undef};my%tmap=qw(B::NULL SCALAR B::HV HASH B::AV ARRAY B::CV CODE B::IO IO B::GV GLOB B::REGEXP REGEXP);*JSON::PP::reftype=sub {my$r=shift;return undef unless length(ref($r));my$t=ref(B::svref_2object($r));return exists$tmap{$t}? $tmap{$t}: length(ref($$r))? 'REF' : 'SCALAR'};*JSON::PP::refaddr=sub {return undef unless length(ref($_[0]));my$addr;if(defined(my$pkg=blessed($_[0]))){$addr .= bless $_[0],'Scalar::Util::Fake';bless $_[0],$pkg}else {$addr .= $_[0]}$addr =~ /0x(\w+)/;local $^W;hex($1)}}}$JSON::PP::true=do {bless \(my$dummy=1),"JSON::PP::Boolean"};$JSON::PP::false=do {bless \(my$dummy=0),"JSON::PP::Boolean"};sub is_bool {defined $_[0]and UNIVERSAL::isa($_[0],"JSON::PP::Boolean")}sub true {$JSON::PP::true}sub false {$JSON::PP::false}sub null {undef}package JSON::PP::Boolean;use overload ("0+"=>sub {${$_[0]}},"++"=>sub {$_[0]=${$_[0]}+ 1},"--"=>sub {$_[0]=${$_[0]}- 1},fallback=>1,);package JSON::PP::IncrParser;use strict;use constant INCR_M_WS=>0;use constant INCR_M_STR=>1;use constant INCR_M_BS=>2;use constant INCR_M_JSON=>3;use constant INCR_M_C0=>4;use constant INCR_M_C1=>5;$JSON::PP::IncrParser::VERSION='1.01';my$unpack_format=$] < 5.006 ? 'C*' : 'U*';sub new {my ($class)=@_;bless {incr_nest=>0,incr_text=>undef,incr_parsing=>0,incr_p=>0,},$class}sub incr_parse {my ($self,$coder,$text)=@_;$self->{incr_text}='' unless (defined$self->{incr_text});if (defined$text){if (utf8::is_utf8($text)and!utf8::is_utf8($self->{incr_text})){utf8::upgrade($self->{incr_text});utf8::decode($self->{incr_text})}$self->{incr_text}.= $text}my$max_size=$coder->get_max_size;if (defined wantarray){$self->{incr_mode}=INCR_M_WS unless defined$self->{incr_mode};if (wantarray){my@ret;$self->{incr_parsing}=1;do {push@ret,$self->_incr_parse($coder,$self->{incr_text});unless (!$self->{incr_nest}and $self->{incr_mode}==INCR_M_JSON){$self->{incr_mode}=INCR_M_WS if$self->{incr_mode}!=INCR_M_STR}}until (length$self->{incr_text}>= $self->{incr_p});$self->{incr_parsing}=0;return@ret}else {$self->{incr_parsing}=1;my$obj=$self->_incr_parse($coder,$self->{incr_text});$self->{incr_parsing}=0 if defined$obj;return$obj ? $obj : undef}}}sub _incr_parse {my ($self,$coder,$text,$skip)=@_;my$p=$self->{incr_p};my$restore=$p;my@obj;my$len=length$text;if ($self->{incr_mode}==INCR_M_WS){while ($len > $p){my$s=substr($text,$p,1);$p++ and next if (0x20 >= unpack($unpack_format,$s));$self->{incr_mode}=INCR_M_JSON;last}}while ($len > $p){my$s=substr($text,$p++,1);if ($s eq '"'){if (substr($text,$p - 2,1)eq '\\'){next}if ($self->{incr_mode}!=INCR_M_STR){$self->{incr_mode}=INCR_M_STR}else {$self->{incr_mode}=INCR_M_JSON;unless ($self->{incr_nest}){last}}}if ($self->{incr_mode}==INCR_M_JSON){if ($s eq '[' or $s eq '{'){if (++$self->{incr_nest}> $coder->get_max_depth){Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')}}elsif ($s eq ']' or $s eq '}'){last if (--$self->{incr_nest}<= 0)}elsif ($s eq '#'){while ($len > $p){last if substr($text,$p++,1)eq "\n"}}}}$self->{incr_p}=$p;return if ($self->{incr_mode}==INCR_M_STR and not $self->{incr_nest});return if ($self->{incr_mode}==INCR_M_JSON and $self->{incr_nest}> 0);return '' unless (length substr($self->{incr_text},0,$p));local$Carp::CarpLevel=2;$self->{incr_p}=$restore;$self->{incr_c}=$p;my ($obj,$tail)=$coder->PP_decode_json(substr($self->{incr_text},0,$p),0x10000001);$self->{incr_text}=substr($self->{incr_text},$p);$self->{incr_p}=0;return$obj || ''}sub incr_text {if ($_[0]->{incr_parsing}){Carp::croak("incr_text can not be called when the incremental parser already started parsing")}$_[0]->{incr_text}}sub incr_skip {my$self=shift;$self->{incr_text}=substr($self->{incr_text},$self->{incr_c});$self->{incr_p}=0}sub incr_reset {my$self=shift;$self->{incr_text}=undef;$self->{incr_p}=0;$self->{incr_mode}=0;$self->{incr_nest}=0;$self->{incr_parsing}=0}1; JSON_PP $fatpacked{"JSON/PP/Boolean.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP_BOOLEAN'; use JSON::PP ();use strict;1; JSON_PP_BOOLEAN $fatpacked{"Module/CPANfile.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE'; package Module::CPANfile;use strict;use warnings;use Cwd;use Carp ();use Module::CPANfile::Environment;use Module::CPANfile::Requirement;our$VERSION='1.1000';sub new {my($class,$file)=@_;bless {},$class}sub load {my($proto,$file)=@_;my$self=ref$proto ? $proto : $proto->new;$self->parse($file || Cwd::abs_path('cpanfile'));$self}sub save {my($self,$path)=@_;open my$out,">",$path or die "$path: $!";print {$out}$self->to_string}sub parse {my($self,$file)=@_;my$code=do {open my$fh,"<",$file or die "$file: $!";join '',<$fh>};my$env=Module::CPANfile::Environment->new($file);$env->parse($code)or die $@;$self->{_mirrors}=$env->mirrors;$self->{_prereqs}=$env->prereqs}sub from_prereqs {my($proto,$prereqs)=@_;my$self=$proto->new;$self->{_prereqs}=Module::CPANfile::Prereqs->from_cpan_meta($prereqs);$self}sub mirrors {my$self=shift;$self->{_mirrors}|| []}sub features {my$self=shift;map$self->feature($_),$self->{_prereqs}->identifiers}sub feature {my($self,$identifier)=@_;$self->{_prereqs}->feature($identifier)}sub prereq {shift->prereqs}sub prereqs {my$self=shift;$self->{_prereqs}->as_cpan_meta}sub merged_requirements {my$self=shift;$self->{_prereqs}->merged_requirements}sub effective_prereqs {my($self,$features)=@_;$self->prereqs_with(@{$features || []})}sub prereqs_with {my($self,@feature_identifiers)=@_;my$prereqs=$self->prereqs;my@others=map {$self->feature($_)->prereqs}@feature_identifiers;$prereqs->with_merged_prereqs(\@others)}sub prereq_specs {my$self=shift;$self->prereqs->as_string_hash}sub prereq_for_module {my($self,$module)=@_;$self->{_prereqs}->find($module)}sub options_for_module {my($self,$module)=@_;my$prereq=$self->prereq_for_module($module)or return;$prereq->requirement->options}sub merge_meta {my($self,$file,$version)=@_;require CPAN::Meta;$version ||= $file =~ /\.yml$/ ? '1.4' : '2';my$prereq=$self->prereqs;my$meta=CPAN::Meta->load_file($file);my$prereqs_hash=$prereq->with_merged_prereqs($meta->effective_prereqs)->as_string_hash;my$struct={%{$meta->as_struct},prereqs=>$prereqs_hash };CPAN::Meta->new($struct)->save($file,{version=>$version })}sub _dump {my$str=shift;require Data::Dumper;chomp(my$value=Data::Dumper->new([$str])->Terse(1)->Dump);$value}sub to_string {my($self,$include_empty)=@_;my$mirrors=$self->mirrors;my$prereqs=$self->prereq_specs;my$code='';$code .= $self->_dump_mirrors($mirrors);$code .= $self->_dump_prereqs($prereqs,$include_empty);for my$feature ($self->features){$code .= sprintf "feature %s, %s => sub {\n",_dump($feature->{identifier}),_dump($feature->{description});$code .= $self->_dump_prereqs($feature->{spec},$include_empty,4);$code .= "}\n\n"}$code =~ s/\n+$/\n/s;$code}sub _dump_mirrors {my($self,$mirrors)=@_;my$code="";for my$url (@$mirrors){$code .= "mirror '$url';\n"}$code =~ s/\n+$/\n/s;$code}sub _dump_prereqs {my($self,$prereqs,$include_empty,$base_indent)=@_;my$code='';for my$phase (qw(runtime configure build test develop)){my$indent=$phase eq 'runtime' ? '' : ' ';$indent=(' ' x ($base_indent || 0)).$indent;my($phase_code,$requirements);$phase_code .= "on $phase => sub {\n" unless$phase eq 'runtime';for my$type (qw(requires recommends suggests conflicts)){for my$mod (sort keys %{$prereqs->{$phase}{$type}}){my$ver=$prereqs->{$phase}{$type}{$mod};$phase_code .= $ver eq '0' ? "${indent}$type '$mod';\n" : "${indent}$type '$mod', '$ver';\n";$requirements++}}$phase_code .= "\n" unless$requirements;$phase_code .= "};\n" unless$phase eq 'runtime';$code .= $phase_code ."\n" if$requirements or $include_empty}$code =~ s/\n+$/\n/s;$code}1; MODULE_CPANFILE $fatpacked{"Module/CPANfile/Environment.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_ENVIRONMENT'; package Module::CPANfile::Environment;use strict;use warnings;use Module::CPANfile::Prereqs;use Carp ();my@bindings=qw(on requires recommends suggests conflicts feature osname mirror configure_requires build_requires test_requires author_requires);my$file_id=1;sub new {my($class,$file)=@_;bless {file=>$file,phase=>'runtime',feature=>undef,features=>{},prereqs=>Module::CPANfile::Prereqs->new,mirrors=>[],},$class}sub bind {my$self=shift;my$pkg=caller;for my$binding (@bindings){no strict 'refs';*{"$pkg\::$binding"}=sub {$self->$binding(@_)}}}sub parse {my($self,$code)=@_;my$err;{local $@;$file_id++;$self->_evaluate(<<EVAL);$err=$@}if ($err){die "Parsing $self->{file} failed: $err"};return 1}sub _evaluate {my$_environment=$_[0];eval $_[1]}sub prereqs {$_[0]->{prereqs}}sub mirrors {$_[0]->{mirrors}}sub on {my($self,$phase,$code)=@_;local$self->{phase}=$phase;$code->()}sub feature {my($self,$identifier,$description,$code)=@_;if (@_==3 && ref($description)eq 'CODE'){$code=$description;$description=$identifier}unless (ref$description eq '' && ref$code eq 'CODE'){Carp::croak("Usage: feature 'identifier', 'Description' => sub { ... }")}local$self->{feature}=$identifier;$self->prereqs->add_feature($identifier,$description);$code->()}sub osname {die "TODO"}sub mirror {my($self,$url)=@_;push @{$self->{mirrors}},$url}sub requirement_for {my($self,$module,@args)=@_;my$requirement=0;$requirement=shift@args if@args % 2;return Module::CPANfile::Requirement->new(name=>$module,version=>$requirement,@args,)}sub requires {my$self=shift;$self->add_prereq(requires=>@_)}sub recommends {my$self=shift;$self->add_prereq(recommends=>@_)}sub suggests {my$self=shift;$self->add_prereq(suggests=>@_)}sub conflicts {my$self=shift;$self->add_prereq(conflicts=>@_)}sub add_prereq {my($self,$type,$module,@args)=@_;$self->prereqs->add_prereq(feature=>$self->{feature},phase=>$self->{phase},type=>$type,module=>$module,requirement=>$self->requirement_for($module,@args),)}sub configure_requires {my($self,@args)=@_;$self->on(configure=>sub {$self->requires(@args)})}sub build_requires {my($self,@args)=@_;$self->on(build=>sub {$self->requires(@args)})}sub test_requires {my($self,@args)=@_;$self->on(test=>sub {$self->requires(@args)})}sub author_requires {my($self,@args)=@_;$self->on(develop=>sub {$self->requires(@args)})}1; package Module::CPANfile::Sandbox$file_id; no warnings; BEGIN { \$_environment->bind } # line 1 "$self->{file}" $code; EVAL MODULE_CPANFILE_ENVIRONMENT $fatpacked{"Module/CPANfile/Prereq.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_PREREQ'; package Module::CPANfile::Prereq;use strict;sub new {my($class,%options)=@_;bless \%options,$class}sub feature {$_[0]->{feature}}sub phase {$_[0]->{phase}}sub type {$_[0]->{type}}sub module {$_[0]->{module}}sub requirement {$_[0]->{requirement}}sub match_feature {my($self,$identifier)=@_;no warnings 'uninitialized';$self->feature eq $identifier}1; MODULE_CPANFILE_PREREQ $fatpacked{"Module/CPANfile/Prereqs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_PREREQS'; package Module::CPANfile::Prereqs;use strict;use Carp ();use CPAN::Meta::Feature;use Module::CPANfile::Prereq;sub from_cpan_meta {my($class,$prereqs)=@_;my$self=$class->new;for my$phase (keys %$prereqs){for my$type (keys %{$prereqs->{$phase}}){while (my($module,$requirement)=each %{$prereqs->{$phase}{$type}}){$self->add_prereq(phase=>$phase,type=>$type,module=>$module,requirement=>Module::CPANfile::Requirement->new(name=>$module,version=>$requirement),)}}}$self}sub new {my$class=shift;bless {prereqs=>[],features=>{},},$class}sub add_feature {my($self,$identifier,$description)=@_;$self->{features}{$identifier}={description=>$description }}sub add_prereq {my($self,%args)=@_;$self->add(Module::CPANfile::Prereq->new(%args))}sub add {my($self,$prereq)=@_;push @{$self->{prereqs}},$prereq}sub as_cpan_meta {my$self=shift;$self->{cpanmeta}||= $self->build_cpan_meta}sub build_cpan_meta {my($self,$identifier)=@_;my$prereq_spec={};$self->prereq_each($identifier,sub {my$prereq=shift;$prereq_spec->{$prereq->phase}{$prereq->type}{$prereq->module}=$prereq->requirement->version});CPAN::Meta::Prereqs->new($prereq_spec)}sub prereq_each {my($self,$identifier,$code)=@_;for my$prereq (@{$self->{prereqs}}){next unless$prereq->match_feature($identifier);$code->($prereq)}}sub merged_requirements {my$self=shift;my$reqs=CPAN::Meta::Requirements->new;for my$prereq (@{$self->{prereqs}}){$reqs->add_string_requirement($prereq->module,$prereq->requirement->version)}$reqs}sub find {my($self,$module)=@_;for my$prereq (@{$self->{prereqs}}){return$prereq if$prereq->module eq $module}return}sub identifiers {my$self=shift;keys %{$self->{features}}}sub feature {my($self,$identifier)=@_;my$data=$self->{features}{$identifier}or Carp::croak("Unknown feature '$identifier'");my$prereqs=$self->build_cpan_meta($identifier);CPAN::Meta::Feature->new($identifier,{description=>$data->{description},prereqs=>$prereqs->as_string_hash,})}1; MODULE_CPANFILE_PREREQS $fatpacked{"Module/CPANfile/Requirement.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_REQUIREMENT'; package Module::CPANfile::Requirement;use strict;sub new {my ($class,%args)=@_;$args{version}||= 0;bless +{name=>delete$args{name},version=>delete$args{version},options=>\%args,},$class}sub name {$_[0]->{name}}sub version {$_[0]->{version}}sub options {$_[0]->{options}}sub has_options {keys %{$_[0]->{options}}> 0}1; MODULE_CPANFILE_REQUIREMENT $fatpacked{"Module/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_METADATA'; package Module::Metadata;sub __clean_eval {eval $_[0]}use strict;use warnings;our$VERSION='1.000027';use Carp qw/croak/;use File::Spec;BEGIN {eval {require Fcntl;Fcntl->import('SEEK_SET');1}or *SEEK_SET=sub {0}}use version 0.87;BEGIN {if ($INC{'Log/Contextual.pm'}){require "Log/Contextual/WarnLogger.pm";Log::Contextual->import('log_info','-default_logger'=>Log::Contextual::WarnLogger->new({env_prefix=>'MODULE_METADATA',}),)}else {*log_info=sub (&) {warn $_[0]->()}}}use File::Find qw(find);my$V_NUM_REGEXP=qr{v?[0-9._]+};my$PKG_FIRST_WORD_REGEXP=qr{ # the FIRST word in a package name [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 =~ /[=<>!,]/){}elsif (ref$version eq 'version'){$version=$version->is_qv ? $version->normal : $version->stringify}elsif ($version =~ /^[^v][^.]*\.[^.]+\./){$version="v$version"}else {}return$version};my$resolve_module_versions=sub {my$packages=shift;my($file,$version);my$err='';for my$p (@$packages){if (defined($p->{version})){if (defined($version)){if ($compare_versions->($version,'!=',$p->{version})){$err .= " $p->{file} ($p->{version})\n"}else {}}else {$file=$p->{file};$version=$p->{version}}}$file ||= $p->{file}if defined($p->{file})}if ($err){$err=" $file ($version)\n" .$err}my%result=(file=>$file,version=>$version,err=>$err);return \%result};sub provides {my$class=shift;croak "provides() requires key/value pairs \n" if @_ % 2;my%args=@_;croak "provides() takes only one of 'dir' or 'files'\n" if$args{dir}&& $args{files};croak "provides() requires a 'version' argument" unless defined$args{version};croak "provides() does not support version '$args{version}' metadata" unless grep {$args{version}eq $_}qw/1.4 2/;$args{prefix}='lib' unless defined$args{prefix};my$p;if ($args{dir}){$p=$class->package_versions_from_directory($args{dir})}else {croak "provides() requires 'files' to be an array reference\n" unless ref$args{files}eq 'ARRAY';$p=$class->package_versions_from_directory($args{files})}if (length$args{prefix}){$args{prefix}=~ s{/$}{};for my$v (values %$p){$v->{file}="$args{prefix}/$v->{file}"}}return$p}sub package_versions_from_directory {my ($class,$dir,$files)=@_;my@files;if ($files){@files=@$files}else {find({wanted=>sub {push@files,$_ if -f $_ && /\.pm$/},no_chdir=>1,},$dir)}my(%prime,%alt);for my$file (@files){my$mapped_filename=File::Spec::Unix->abs2rel($file,$dir);my@path=split(/\//,$mapped_filename);(my$prime_package=join('::',@path))=~ s/\.pm$//;my$pm_info=$class->new_from_file($file);for my$package ($pm_info->packages_inside){next if$package eq 'main';next if$package eq 'DB';next if grep /^_/,split(/::/,$package);my$version=$pm_info->version($package);$prime_package=$package if lc($prime_package)eq lc($package);if ($package eq $prime_package){if (exists($prime{$package})){croak "Unexpected conflict in '$package'; multiple versions found.\n"}else {$mapped_filename="$package.pm" if lc("$package.pm")eq lc($mapped_filename);$prime{$package}{file}=$mapped_filename;$prime{$package}{version}=$version if defined($version)}}else {push(@{$alt{$package}},{file=>$mapped_filename,version=>$version,})}}}for my$package (keys(%alt)){my$result=$resolve_module_versions->($alt{$package});if (exists($prime{$package})){if ($result->{err}){log_info {"Found conflicting versions for package '$package'\n" ." $prime{$package}{file} ($prime{$package}{version})\n" .$result->{err}}}elsif (defined($result->{version})){if (exists($prime{$package}{version})&& defined($prime{$package}{version})){if ($compare_versions->($prime{$package}{version},'!=',$result->{version})){log_info {"Found conflicting versions for package '$package'\n" ." $prime{$package}{file} ($prime{$package}{version})\n" ." $result->{file} ($result->{version})\n"}}}else {$prime{$package}{file}=$result->{file};$prime{$package}{version}=$result->{version}}}else {}}else {if ($result->{err}){log_info {"Found conflicting versions for package '$package'\n" .$result->{err}}}$prime{$package}{file}=$result->{file};$prime{$package}{version}=$result->{version}if defined($result->{version})}}for (grep defined $_->{version},values%prime){$_->{version}=$normalize_version->($_->{version})}return \%prime}}sub _init {my$class=shift;my$module=shift;my$filename=shift;my%props=@_;my$handle=delete$props{handle};my(%valid_props,@valid_props);@valid_props=qw(collect_pod inc);@valid_props{@valid_props}=delete(@props{@valid_props});warn "Unknown properties: @{[keys %props]}\n" if scalar(%props);my%data=(module=>$module,filename=>$filename,version=>undef,packages=>[],versions=>{},pod=>{},pod_headings=>[],collect_pod=>0,%valid_props,);my$self=bless(\%data,$class);if (not $handle){my$filename=$self->{filename};open$handle,'<',$filename or croak("Can't open '$filename': $!");$self->_handle_bom($handle,$filename)}$self->_parse_fh($handle);unless($self->{module}and length($self->{module})){my ($v,$d,$f)=File::Spec->splitpath($self->{filename});if($f =~ /\.pm$/){$f =~ s/\..+$//;my@candidates=grep /$f$/,@{$self->{packages}};$self->{module}=shift(@candidates)}else {if(grep /main/,@{$self->{packages}}){$self->{module}='main'}else {$self->{module}=$self->{packages}[0]|| ''}}}$self->{version}=$self->{versions}{$self->{module}}if defined($self->{module});return$self}sub _do_find_module {my$class=shift;my$module=shift || croak 'find_module_by_name() requires a package name';my$dirs=shift || \@INC;my$file=File::Spec->catfile(split(/::/,$module));for my$dir (@$dirs){my$testfile=File::Spec->catfile($dir,$file);return [File::Spec->rel2abs($testfile),$dir ]if -e $testfile and!-d _;$testfile .= '.pm';return [File::Spec->rel2abs($testfile),$dir ]if -e $testfile}return}sub find_module_by_name {my$found=shift()->_do_find_module(@_)or return;return$found->[0]}sub find_module_dir_by_name {my$found=shift()->_do_find_module(@_)or return;return$found->[1]}sub _parse_version_expression {my$self=shift;my$line=shift;my($sigil,$variable_name,$package);if ($line =~ /$VERS_REGEXP/o){($sigil,$variable_name,$package)=$2 ? ($1,$2,$3): ($4,$5,$6);if ($package){$package=($package eq '::')? 'main' : $package;$package =~ s/::$//}}return ($sigil,$variable_name,$package)}sub _handle_bom {my ($self,$fh,$filename)=@_;my$pos=tell$fh;return unless defined$pos;my$buf=' ' x 2;my$count=read$fh,$buf,length$buf;return unless defined$count and $count >= 2;my$encoding;if ($buf eq "\x{FE}\x{FF}"){$encoding='UTF-16BE'}elsif ($buf eq "\x{FF}\x{FE}"){$encoding='UTF-16LE'}elsif ($buf eq "\x{EF}\x{BB}"){$buf=' ';$count=read$fh,$buf,length$buf;if (defined$count and $count >= 1 and $buf eq "\x{BF}"){$encoding='UTF-8'}}if (defined$encoding){if ("$]" >= 5.008){binmode($fh,":encoding($encoding)")}}else {seek$fh,$pos,SEEK_SET or croak(sprintf "Can't reset position to the top of '$filename'")}return$encoding}sub _parse_fh {my ($self,$fh)=@_;my($in_pod,$seen_end,$need_vers)=(0,0,0);my(@packages,%vers,%pod,@pod);my$package='main';my$pod_sect='';my$pod_data='';my$in_end=0;while (defined(my$line=<$fh>)){my$line_num=$.;chomp($line);my$is_cut;if ($line =~ /^=([a-zA-Z].*)/){my$cmd=$1;$is_cut=$cmd =~ /^cut(?:[^a-zA-Z]|$)/;$in_pod=!$is_cut}if ($in_pod){if ($line =~ /^=head[1-4]\s+(.+)\s*$/){push(@pod,$1);if ($self->{collect_pod}&& length($pod_data)){$pod{$pod_sect}=$pod_data;$pod_data=''}$pod_sect=$1}elsif ($self->{collect_pod}){$pod_data .= "$line\n"}}elsif ($is_cut){if ($self->{collect_pod}&& length($pod_data)){$pod{$pod_sect}=$pod_data;$pod_data=''}$pod_sect=''}else {next if$in_end;next if$line =~ /^\s*#/;if ($line eq '__END__'){$in_end++;next}last if$line eq '__DATA__';my($version_sigil,$version_fullname,$version_package)=index($line,'VERSION')>= 1 ? $self->_parse_version_expression($line): ();if ($line =~ /$PKG_REGEXP/o){$package=$1;my$version=$2;push(@packages,$package)unless grep($package eq $_,@packages);$need_vers=defined$version ? 0 : 1;if (not exists$vers{$package}and defined$version){my$dwim_version=eval {_dwim_version($version)};croak "Version '$version' from $self->{filename} does not appear to be valid:\n$line\n\nThe fatal error was: $@\n" unless defined$dwim_version;$vers{$package}=$dwim_version}}elsif ($version_fullname && $version_package){push(@packages,$version_package)unless grep($version_package eq $_,@packages);$need_vers=0 if$version_package eq $package;unless (defined$vers{$version_package}&& length$vers{$version_package}){$vers{$version_package}=$self->_evaluate_version_line($version_sigil,$version_fullname,$line)}}elsif ($package eq 'main' && $version_fullname &&!exists($vers{main})){$need_vers=0;my$v=$self->_evaluate_version_line($version_sigil,$version_fullname,$line);$vers{$package}=$v;push(@packages,'main')}elsif ($package eq 'main' &&!exists($vers{main})&& $line =~ /\w/){$need_vers=1;$vers{main}='';push(@packages,'main')}elsif ($version_fullname && $need_vers){$need_vers=0;my$v=$self->_evaluate_version_line($version_sigil,$version_fullname,$line);unless (defined$vers{$package}&& length$vers{$package}){$vers{$package}=$v}}}}if ($self->{collect_pod}&& length($pod_data)){$pod{$pod_sect}=$pod_data}$self->{versions}=\%vers;$self->{packages}=\@packages;$self->{pod}=\%pod;$self->{pod_headings}=\@pod}{my$pn=0;sub _evaluate_version_line {my$self=shift;my($sigil,$variable_name,$line)=@_;$pn++;my$eval=qq{ my \$dummy = q# Hide from _packages_inside() #; package Module::Metadata::_version::p${pn}; use version; sub { local $sigil$variable_name; $line; \$$variable_name }; };$eval=$1 if$eval =~ m{^(.+)}s;local $^W;my$vsub=__clean_eval($eval);if ($@ =~ /Can't locate/ && -d 'lib'){local@INC=('lib',@INC);$vsub=__clean_eval($eval)}warn "Error evaling version line '$eval' in $self->{filename}: $@\n" if $@;(ref($vsub)eq 'CODE')or croak "failed to build version sub for $self->{filename}";my$result=eval {$vsub->()};croak "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n" if $@;my$version=eval {_dwim_version($result)};croak "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n" unless defined$version;return$version}}{my@version_prep=(sub {return shift},sub {my$v=shift;$v =~ s{([0-9])[a-z-].*$}{$1}i;return$v},sub {my$v=shift;my$num_dots=()=$v =~ m{(\.)}g;my$num_unders=()=$v =~ m{(_)}g;my$leading_v=substr($v,0,1)eq 'v';if (!$leading_v && $num_dots < 2 && $num_unders > 1){$v =~ s{_}{}g;$num_unders=()=$v =~ m{(_)}g}return$v},sub {my$v=shift;no warnings 'numeric';return 0 + $v},);sub _dwim_version {my ($result)=shift;return$result if ref($result)eq 'version';my ($version,$error);for my$f (@version_prep){$result=$f->($result);$version=eval {version->new($result)};$error ||= $@ if $@;last if defined$version}croak$error unless defined$version;return$version}}sub name {$_[0]->{module}}sub filename {$_[0]->{filename}}sub packages_inside {@{$_[0]->{packages}}}sub pod_inside {@{$_[0]->{pod_headings}}}sub contains_pod {0+@{$_[0]->{pod_headings}}}sub version {my$self=shift;my$mod=shift || $self->{module};my$vers;if (defined($mod)&& length($mod)&& exists($self->{versions}{$mod})){return$self->{versions}{$mod}}else {return undef}}sub pod {my$self=shift;my$sect=shift;if (defined($sect)&& length($sect)&& exists($self->{pod}{$sect})){return$self->{pod}{$sect}}else {return undef}}sub is_indexable {my ($self,$package)=@_;my@indexable_packages=grep {$_ ne 'main'}$self->packages_inside;return!!grep {$_ eq $package}@indexable_packages if$package;return!!@indexable_packages}1; MODULE_METADATA $fatpacked{"Parse/CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PARSE_CPAN_META'; use 5.008001;use strict;package Parse::CPAN::Meta;our$VERSION='1.4414';use Exporter;use Carp 'croak';our@ISA=qw/Exporter/;our@EXPORT_OK=qw/Load LoadFile/;sub load_file {my ($class,$filename)=@_;my$meta=_slurp($filename);if ($filename =~ /\.ya?ml$/){return$class->load_yaml_string($meta)}elsif ($filename =~ /\.json$/){return$class->load_json_string($meta)}else {$class->load_string($meta)}}sub load_string {my ($class,$string)=@_;if ($string =~ /^---/){return$class->load_yaml_string($string)}elsif ($string =~ /^\s*\{/){return$class->load_json_string($string)}else {return$class->load_yaml_string($string)}}sub load_yaml_string {my ($class,$string)=@_;my$backend=$class->yaml_backend();my$data=eval {no strict 'refs';&{"$backend\::Load"}($string)};croak $@ if $@;return$data || {}}sub load_json_string {my ($class,$string)=@_;my$data=eval {$class->json_backend()->new->decode($string)};croak $@ if $@;return$data || {}}sub yaml_backend {if (!defined$ENV{PERL_YAML_BACKEND}){_can_load('CPAN::Meta::YAML',0.011)or croak "CPAN::Meta::YAML 0.011 is not available\n";return "CPAN::Meta::YAML"}else {my$backend=$ENV{PERL_YAML_BACKEND};_can_load($backend)or croak "Could not load PERL_YAML_BACKEND '$backend'\n";$backend->can("Load")or croak "PERL_YAML_BACKEND '$backend' does not implement Load()\n";return$backend}}sub json_backend {if (!$ENV{PERL_JSON_BACKEND}or $ENV{PERL_JSON_BACKEND}eq 'JSON::PP'){_can_load('JSON::PP'=>2.27103)or croak "JSON::PP 2.27103 is not available\n";return 'JSON::PP'}else {_can_load('JSON'=>2.5)or croak "JSON 2.5 is required for " ."\$ENV{PERL_JSON_BACKEND} = '$ENV{PERL_JSON_BACKEND}'\n";return "JSON"}}sub _slurp {require Encode;open my$fh,"<:raw","$_[0]" or die "can't open $_[0] for reading: $!";my$content=do {local $/;<$fh>};$content=Encode::decode('UTF-8',$content,Encode::PERLQQ());return$content}sub _can_load {my ($module,$version)=@_;(my$file=$module)=~ s{::}{/}g;$file .= ".pm";return 1 if$INC{$file};return 0 if exists$INC{$file};eval {require$file;1}or return 0;if (defined$version){eval {$module->VERSION($version);1}or return 0}return 1}sub LoadFile ($) {return Load(_slurp(shift))}sub Load ($) {require CPAN::Meta::YAML;my$object=eval {CPAN::Meta::YAML::Load(shift)};croak $@ if $@;return$object}1; PARSE_CPAN_META $fatpacked{"Parse/PMFile.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PARSE_PMFILE'; package Parse::PMFile;sub __clean_eval {eval $_[0]}use strict;use warnings;use Safe;use JSON::PP ();use Dumpvalue;use version ();use File::Spec ();our$VERSION='0.36';our$VERBOSE=0;our$ALLOW_DEV_VERSION=0;our$FORK=0;our$UNSAFE=$] < 5.010000 ? 1 : 0;sub new {my ($class,$meta,$opts)=@_;bless {%{$opts || {}},META_CONTENT=>$meta},$class}sub parse {my ($self,$pmfile)=@_;$pmfile =~ s|\\|/|g;my($filemtime)=(stat$pmfile)[9];$self->{MTIME}=$filemtime;$self->{PMFILE}=$pmfile;unless ($self->_version_from_meta_ok){my$version;unless (eval {$version=$self->_parse_version;1}){$self->_verbose(1,"error with version in $pmfile: $@");return}$self->{VERSION}=$version;if ($self->{VERSION}=~ /^\{.*\}$/){}elsif ($self->{VERSION}=~ /[_\s]/ &&!$self->{ALLOW_DEV_VERSION}&&!$ALLOW_DEV_VERSION){return}}my($ppp)=$self->_packages_per_pmfile;my@keys_ppp=$self->_filter_ppps(sort keys %$ppp);$self->_verbose(1,"Will check keys_ppp[@keys_ppp]\n");my ($package,%errors);my%checked_in;DBPACK: foreach$package (@keys_ppp){if ($package !~ /^\w[\w\:\']*\w?\z/ || $package !~ /\w\z/ || $package =~ /:/ && $package !~ /::/ || $package =~ /\w:\w/ || $package =~ /:::/){$self->_verbose(1,"Package[$package] did not pass the ultimate sanity check");delete$ppp->{$package};next}if ($self->{USERID}&& $self->{PERMISSIONS}&&!$self->_perm_check($package)){delete$ppp->{$package};next}{my (undef,$module)=split m{/lib/},$self->{PMFILE},2;if ($module){$module =~ s{\.pm\z}{};$module =~ s{/}{::}g;if (lc$module eq lc$package && $module ne $package){$errors{$package}={indexing_warning=>"Capitalization of package ($package) does not match filename!",infile=>$self->{PMFILE},}}}}my$pp=$ppp->{$package};if ($pp->{version}&& $pp->{version}=~ /^\{.*\}$/){my$err=JSON::PP::decode_json($pp->{version});if ($err->{x_normalize}){$errors{$package}={normalize=>$err->{version},infile=>$pp->{infile},};$pp->{version}="undef"}elsif ($err->{openerr}){$pp->{version}="undef";$self->_verbose(1,qq{Parse::PMFile was not able to 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},}}}for ($package,$pp->{version},){if (!defined || /^\s*$/ || /\s/){delete$ppp->{$package};next}}$checked_in{$package}=$ppp->{$package}}return (wantarray && %errors)? (\%checked_in,\%errors): \%checked_in}sub _perm_check {my ($self,$package)=@_;my$userid=$self->{USERID};my$module=$self->{PERMISSIONS}->module_permissions($package);return 1 if!$module;return 1 if defined$module->m && $module->m eq $userid;return 1 if defined$module->f && $module->f eq $userid;return 1 if defined$module->c && grep {$_ eq $userid}@{$module->c};return}sub _parse_version {my$self=shift;use strict;my$pmfile=$self->{PMFILE};my$tmpfile=File::Spec->catfile(File::Spec->tmpdir,"ParsePMFile$$" .rand(1000));my$pmcp=$pmfile;for ($pmcp){s/([^\\](\\\\)*)@/$1\\@/g}my($v);{package main;my$pid;if ($self->{FORK}|| $FORK){$pid=fork();die "Can't fork: $!" unless defined$pid}if ($pid){waitpid($pid,0);if (open my$fh,'<',$tmpfile){$v=<$fh>}}else {my($comp)=Safe->new;my$eval=qq{ local(\$^W) = 0; Parse::PMFile::_parse_version_safely("$pmcp"); };$comp->permit("entereval");$comp->share("*Parse::PMFile::_parse_version_safely");$comp->share("*version::new");$comp->share("*version::numify");$comp->share_from('main',['*version::','*charstar::','*Exporter::','*DynaLoader::']);$comp->share_from('version',['&qv']);$comp->permit(":base_math");$comp->deny(qw/enteriter iter unstack goto/);version->import('qv')if$self->{UNSAFE}|| $UNSAFE;{no strict;$v=($self->{UNSAFE}|| $UNSAFE)? eval$eval : $comp->reval($eval)}if ($@){my$err=$@;if (ref$err){if ($err->{line}=~ /([\$*])([\w\:\']*)\bVERSION\b.*?\=(.*)/){local($^W)=0;my ($sigil,$vstr)=($1,$3);$self->_restore_overloaded_stuff(1)if$err->{line}=~ /use\s+version\b|version\->|qv\(/;$v=($self->{UNSAFE}|| $UNSAFE)? eval$vstr : $comp->reval($vstr);$v=$$v if$sigil eq '*' && ref$v}if ($@ or!$v){$self->_verbose(1,sprintf("reval failed: err[%s] for eval[%s]",JSON::PP::encode_json($err),$eval,));$v=JSON::PP::encode_json($err)}}else {$v=JSON::PP::encode_json({openerr=>$err })}}if (defined$v){$v=$v->numify if ref($v)=~ /^version(::vpp)?$/}else {$v=""}if ($self->{FORK}|| $FORK){open my$fh,'>:utf8',$tmpfile;print$fh $v;exit 0}else {utf8::encode($v);$v=undef if defined$v &&!length$v;$comp->erase;$self->_restore_overloaded_stuff}}}unlink$tmpfile if ($self->{FORK}|| $FORK)&& -e $tmpfile;return$self->_normalize_version($v)}sub _restore_overloaded_stuff {my ($self,$used_version_in_safe)=@_;return if$self->{UNSAFE}|| $UNSAFE;no strict 'refs';no warnings 'redefine';my$restored;if ($INC{'version/vxs.pm'}){*{'version::(""'}=\&version::vxs::stringify;*{'version::(0+'}=\&version::vxs::numify;*{'version::(cmp'}=\&version::vxs::VCMP;*{'version::(<=>'}=\&version::vxs::VCMP;*{'version::(bool'}=\&version::vxs::boolean;$restored=1}if ($INC{'version/vpp.pm'}){{package charstar;overload->import}if (!$used_version_in_safe){package version::vpp;overload->import}unless ($restored){*{'version::(""'}=\&version::vpp::stringify;*{'version::(0+'}=\&version::vpp::numify;*{'version::(cmp'}=\&version::vpp::vcmp;*{'version::(<=>'}=\&version::vpp::vcmp;*{'version::(bool'}=\&version::vpp::vbool}*{'version::vpp::(""'}=\&version::vpp::stringify;*{'version::vpp::(0+'}=\&version::vpp::numify;*{'version::vpp::(cmp'}=\&version::vpp::vcmp;*{'version::vpp::(<=>'}=\&version::vpp::vcmp;*{'version::vpp::(bool'}=\&version::vpp::vbool;*{'charstar::(""'}=\&charstar::thischar;*{'charstar::(0+'}=\&charstar::thischar;*{'charstar::(++'}=\&charstar::increment;*{'charstar::(--'}=\&charstar::decrement;*{'charstar::(+'}=\&charstar::plus;*{'charstar::(-'}=\&charstar::minus;*{'charstar::(*'}=\&charstar::multiply;*{'charstar::(cmp'}=\&charstar::cmp;*{'charstar::(<=>'}=\&charstar::spaceship;*{'charstar::(bool'}=\&charstar::thischar;*{'charstar::(='}=\&charstar::clone;$restored=1}if (!$restored){*{'version::(""'}=\&version::stringify;*{'version::(0+'}=\&version::numify;*{'version::(cmp'}=\&version::vcmp;*{'version::(<=>'}=\&version::vcmp;*{'version::(bool'}=\&version::boolean}}sub _packages_per_pmfile {my$self=shift;my$ppp={};my$pmfile=$self->{PMFILE};my$filemtime=$self->{MTIME};my$version=$self->{VERSION};open my$fh,"<","$pmfile" or return$ppp;local $/="\n";my$inpod=0;PLINE: while (<$fh>){chomp;my($pline)=$_;$inpod=$pline =~ /^=(?!cut)/ ? 1 : $pline =~ /^=cut/ ? 0 : $inpod;next if$inpod;next if substr($pline,0,4)eq "=cut";$pline =~ s/\#.*//;next if$pline =~ /^\s*$/;if ($pline =~ /^__(?:END|DATA)__\b/ and $pmfile !~ /\.PL$/){last PLINE}my$pkg;my$strict_version;if ($pline =~ m{ # (.*) # 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"){next PLINE}}if ($pkg){$pkg =~ s/\'/::/;next PLINE unless$pkg =~ /^[A-Za-z]/;next PLINE unless$pkg =~ /\w$/;next PLINE if$pkg eq "main";next PLINE if length($pkg)> 128;$ppp->{$pkg}{parsed}++;$ppp->{$pkg}{infile}=$pmfile;if ($self->_simile($pmfile,$pkg)){$ppp->{$pkg}{simile}=$pmfile;if ($self->_version_from_meta_ok){my$provides=$self->{META_CONTENT}{provides};if (exists$provides->{$pkg}){if (defined$provides->{$pkg}{version}){my$v=$provides->{$pkg}{version};if ($v =~ /[_\s]/ &&!$self->{ALLOW_DEV_VERSION}&&!$ALLOW_DEV_VERSION){next PLINE}unless (eval {$version=$self->_normalize_version($v);1}){$self->_verbose(1,"error with version in $pmfile: $@");next}$ppp->{$pkg}{version}=$version}else {$ppp->{$pkg}{version}="undef"}}}else {if (defined$strict_version){$ppp->{$pkg}{version}=$strict_version }else {$ppp->{$pkg}{version}=defined$version ? $version : ""}no warnings;if ($version eq 'undef'){$ppp->{$pkg}{version}=$version unless defined$ppp->{$pkg}{version}}else {$ppp->{$pkg}{version}=$version if$version > $ppp->{$pkg}{version}|| $version gt $ppp->{$pkg}{version}}}}else {$ppp->{$pkg}{version}=$version unless defined$ppp->{$pkg}{version}&& length($ppp->{$pkg}{version})}$ppp->{$pkg}{filemtime}=$filemtime}else {}}close$fh;$ppp}{no strict;sub _parse_version_safely {my($parsefile)=@_;my$result;local*FH;local $/="\n";open(FH,$parsefile)or die "Could not open '$parsefile': $!";my$inpod=0;while (<FH>){$inpod=/^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod;next if$inpod || /^\s*#/;last if /^__(?:END|DATA)__\b/;chop;if (my ($ver)=/package \s+ \S+ \s+ (\S+) \s* [;{]/x){return$ver if version::is_lax($ver)}next unless /(?<!\\)([\$*])(([\w\:\']*)\bVERSION)\b.*(?<![!><=])\=(?![=>])/;my$current_parsed_line=$_;my$eval=qq{ package # ExtUtils::MakeMaker::_version; local $1$2; \$$2=undef; do { $_ }; \$$2 };local $^W=0;local$SIG{__WARN__}=sub {};$result=__clean_eval($eval);if ($@ or!defined$result){die +{eval=>$eval,line=>$current_parsed_line,file=>$parsefile,err=>$@,}}last}close FH;$result="undef" unless defined$result;if ((ref$result)=~ /^version(?:::vpp)?\b/){$result=$result->numify}return$result}}sub _filter_ppps {my($self,@ppps)=@_;my@res;MANI: for my$ppp (@ppps){if ($self->{META_CONTENT}){my$no_index=$self->{META_CONTENT}{no_index}|| $self->{META_CONTENT}{private};if (ref($no_index)eq 'HASH'){my%map=(package=>qr{\z},namespace=>qr{::},);for my$k (qw(package namespace)){next unless my$v=$no_index->{$k};my$rest=$map{$k};if (ref$v eq "ARRAY"){for my$ve (@$v){$ve =~ s|::$||;if ($ppp =~ /^$ve$rest/){$self->_verbose(1,"Skipping ppp[$ppp] due to ve[$ve]");next MANI}else {$self->_verbose(1,"NOT skipping ppp[$ppp] due to ve[$ve]")}}}else {$v =~ s|::$||;if ($ppp =~ /^$v$rest/){$self->_verbose(1,"Skipping ppp[$ppp] due to v[$v]");next MANI}else {$self->_verbose(1,"NOT skipping ppp[$ppp] due to v[$v]")}}}}else {$self->_verbose(1,"No keyword 'no_index' or 'private' in META_CONTENT")}}else {}push@res,$ppp}$self->_verbose(1,"Result of filter_ppps: res[@res]");@res}sub _simile {my($self,$file,$package)=@_;$file =~ s|.*/||;$file =~ s|\.pm(?:\.PL)?||;my$ret=$package =~ m/\b\Q$file\E$/;$ret ||= 0;unless ($ret){$ret=1 if lc$file eq 'version'}$self->_verbose(1,"Result of simile(): file[$file] package[$package] ret[$ret]\n");$ret}sub _normalize_version {my($self,$v)=@_;$v="undef" unless defined$v;my$dv=Dumpvalue->new;my$sdv=$dv->stringify($v,1);$self->_verbose(1,"Result of normalize_version: sdv[$sdv]\n");return$v if$v eq "undef";return$v if$v =~ /^\{.*\}$/;$v =~ s/^\s+//;$v =~ s/\s+\z//;if ($v =~ /_/){return$v }if (!version::is_lax($v)){return JSON::PP::encode_json({x_normalize=>'version::is_lax failed',version=>$v })}my$vv=eval {no warnings;version->new($v)->numify};if ($@){return JSON::PP::encode_json({x_normalize=>$@,version=>$v })}if ($vv eq $v){}else {my$forced=$self->_force_numeric($v);if ($forced eq $vv){}elsif ($forced =~ /^v(.+)/){$vv=version->new($1)->numify}else {if ($forced==$vv){$vv=$forced}}}return$vv}sub _force_numeric {my($self,$v)=@_;$v=$self->_readable($v);if ($v =~ /^(\+?)(\d*)(\.(\d*))?/ && (defined $2 && length $2 || defined $4 && length $4)){my$two=defined $2 ? $2 : "";my$three=defined $3 ? $3 : "";$v="$two$three"}$v}sub _version_from_meta_ok {my($self)=@_;return$self->{VERSION_FROM_META_OK}if exists$self->{VERSION_FROM_META_OK};my$c=$self->{META_CONTENT};return($self->{VERSION_FROM_META_OK}=0)unless$c->{provides};my ($mb_v)=(defined$c->{generated_by}? $c->{generated_by}: '')=~ /Module::Build version ([\d\.]+)/;return($self->{VERSION_FROM_META_OK}=1)unless$mb_v;return($self->{VERSION_FROM_META_OK}=1)if$mb_v eq '0.250.0';if ($mb_v >= 0.19 && $mb_v < 0.26 &&!keys %{$c->{provides}}){return($self->{VERSION_FROM_META_OK}=0)}return($self->{VERSION_FROM_META_OK}=1)}sub _verbose {my($self,$level,@what)=@_;warn@what if$level <= ((ref$self && $self->{VERBOSE})|| $VERBOSE)}sub _vcmp {my($self,$l,$r)=@_;local($^W)=0;$self->_verbose(9,"l[$l] r[$r]");return 0 if$l eq $r;for ($l,$r){s/_//g}$self->_verbose(9,"l[$l] r[$r]");for ($l,$r){next unless tr/.// > 1 || /^v/;s/^v?/v/;1 while s/\.0+(\d)/.$1/}$self->_verbose(9,"l[$l] r[$r]");if ($l=~/^v/ <=> $r=~/^v/){for ($l,$r){next if /^v/;$_=$self->_float2vv($_)}}$self->_verbose(9,"l[$l] r[$r]");my$lvstring="v0";my$rvstring="v0";if ($] >= 5.006 && $l =~ /^v/ && $r =~ /^v/){$lvstring=$self->_vstring($l);$rvstring=$self->_vstring($r);$self->_verbose(9,sprintf "lv[%vd] rv[%vd]",$lvstring,$rvstring)}return (($l ne "undef")<=> ($r ne "undef")|| $lvstring cmp $rvstring || $l <=> $r || $l cmp $r)}sub _vgt {my($self,$l,$r)=@_;$self->_vcmp($l,$r)> 0}sub _vlt {my($self,$l,$r)=@_;$self->_vcmp($l,$r)< 0}sub _vge {my($self,$l,$r)=@_;$self->_vcmp($l,$r)>= 0}sub _vle {my($self,$l,$r)=@_;$self->_vcmp($l,$r)<= 0}sub _vstring {my($self,$n)=@_;$n =~ s/^v// or die "Parse::PMFile::_vstring() called with invalid arg [$n]";pack "U*",split /\./,$n}sub _float2vv {my($self,$n)=@_;my($rev)=int($n);$rev ||= 0;my($mantissa)=$n =~ /\.(\d{1,12})/;$mantissa ||= 0;$mantissa .= "0" while length($mantissa)%3;my$ret="v" .$rev;while ($mantissa){$mantissa =~ s/(\d{1,3})// or die "Panic: length>0 but not a digit? mantissa[$mantissa]";$ret .= ".".int($1)}$ret =~ s/(\.0)+/.0/;$ret}sub _readable {my($self,$n)=@_;$n =~ /^([\w\-\+\.]+)/;return $1 if defined $1 && length($1)>0;if ($] < 5.006){$self->_verbose(9,"Suspicious version string seen [$n]\n");return$n}my$better=sprintf "v%vd",$n;$self->_verbose(9,"n[$n] better[$better]");return$better}1; PARSE_PMFILE $fatpacked{"String/ShellQuote.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'STRING_SHELLQUOTE'; package String::ShellQuote;use strict;use vars qw($VERSION @ISA @EXPORT);require Exporter;$VERSION='1.04';@ISA=qw(Exporter);@EXPORT=qw(shell_quote shell_quote_best_effort shell_comment_quote);sub croak {require Carp;goto&Carp::croak}sub _shell_quote_backend {my@in=@_;my@err=();if (0){require RS::Handy;print RS::Handy::data_dump(\@in)}return \@err,'' unless@in;my$ret='';my$saw_non_equal=0;for (@in){if (!defined $_ or $_ eq ''){$_="''";next}if (s/\x00//g){push@err,"No way to quote string containing null (\\000) bytes"}my$escape=0;if (/=/){if (!$saw_non_equal){$escape=1}}else {$saw_non_equal=1}if (m|[^\w!%+,\-./:=@^]|){$escape=1}if ($escape || (!$saw_non_equal && /=/)){s/'/'\\''/g;s|((?:'\\''){2,})|q{'"} . (q{'} x (length($1) / 4)) . q{"'}|ge;$_="'$_'";s/^''//;s/''$//}}continue {$ret .= "$_ "}chop$ret;return \@err,$ret}sub shell_quote {my ($rerr,$s)=_shell_quote_backend @_;if (@$rerr){my%seen;@$rerr=grep {!$seen{$_}++}@$rerr;my$s=join '',map {"shell_quote(): $_\n"}@$rerr;chomp$s;croak$s}return$s}sub shell_quote_best_effort {my ($rerr,$s)=_shell_quote_backend @_;return$s}sub shell_comment_quote {return '' unless @_;unless (@_==1){croak "Too many arguments to shell_comment_quote " ."(got " .@_ ." expected 1)"}local $_=shift;s/\n/\n#/g;return $_}1; STRING_SHELLQUOTE $fatpacked{"lib/core/only.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LIB_CORE_ONLY'; package lib::core::only;use strict;use warnings FATAL=>'all';use Config;sub import {@INC=@Config{qw(privlibexp archlibexp)};return}1; LIB_CORE_ONLY $fatpacked{"local/lib.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOCAL_LIB'; package local::lib;use 5.006;use strict;use warnings;use Config;our$VERSION='2.000015';$VERSION=eval$VERSION;BEGIN {*_WIN32=($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'symbian')? sub(){1}: sub(){0};*_USE_FSPEC=($^O eq 'MacOS' || $^O eq 'VMS' || $INC{'File/Spec.pm'})? sub(){1}: sub(){0}}our$_DIR_JOIN=_WIN32 ? '\\' : '/';our$_DIR_SPLIT=(_WIN32 || $^O eq 'cygwin')? qr{[\\/]} : qr{/};our$_ROOT=_WIN32 ? do {my$UNC=qr{[\\/]{2}[^\\/]+[\\/][^\\/]+};qr{^(?:$UNC|[A-Za-z]:|)$_DIR_SPLIT}}: qr{^/};our$_PERL;sub _cwd {my$drive=shift;if (!$_PERL){($_PERL)=$^X =~ /(.+)/;if (_is_abs($_PERL)){}elsif (-x $Config{perlpath}){$_PERL=$Config{perlpath}}else {($_PERL)=map {/(.*)/}grep {-x $_}map {join($_DIR_JOIN,$_,$_PERL)}split /\Q$Config{path_sep}\E/,$ENV{PATH}}}local@ENV{qw(PATH IFS CDPATH ENV BASH_ENV)};my$cmd=$drive ? "eval { Cwd::getdcwd(q($drive)) }" : 'getcwd';my$cwd=`"$_PERL" -MCwd -le "print $cmd"`;chomp$cwd;if (!length$cwd && $drive){$cwd=$drive}$cwd =~ s/$_DIR_SPLIT?$/$_DIR_JOIN/;$cwd}sub _catdir {if (_USE_FSPEC){require File::Spec;File::Spec->catdir(@_)}else {my$dir=join($_DIR_JOIN,@_);$dir =~ s{($_DIR_SPLIT)(?:\.?$_DIR_SPLIT)+}{$1}g;$dir}}sub _is_abs {if (_USE_FSPEC){require File::Spec;File::Spec->file_name_is_absolute($_[0])}else {$_[0]=~ $_ROOT}}sub _rel2abs {my ($dir,$base)=@_;return$dir if _is_abs($dir);$base=_WIN32 && $dir =~ s/^([A-Za-z]:)// ? _cwd("$1"): $base ? $base : _cwd;return _catdir($base,$dir)}sub import {my ($class,@args)=@_;push@args,@ARGV if $0 eq '-';my@steps;my%opts;my$shelltype;while (@args){my$arg=shift@args;if ($arg =~ /\xE2\x88\x92/ or $arg =~ /−/){die <<'DEATH'}elsif ($arg eq '--self-contained'){die <<'DEATH'}elsif($arg =~ /^--deactivate(?:=(.*))?$/){my$path=defined $1 ? $1 : shift@args;push@steps,['deactivate',$path]}elsif ($arg eq '--deactivate-all'){push@steps,['deactivate_all']}elsif ($arg =~ /^--shelltype(?:=(.*))?$/){$shelltype=defined $1 ? $1 : shift@args}elsif ($arg eq '--no-create'){$opts{no_create}=1}elsif ($arg =~ /^--/){die "Unknown import argument: $arg"}else {push@steps,['activate',$arg]}}if (!@steps){push@steps,['activate',undef]}my$self=$class->new(%opts);for (@steps){my ($method,@args)=@$_;$self=$self->$method(@args)}if ($0 eq '-'){print$self->environment_vars_string($shelltype);exit 0}else {$self->setup_local_lib}}sub new {my$class=shift;bless {@_},$class}sub clone {my$self=shift;bless {%$self,@_},ref$self}sub inc {$_[0]->{inc}||= \@INC}sub libs {$_[0]->{libs}||= [\'PERL5LIB' ]}sub bins {$_[0]->{bins}||= [\'PATH' ]}sub roots {$_[0]->{roots}||= [\'PERL_LOCAL_LIB_ROOT' ]}sub extra {$_[0]->{extra}||= {}}sub no_create {$_[0]->{no_create}}my$_archname=$Config{archname};my$_version=$Config{version};my@_inc_version_list=reverse split / /,$Config{inc_version_list};my$_path_sep=$Config{path_sep};sub _as_list {my$list=shift;grep length,map {!(ref $_ && ref $_ eq 'SCALAR')? $_ : (defined$ENV{$$_}? split(/\Q$_path_sep/,$ENV{$$_}): ())}ref$list ? @$list : $list}sub _remove_from {my ($list,@remove)=@_;return @$list if!@remove;my%remove=map {$_=>1}@remove;grep!$remove{$_},_as_list($list)}my@_lib_subdirs=([$_version,$_archname],[$_version],[$_archname],(@_inc_version_list ? \@_inc_version_list : ()),[],);sub install_base_bin_path {my ($class,$path)=@_;return _catdir($path,'bin')}sub install_base_perl_path {my ($class,$path)=@_;return _catdir($path,'lib','perl5')}sub install_base_arch_path {my ($class,$path)=@_;_catdir($class->install_base_perl_path($path),$_archname)}sub lib_paths_for {my ($class,$path)=@_;my$base=$class->install_base_perl_path($path);return map {_catdir($base,@$_)}@_lib_subdirs}sub _mm_escape_path {my$path=shift;$path =~ s/\\/\\\\/g;if ($path =~ s/ /\\ /g){$path=qq{"$path"}}return$path}sub _mb_escape_path {my$path=shift;$path =~ s/\\/\\\\/g;return qq{"$path"}}sub installer_options_for {my ($class,$path)=@_;return (PERL_MM_OPT=>defined$path ? "INSTALL_BASE="._mm_escape_path($path): undef,PERL_MB_OPT=>defined$path ? "--install_base "._mb_escape_path($path): undef,)}sub active_paths {my ($self)=@_;$self=ref$self ? $self : $self->new;return grep {my$active_ll=$self->install_base_perl_path($_);grep {$_ eq $active_ll}@{$self->inc}}_as_list($self->roots)}sub deactivate {my ($self,$path)=@_;$self=$self->new unless ref$self;$path=$self->resolve_path($path);$path=$self->normalize_path($path);my@active_lls=$self->active_paths;if (!grep {$_ eq $path}@active_lls){warn "Tried to deactivate inactive local::lib '$path'\n";return$self}my%args=(bins=>[_remove_from($self->bins,$self->install_base_bin_path($path))],libs=>[_remove_from($self->libs,$self->install_base_perl_path($path))],inc=>[_remove_from($self->inc,$self->lib_paths_for($path))],roots=>[_remove_from($self->roots,$path)],);$args{extra}={$self->installer_options_for($args{roots}[0])};$self->clone(%args)}sub deactivate_all {my ($self)=@_;$self=$self->new unless ref$self;my@active_lls=$self->active_paths;my%args;if (@active_lls){%args=(bins=>[_remove_from($self->bins,map$self->install_base_bin_path($_),@active_lls)],libs=>[_remove_from($self->libs,map$self->install_base_perl_path($_),@active_lls)],inc=>[_remove_from($self->inc,map$self->lib_paths_for($_),@active_lls)],roots=>[_remove_from($self->roots,@active_lls)],)}$args{extra}={$self->installer_options_for(undef)};$self->clone(%args)}sub activate {my ($self,$path)=@_;$self=$self->new unless ref$self;$path=$self->resolve_path($path);$self->ensure_dir_structure_for($path)unless$self->no_create;$path=$self->normalize_path($path);my@active_lls=$self->active_paths;if (grep {$_ eq $path}@active_lls[1 .. $#active_lls]){$self=$self->deactivate($path)}my%args;if (!@active_lls || $active_lls[0]ne $path){%args=(bins=>[$self->install_base_bin_path($path),@{$self->bins}],libs=>[$self->install_base_perl_path($path),@{$self->libs}],inc=>[$self->lib_paths_for($path),@{$self->inc}],roots=>[$path,@{$self->roots}],)}$args{extra}={$self->installer_options_for($path)};$self->clone(%args)}sub normalize_path {my ($self,$path)=@_;$path=(Win32::GetShortPathName($path)|| $path)if $^O eq 'MSWin32';return$path}sub build_environment_vars_for {my$self=$_[0]->new->activate($_[1]);$self->build_environment_vars}sub build_activate_environment_vars_for {my$self=$_[0]->new->activate($_[1]);$self->build_environment_vars}sub build_deactivate_environment_vars_for {my$self=$_[0]->new->deactivate($_[1]);$self->build_environment_vars}sub build_deact_all_environment_vars_for {my$self=$_[0]->new->deactivate_all;$self->build_environment_vars}sub build_environment_vars {my$self=shift;(PATH=>join($_path_sep,_as_list($self->bins)),PERL5LIB=>join($_path_sep,_as_list($self->libs)),PERL_LOCAL_LIB_ROOT=>join($_path_sep,_as_list($self->roots)),%{$self->extra},)}sub setup_local_lib_for {my$self=$_[0]->new->activate($_[1]);$self->setup_local_lib}sub setup_local_lib {my$self=shift;require Carp::Heavy if$INC{'Carp.pm'};$self->setup_env_hash;@INC=@{$self->inc}}sub setup_env_hash_for {my$self=$_[0]->new->activate($_[1]);$self->setup_env_hash}sub setup_env_hash {my$self=shift;my%env=$self->build_environment_vars;for my$key (keys%env){if (defined$env{$key}){$ENV{$key}=$env{$key}}else {delete$ENV{$key}}}}sub print_environment_vars_for {print $_[0]->environment_vars_string_for(@_[1..$#_])}sub environment_vars_string_for {my$self=$_[0]->new->activate($_[1]);$self->environment_vars_string}sub environment_vars_string {my ($self,$shelltype)=@_;$shelltype ||= $self->guess_shelltype;my$extra=$self->extra;my@envs=(PATH=>$self->bins,PERL5LIB=>$self->libs,PERL_LOCAL_LIB_ROOT=>$self->roots,map {$_=>$extra->{$_}}sort keys %$extra,);$self->_build_env_string($shelltype,\@envs)}sub _build_env_string {my ($self,$shelltype,$envs)=@_;my@envs=@$envs;my$build_method="build_${shelltype}_env_declaration";my$out='';while (@envs){my ($name,$value)=(shift(@envs),shift(@envs));if (ref$value && @$value==1 && ref$value->[0]&& ref$value->[0]eq 'SCALAR' && ${$value->[0]}eq $name){next}$out .= $self->$build_method($name,$value)}my$wrap_method="wrap_${shelltype}_output";if ($self->can($wrap_method)){return$self->$wrap_method($out)}return$out}sub build_bourne_env_declaration {my ($class,$name,$args)=@_;my$value=$class->_interpolate($args,'${%s}',qr/["\\\$!`]/,'\\%s');if (!defined$value){return qq{unset $name;\n}}$value =~ s/(^|\G|$_path_sep)\$\{$name\}$_path_sep/$1\${$name}\${$name+$_path_sep}/g;$value =~ s/$_path_sep\$\{$name\}$/\${$name+$_path_sep}\${$name}/;qq{${name}="$value"; export ${name};\n}}sub build_csh_env_declaration {my ($class,$name,$args)=@_;my ($value,@vars)=$class->_interpolate($args,'${%s}','"','"\\%s"');if (!defined$value){return qq{unsetenv $name;\n}}my$out='';for my$var (@vars){$out .= qq{if ! \$?$name setenv $name '';\n}}my$value_without=$value;if ($value_without =~ s/(?:^|$_path_sep)\$\{$name\}(?:$_path_sep|$)//g){$out .= qq{if "\${$name}" != '' setenv $name "$value";\n};$out .= qq{if "\${$name}" == '' }}$out .= qq{setenv $name "$value_without";\n};return$out}sub build_cmd_env_declaration {my ($class,$name,$args)=@_;my$value=$class->_interpolate($args,'%%%s%%',qr(%),'%s');if (!$value){return qq{\@set $name=\n}}my$out='';my$value_without=$value;if ($value_without =~ s/(?:^|$_path_sep)%$name%(?:$_path_sep|$)//g){$out .= qq{\@if not "%$name%"=="" set "$name=$value"\n};$out .= qq{\@if "%$name%"=="" }}$out .= qq{\@set "$name=$value_without"\n};return$out}sub build_powershell_env_declaration {my ($class,$name,$args)=@_;my$value=$class->_interpolate($args,'$env:%s','"','`%s');if (!$value){return qq{Remove-Item -ErrorAction 0 Env:\\$name;\n}}my$maybe_path_sep=qq{\$(if("\$env:$name"-eq""){""}else{"$_path_sep"})};$value =~ s/(^|\G|$_path_sep)\$env:$name$_path_sep/$1\$env:$name"+$maybe_path_sep+"/g;$value =~ s/$_path_sep\$env:$name$/"+$maybe_path_sep+\$env:$name+"/;qq{\$env:$name = \$("$value");\n}}sub wrap_powershell_output {my ($class,$out)=@_;return$out || " \n"}sub build_fish_env_declaration {my ($class,$name,$args)=@_;my$value=$class->_interpolate($args,'$%s',qr/[\\"' ]/,'\\%s');if (!defined$value){return qq{set -e $name;\n}}$value =~ s/$_path_sep/ /g;qq{set -x $name $value;\n}}sub _interpolate {my ($class,$args,$var_pat,$escape,$escape_pat)=@_;return unless defined$args;my@args=ref$args ? @$args : $args;return unless@args;my@vars=map {$$_}grep {ref $_ eq 'SCALAR'}@args;my$string=join$_path_sep,map {ref $_ eq 'SCALAR' ? sprintf($var_pat,$$_): do {s/($escape)/sprintf($escape_pat, $1)/ge;$_}}@args;return wantarray ? ($string,\@vars): $string}sub pipeline;sub pipeline {my@methods=@_;my$last=pop(@methods);if (@methods){\sub {my ($obj,@args)=@_;$obj->${pipeline@methods}($obj->$last(@args))}}else {\sub {shift->$last(@_)}}}sub resolve_path {my ($class,$path)=@_;$path=$class->${pipeline qw(resolve_relative_path resolve_home_path resolve_empty_path)}($path);$path}sub resolve_empty_path {my ($class,$path)=@_;if (defined$path){$path}else {'~/perl5'}}sub resolve_home_path {my ($class,$path)=@_;$path =~ /^~([^\/]*)/ or return$path;my$user=$1;my$homedir=do {if (!length($user)&& defined$ENV{HOME}){$ENV{HOME}}else {require File::Glob;File::Glob::bsd_glob("~$user",File::Glob::GLOB_TILDE())}};unless (defined$homedir){require Carp;require Carp::Heavy;Carp::croak("Couldn't resolve homedir for " .(defined$user ? $user : 'current user'))}$path =~ s/^~[^\/]*/$homedir/;$path}sub resolve_relative_path {my ($class,$path)=@_;_rel2abs($path)}sub ensure_dir_structure_for {my ($class,$path)=@_;unless (-d $path){warn "Attempting to create directory ${path}\n"}require File::Basename;my@dirs;while(!-d $path){push@dirs,$path;$path=File::Basename::dirname($path)}mkdir $_ for reverse@dirs;return}sub guess_shelltype {my$shellbin =defined$ENV{SHELL}? ($ENV{SHELL}=~ /([\w.]+)$/)[-1]: ($^O eq 'MSWin32' && exists$ENV{'!EXITCODE'})? 'bash' : ($^O eq 'MSWin32' && $ENV{PROMPT}&& $ENV{COMSPEC})? ($ENV{COMSPEC}=~ /([\w.]+)$/)[-1]: ($^O eq 'MSWin32' &&!$ENV{PROMPT})? 'powershell.exe' : 'sh';for ($shellbin){return /csh$/ ? 'csh' : /fish/ ? 'fish' : /command(?:\.com)?$/i ? 'cmd' : /cmd(?:\.exe)?$/i ? 'cmd' : /4nt(?:\.exe)?$/i ? 'cmd' : /powershell(?:\.exe)?$/i ? 'powershell' : 'bourne'}}1; 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 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 LOCAL_LIB $fatpacked{"parent.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PARENT'; package parent;use strict;use vars qw($VERSION);$VERSION='0.228';sub import {my$class=shift;my$inheritor=caller(0);if (@_ and $_[0]eq '-norequire'){shift @_}else {for (my@filename=@_){if ($_ eq $inheritor){warn "Class '$inheritor' tried to inherit from itself\n"};s{::|'}{/}g;require "$_.pm"}}{no strict 'refs';push @{"$inheritor\::ISA"},@_}};"All your base are belong to us" PARENT $fatpacked{"version.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'VERSION'; package version;use 5.006002;use strict;use warnings::register;if ($] >= 5.015){warnings::register_categories(qw/version/)}use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv);$VERSION=0.9912;$CLASS='version';{local$SIG{'__DIE__'};if (1){eval "use version::vpp $VERSION";die "$@" if ($@);push@ISA,"version::vpp";local $^W;*version::qv=\&version::vpp::qv;*version::declare=\&version::vpp::declare;*version::_VERSION=\&version::vpp::_VERSION;*version::vcmp=\&version::vpp::vcmp;*version::new=\&version::vpp::new;*version::numify=\&version::vpp::numify;*version::normal=\&version::vpp::normal;if ($] >= 5.009000){no strict 'refs';*version::stringify=\&version::vpp::stringify;*{'version::(""'}=\&version::vpp::stringify;*{'version::(<=>'}=\&version::vpp::vcmp;*version::parse=\&version::vpp::parse}}else {push@ISA,"version::vxs";local $^W;*version::declare=\&version::vxs::declare;*version::qv=\&version::vxs::qv;*version::_VERSION=\&version::vxs::_VERSION;*version::vcmp=\&version::vxs::VCMP;*version::new=\&version::vxs::new;*version::numify=\&version::vxs::numify;*version::normal=\&version::vxs::normal;if ($] >= 5.009000){no strict 'refs';*version::stringify=\&version::vxs::stringify;*{'version::(""'}=\&version::vxs::stringify;*{'version::(<=>'}=\&version::vxs::VCMP;*version::parse=\&version::vxs::parse}}}require version::regex;*version::is_lax=\&version::regex::is_lax;*version::is_strict=\&version::regex::is_strict;*LAX=\$version::regex::LAX;*STRICT=\$version::regex::STRICT;sub import {no strict 'refs';my ($class)=shift;unless ($class eq $CLASS){local $^W;*{$class.'::declare'}=\&{$CLASS.'::declare'};*{$class.'::qv'}=\&{$CLASS.'::qv'}}my%args;if (@_){map {$args{$_}=1}@_}else {%args=(qv=>1,'UNIVERSAL::VERSION'=>1,)}my$callpkg=caller();if (exists($args{declare})){*{$callpkg.'::declare'}=sub {return$class->declare(shift)}unless defined(&{$callpkg.'::declare'})}if (exists($args{qv})){*{$callpkg.'::qv'}=sub {return$class->qv(shift)}unless defined(&{$callpkg.'::qv'})}if (exists($args{'UNIVERSAL::VERSION'})){local $^W;*UNIVERSAL::VERSION =\&{$CLASS.'::_VERSION'}}if (exists($args{'VERSION'})){*{$callpkg.'::VERSION'}=\&{$CLASS.'::_VERSION'}}if (exists($args{'is_strict'})){*{$callpkg.'::is_strict'}=\&{$CLASS.'::is_strict'}unless defined(&{$callpkg.'::is_strict'})}if (exists($args{'is_lax'})){*{$callpkg.'::is_lax'}=\&{$CLASS.'::is_lax'}unless defined(&{$callpkg.'::is_lax'})}}1; VERSION $fatpacked{"version/regex.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'VERSION_REGEX'; package version::regex;use strict;use vars qw($VERSION $CLASS $STRICT $LAX);$VERSION=0.9912;my$FRACTION_PART=qr/\.[0-9]+/;my$STRICT_INTEGER_PART=qr/0|[1-9][0-9]*/;my$LAX_INTEGER_PART=qr/[0-9]+/;my$STRICT_DOTTED_DECIMAL_PART=qr/\.[0-9]{1,3}/;my$LAX_DOTTED_DECIMAL_PART=qr/\.[0-9]+/;my$LAX_ALPHA_PART=qr/_[0-9]+/;my$STRICT_DECIMAL_VERSION=qr/ $STRICT_INTEGER_PART $FRACTION_PART? /x;my$STRICT_DOTTED_DECIMAL_VERSION=qr/ v $STRICT_INTEGER_PART $STRICT_DOTTED_DECIMAL_PART{2,} /x;$STRICT=qr/ $STRICT_DECIMAL_VERSION | $STRICT_DOTTED_DECIMAL_VERSION /x;my$LAX_DECIMAL_VERSION=qr/ $LAX_INTEGER_PART (?: \. | $FRACTION_PART $LAX_ALPHA_PART? )? | $FRACTION_PART $LAX_ALPHA_PART? /x;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;$LAX=qr/ undef | $LAX_DECIMAL_VERSION | $LAX_DOTTED_DECIMAL_VERSION /x;sub is_strict {defined $_[0]&& $_[0]=~ qr/ \A $STRICT \z /x}sub is_lax {defined $_[0]&& $_[0]=~ qr/ \A $LAX \z /x}1; VERSION_REGEX $fatpacked{"version/vpp.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'VERSION_VPP'; package charstar;use overload ('""'=>\&thischar,'0+'=>\&thischar,'++'=>\&increment,'--'=>\&decrement,'+'=>\&plus,'-'=>\&minus,'*'=>\&multiply,'cmp'=>\&cmp,'<=>'=>\&spaceship,'bool'=>\&thischar,'='=>\&clone,);sub new {my ($self,$string)=@_;my$class=ref($self)|| $self;my$obj={string=>[split(//,$string)],current=>0,};return bless$obj,$class}sub thischar {my ($self)=@_;my$last=$#{$self->{string}};my$curr=$self->{current};if ($curr >= 0 && $curr <= $last){return$self->{string}->[$curr]}else {return ''}}sub increment {my ($self)=@_;$self->{current}++}sub decrement {my ($self)=@_;$self->{current}--}sub plus {my ($self,$offset)=@_;my$rself=$self->clone;$rself->{current}+= $offset;return$rself}sub minus {my ($self,$offset)=@_;my$rself=$self->clone;$rself->{current}-= $offset;return$rself}sub multiply {my ($left,$right,$swapped)=@_;my$char=$left->thischar();return$char * $right}sub spaceship {my ($left,$right,$swapped)=@_;unless (ref($right)){$right=$left->new($right)}return$left->{current}<=> $right->{current}}sub cmp {my ($left,$right,$swapped)=@_;unless (ref($right)){if (length($right)==1){return$left->thischar cmp $right}$right=$left->new($right)}return$left->currstr cmp $right->currstr}sub bool {my ($self)=@_;my$char=$self->thischar;return ($char ne '')}sub clone {my ($left,$right,$swapped)=@_;$right={string=>[@{$left->{string}}],current=>$left->{current},};return bless$right,ref($left)}sub currstr {my ($self,$s)=@_;my$curr=$self->{current};my$last=$#{$self->{string}};if (defined($s)&& $s->{current}< $last){$last=$s->{current}}my$string=join('',@{$self->{string}}[$curr..$last]);return$string}package version::vpp;use 5.006002;use strict;use warnings::register;use Config;use vars qw($VERSION $CLASS @ISA $LAX $STRICT $WARN_CATEGORY);$VERSION=0.9912;$CLASS='version::vpp';if ($] > 5.015){warnings::register_categories(qw/version/);$WARN_CATEGORY='version'}else {$WARN_CATEGORY='numeric'}require version::regex;*version::vpp::is_strict=\&version::regex::is_strict;*version::vpp::is_lax=\&version::regex::is_lax;*LAX=\$version::regex::LAX;*STRICT=\$version::regex::STRICT;use overload ('""'=>\&stringify,'0+'=>\&numify,'cmp'=>\&vcmp,'<=>'=>\&vcmp,'bool'=>\&vbool,'+'=>\&vnoop,'-'=>\&vnoop,'*'=>\&vnoop,'/'=>\&vnoop,'+='=>\&vnoop,'-='=>\&vnoop,'*='=>\&vnoop,'/='=>\&vnoop,'abs'=>\&vnoop,);sub import {no strict 'refs';my ($class)=shift;unless ($class eq $CLASS){local $^W;*{$class.'::declare'}=\&{$CLASS.'::declare'};*{$class.'::qv'}=\&{$CLASS.'::qv'}}my%args;if (@_){map {$args{$_}=1}@_}else {%args=(qv=>1,'UNIVERSAL::VERSION'=>1,)}my$callpkg=caller();if (exists($args{declare})){*{$callpkg.'::declare'}=sub {return$class->declare(shift)}unless defined(&{$callpkg.'::declare'})}if (exists($args{qv})){*{$callpkg.'::qv'}=sub {return$class->qv(shift)}unless defined(&{$callpkg.'::qv'})}if (exists($args{'UNIVERSAL::VERSION'})){no warnings qw/redefine/;*UNIVERSAL::VERSION =\&{$CLASS.'::_VERSION'}}if (exists($args{'VERSION'})){*{$callpkg.'::VERSION'}=\&{$CLASS.'::_VERSION'}}if (exists($args{'is_strict'})){*{$callpkg.'::is_strict'}=\&{$CLASS.'::is_strict'}unless defined(&{$callpkg.'::is_strict'})}if (exists($args{'is_lax'})){*{$callpkg.'::is_lax'}=\&{$CLASS.'::is_lax'}unless defined(&{$callpkg.'::is_lax'})}}my$VERSION_MAX=0x7FFFFFFF;use constant TRUE=>1;use constant FALSE=>0;sub isDIGIT {my ($char)=shift->thischar();return ($char =~ /\d/)}sub isALPHA {my ($char)=shift->thischar();return ($char =~ /[a-zA-Z]/)}sub isSPACE {my ($char)=shift->thischar();return ($char =~ /\s/)}sub BADVERSION {my ($s,$errstr,$error)=@_;if ($errstr){$$errstr=$error}return$s}sub prescan_version {my ($s,$strict,$errstr,$sqv,$ssaw_decimal,$swidth,$salpha)=@_;my$qv=defined$sqv ? $$sqv : FALSE;my$saw_decimal=defined$ssaw_decimal ? $$ssaw_decimal : 0;my$width=defined$swidth ? $$swidth : 3;my$alpha=defined$salpha ? $$salpha : FALSE;my$d=$s;if ($qv && isDIGIT($d)){goto dotted_decimal_version}if ($d eq 'v'){$d++;if (isDIGIT($d)){$qv=TRUE}else {return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)")}dotted_decimal_version: if ($strict && $d eq '0' && isDIGIT($d+1)){return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)")}while (isDIGIT($d)){$d++}if ($d eq '.'){$saw_decimal++;$d++}else {if ($strict){return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)")}else {goto version_prescan_finish}}{my$i=0;my$j=0;while (isDIGIT($d)){$i++;while (isDIGIT($d)){$d++;$j++;if ($strict && $j > 3){return BADVERSION($s,$errstr,"Invalid version format (maximum 3 digits between decimals)")}}if ($d eq '_'){if ($strict){return BADVERSION($s,$errstr,"Invalid version format (no underscores)")}if ($alpha){return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)")}$d++;$alpha=TRUE}elsif ($d eq '.'){if ($alpha){return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)")}$saw_decimal++;$d++}elsif (!isDIGIT($d)){last}$j=0}if ($strict && $i < 2){return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)")}}}else {my$j=0;if ($strict){if ($d eq '.'){return BADVERSION($s,$errstr,"Invalid version format (0 before decimal required)")}if ($d eq '0' && isDIGIT($d+1)){return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)")}}if ($d eq '-'){return BADVERSION($s,$errstr,"Invalid version format (negative version number)")}while (isDIGIT($d)){$d++}if ($d eq '.'){$saw_decimal++;$d++}elsif (!$d || $d eq ';' || isSPACE($d)|| $d eq '}'){if ($d==$s){return BADVERSION($s,$errstr,"Invalid version format (version required)")}goto version_prescan_finish}elsif ($d==$s){return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)")}elsif ($d eq '_'){if ($strict){return BADVERSION($s,$errstr,"Invalid version format (no underscores)")}elsif (isDIGIT($d+1)){return BADVERSION($s,$errstr,"Invalid version format (alpha without decimal)")}else {return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)")}}elsif ($d){return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)")}if ($d &&!isDIGIT($d)&& ($strict ||!($d eq ';' || isSPACE($d)|| $d eq '}'))){return BADVERSION($s,$errstr,"Invalid version format (fractional part required)")}while (isDIGIT($d)){$d++;$j++;if ($d eq '.' && isDIGIT($d-1)){if ($alpha){return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)")}if ($strict){return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions must begin with 'v')")}$d=$s;$qv=TRUE;goto dotted_decimal_version}if ($d eq '_'){if ($strict){return BADVERSION($s,$errstr,"Invalid version format (no underscores)")}if ($alpha){return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)")}if (!isDIGIT($d+1)){return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)")}$width=$j;$d++;$alpha=TRUE}}}version_prescan_finish: while (isSPACE($d)){$d++}if ($d &&!isDIGIT($d)&& (!($d eq ';' || $d eq '}'))){return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)")}if ($saw_decimal > 1 && ($d-1)eq '.'){return BADVERSION($s,$errstr,"Invalid version format (trailing decimal)")}if (defined$sqv){$$sqv=$qv}if (defined$swidth){$$swidth=$width}if (defined$ssaw_decimal){$$ssaw_decimal=$saw_decimal}if (defined$salpha){$$salpha=$alpha}return$d}sub scan_version {my ($s,$rv,$qv)=@_;my$start;my$pos;my$last;my$errstr;my$saw_decimal=0;my$width=3;my$alpha=FALSE;my$vinf=FALSE;my@av;$s=new charstar$s;while (isSPACE($s)){$s++}$last=prescan_version($s,FALSE,\$errstr,\$qv,\$saw_decimal,\$width,\$alpha);if ($errstr){if ($s ne 'undef'){require Carp;Carp::croak($errstr)}}$start=$s;if ($s eq 'v'){$s++}$pos=$s;if ($qv){$$rv->{qv}=$qv}if ($alpha){$$rv->{alpha}=$alpha}if (!$qv && $width < 3){$$rv->{width}=$width}while (isDIGIT($pos)){$pos++}if (!isALPHA($pos)){my$rev;for (;;){$rev=0;{my$end=$pos;my$mult=1;my$orev;if (!$qv && $s > $start && $saw_decimal==1){$mult *= 100;while ($s < $end){$orev=$rev;$rev += $s * $mult;$mult /= 10;if ((abs($orev)> abs($rev))|| (abs($rev)> $VERSION_MAX)){warn("Integer overflow in version %d",$VERSION_MAX);$s=$end - 1;$rev=$VERSION_MAX;$vinf=1}$s++;if ($s eq '_'){$s++}}}else {while (--$end >= $s){$orev=$rev;$rev += $end * $mult;$mult *= 10;if ((abs($orev)> abs($rev))|| (abs($rev)> $VERSION_MAX)){warn("Integer overflow in version");$end=$s - 1;$rev=$VERSION_MAX;$vinf=1}}}}push@av,$rev;if ($vinf){$s=$last;last}elsif ($pos eq '.'){$pos++;if ($qv){while ($pos eq '0'){$pos++}}$s=$pos}elsif ($pos eq '_' && isDIGIT($pos+1)){$s=++$pos}elsif ($pos eq ',' && isDIGIT($pos+1)){$s=++$pos}elsif (isDIGIT($pos)){$s=$pos}else {$s=$pos;last}if ($qv){while (isDIGIT($pos)){$pos++}}else {my$digits=0;while ((isDIGIT($pos)|| $pos eq '_')&& $digits < 3){if ($pos ne '_'){$digits++}$pos++}}}}if ($qv){my$len=$#av;$len=2 - $len;while ($len-- > 0){push@av,0}}if ($vinf){$$rv->{original}="v.Inf";$$rv->{vinf}=1}elsif ($s > $start){$$rv->{original}=$start->currstr($s);if ($qv && $saw_decimal==1 && $start ne 'v'){$$rv->{original}='v' .$$rv->{original}}}else {$$rv->{original}='0';push(@av,0)}$$rv->{version}=\@av;if ($s eq 'undef'){$s += 5}return$s}sub new {my$class=shift;unless (defined$class or $#_ > 1){require Carp;Carp::croak('Usage: version::new(class, version)')}my$self=bless ({},ref ($class)|| $class);my$qv=FALSE;if ($#_==1){$qv=TRUE}my$value=pop;if (ref($value)&& eval('$value->isa("version")')){$self->{version}=[@{$value->{version}}];$self->{qv}=1 if$value->{qv};$self->{alpha}=1 if$value->{alpha};$self->{original}=''.$value->{original};return$self}if (not defined$value or $value =~ /^undef$/){push @{$self->{version}},0;$self->{original}="0";return ($self)}if (ref($value)=~ m/ARRAY|HASH/){require Carp;Carp::croak("Invalid version format (non-numeric data)")}$value=_un_vstring($value);if ($Config{d_setlocale}){use POSIX qw/locale_h/;use if$Config{d_setlocale},'locale';my$currlocale=setlocale(LC_ALL);if (localeconv()->{decimal_point}eq ','){$value =~ tr/,/./}}if ($value =~ /\d+.?\d*e[-+]?\d+/){$value=sprintf("%.9f",$value);$value =~ s/(0+)$//}my$s=scan_version($value,\$self,$qv);if ($s){warn("Version string '%s' contains invalid data; " ."ignoring: '%s'",$value,$s)}return ($self)}*parse=\&new;sub numify {my ($self)=@_;unless (_verify($self)){require Carp;Carp::croak("Invalid version object")}my$width=$self->{width}|| 3;my$alpha=$self->{alpha}|| "";my$len=$#{$self->{version}};my$digit=$self->{version}[0];my$string=sprintf("%d.",$digit);if ($alpha and warnings::enabled()){warnings::warn($WARN_CATEGORY,'alpha->numify() is lossy')}for (my$i=1 ;$i < $len ;$i++ ){$digit=$self->{version}[$i];if ($width < 3){my$denom=10**(3-$width);my$quot=int($digit/$denom);my$rem=$digit - ($quot * $denom);$string .= sprintf("%0".$width."d_%d",$quot,$rem)}else {$string .= sprintf("%03d",$digit)}}if ($len > 0){$digit=$self->{version}[$len];if ($alpha && $width==3){$string .= "_"}$string .= sprintf("%0".$width."d",$digit)}else {$string .= sprintf("000")}return$string}sub normal {my ($self)=@_;unless (_verify($self)){require Carp;Carp::croak("Invalid version object")}my$alpha=$self->{alpha}|| "";my$qv=$self->{qv}|| "";my$len=$#{$self->{version}};my$digit=$self->{version}[0];my$string=sprintf("v%d",$digit);for (my$i=1 ;$i < $len ;$i++ ){$digit=$self->{version}[$i];$string .= sprintf(".%d",$digit)}if ($len > 0){$digit=$self->{version}[$len];if ($alpha){$string .= sprintf("_%0d",$digit)}else {$string .= sprintf(".%0d",$digit)}}if ($len <= 2){for ($len=2 - $len;$len!=0;$len-- ){$string .= sprintf(".%0d",0)}}return$string}sub stringify {my ($self)=@_;unless (_verify($self)){require Carp;Carp::croak("Invalid version object")}return exists$self->{original}? $self->{original}: exists$self->{qv}? $self->normal : $self->numify}sub vcmp {require UNIVERSAL;my ($left,$right,$swap)=@_;my$class=ref($left);unless (UNIVERSAL::isa($right,$class)){$right=$class->new($right)}if ($swap){($left,$right)=($right,$left)}unless (_verify($left)){require Carp;Carp::croak("Invalid version object")}unless (_verify($right)){require Carp;Carp::croak("Invalid version format")}my$l=$#{$left->{version}};my$r=$#{$right->{version}};my$m=$l < $r ? $l : $r;my$lalpha=$left->is_alpha;my$ralpha=$right->is_alpha;my$retval=0;my$i=0;while ($i <= $m && $retval==0){$retval=$left->{version}[$i]<=> $right->{version}[$i];$i++}if ($retval==0 && $l==$r && $left->{version}[$m]==$right->{version}[$m]&& ($lalpha || $ralpha)){if ($lalpha &&!$ralpha){$retval=-1}elsif ($ralpha &&!$lalpha){$retval=+1}}if ($retval==0 && $l!=$r){if ($l < $r){while ($i <= $r && $retval==0){if ($right->{version}[$i]!=0){$retval=-1}$i++}}else {while ($i <= $l && $retval==0){if ($left->{version}[$i]!=0){$retval=+1}$i++}}}return$retval}sub vbool {my ($self)=@_;return vcmp($self,$self->new("0"),1)}sub vnoop {require Carp;Carp::croak("operation not supported with version object")}sub is_alpha {my ($self)=@_;return (exists$self->{alpha})}sub qv {my$value=shift;my$class=$CLASS;if (@_){$class=ref($value)|| $value;$value=shift}$value=_un_vstring($value);$value='v'.$value unless$value =~ /(^v|\d+\.\d+\.\d)/;my$obj=$CLASS->new($value);return bless$obj,$class}*declare=\&qv;sub is_qv {my ($self)=@_;return (exists$self->{qv})}sub _verify {my ($self)=@_;if (ref($self)&& eval {exists$self->{version}}&& ref($self->{version})eq 'ARRAY'){return 1}else {return 0}}sub _is_non_alphanumeric {my$s=shift;$s=new charstar$s;while ($s){return 0 if isSPACE($s);return 1 unless (isALPHA($s)|| isDIGIT($s)|| $s =~ /[.-]/);$s++}return 0}sub _un_vstring {my$value=shift;if (length($value)>= 1 && $value !~ /[,._]/ && _is_non_alphanumeric($value)){my$tvalue;if ($] >= 5.008_001){$tvalue=_find_magic_vstring($value);$value=$tvalue if length$tvalue}elsif ($] >= 5.006_000){$tvalue=sprintf("v%vd",$value);if ($tvalue =~ /^v\d+(\.\d+)*$/){$value=$tvalue}}}return$value}sub _find_magic_vstring {my$value=shift;my$tvalue='';require B;my$sv=B::svref_2object(\$value);my$magic=ref($sv)eq 'B::PVMG' ? $sv->MAGIC : undef;while ($magic){if ($magic->TYPE eq 'V'){$tvalue=$magic->PTR;$tvalue =~ s/^v?(.+)$/v$1/;last}else {$magic=$magic->MOREMAGIC}}return$tvalue}sub _VERSION {my ($obj,$req)=@_;my$class=ref($obj)|| $obj;no strict 'refs';if (exists$INC{"$class.pm"}and not %{"$class\::"}and $] >= 5.008){require Carp;Carp::croak("$class defines neither package nor VERSION" ."--version check failed")}my$version=eval "\$$class\::VERSION";if (defined$version){local $^W if $] <= 5.008;$version=version::vpp->new($version)}if (defined$req){unless (defined$version){require Carp;my$msg=$] < 5.006 ? "$class version $req required--this is only version " : "$class does not define \$$class\::VERSION" ."--version check failed";if ($ENV{VERSION_DEBUG}){Carp::confess($msg)}else {Carp::croak($msg)}}$req=version::vpp->new($req);if ($req > $version){require Carp;if ($req->is_qv){Carp::croak(sprintf ("%s version %s required--"."this is only version %s",$class,$req->normal,$version->normal))}else {Carp::croak(sprintf ("%s version %s required--"."this is only version %s",$class,$req->stringify,$version->stringify))}}}return defined$version ? $version->stringify : undef}1; VERSION_VPP s/^ //mg for values %fatpacked; my $class = 'FatPacked::'.(0+\%fatpacked); no strict 'refs'; *{"${class}::files"} = sub { keys %{$_[0]} }; if ($] < 5.008) { *{"${class}::INC"} = sub { if (my $fat = $_[0]{$_[1]}) { 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; }); } }; } else { *{"${class}::INC"} = sub { if (my $fat = $_[0]{$_[1]}) { open my $fh, '<', \$fat or die "FatPacker error loading $_[1] (could be a perl installation issue?)"; return $fh; } return; }; } unshift @INC, bless \%fatpacked, $class; } # END OF FATPACK CODE use strict; use App::cpanminus::script; unless (caller) { my $app = App::cpanminus::script->new; $app->parse_options(@ARGV); exit $app->doit; } __END__ =head1 NAME cpanm - get, unpack build and install modules from CPAN =head1 SYNOPSIS cpanm Test::More # install Test::More cpanm MIYAGAWA/Plack-0.99_05.tar.gz # full distribution path cpanm http://example.org/LDS/CGI.pm-3.20.tar.gz # install from URL cpanm ~/dists/MyCompany-Enterprise-1.00.tar.gz # install from a local file cpanm --interactive Task::Kensho # Configure interactively cpanm . # install from local directory cpanm --installdeps . # install all the deps for the current directory cpanm -L extlib Plack # install Plack and all non-core deps into extlib cpanm --mirror http://cpan.cpantesters.org/ DBI # use the fast-syncing mirror cpanm --from https://cpan.metacpan.org/ Plack # use only the HTTPS mirror =head1 COMMANDS =over 4 =item (arguments) Command line arguments can be either a module name, distribution file, local file path, HTTP URL or git repository URL. Following commands will all work as you expect. cpanm Plack cpanm Plack/Request.pm cpanm MIYAGAWA/Plack-1.0000.tar.gz cpanm /path/to/Plack-1.0000.tar.gz cpanm http://cpan.metacpan.org/authors/id/M/MI/MIYAGAWA/Plack-0.9990.tar.gz cpanm git://github.com/plack/Plack.git Additionally, you can use the notation using C<~> and C<@> to specify version for a given module. C<~> specifies the version requirement in the L<CPAN::Meta::Spec> format, while C<@> pins the exact version, and is a shortcut for C<~"== VERSION">. cpanm Plack~1.0000 # 1.0000 or later cpanm Plack~">= 1.0000, < 2.0000" # latest of 1.xxxx cpanm Plack@0.9990 # specific version. same as Plack~"== 0.9990" The version query including specific version or range will be sent to L<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. For a git repository, you can specify a branch, tag, or commit SHA to build. The default is C<master> cpanm git://github.com/plack/Plack.git@1.0000 # tag cpanm git://github.com/plack/Plack.git@devel # branch =item -i, --install Installs the modules. This is a default behavior and this is just a compatibility option to make it work like L<cpan> or L<cpanp>. =item --self-upgrade Upgrades itself. It's just an alias for: cpanm App::cpanminus =item --info Displays the distribution information in C<AUTHOR/Dist-Name-ver.tar.gz> format in the standard out. =item --installdeps Installs the dependencies of the target distribution but won't build itself. Handy if you want to try the application from a version controlled repository such as git. cpanm --installdeps . =item --look Download and unpack the distribution and then open the directory with your shell. Handy to poke around the source code or do manual testing. =item -h, --help Displays the help message. =item -V, --version Displays the version number. =back =head1 OPTIONS You can specify the default options in C<PERL_CPANM_OPT> environment variable. =over 4 =item -f, --force Force install modules even when testing failed. =item -n, --notest Skip the testing of modules. Use this only when you just want to save time for installing hundreds of distributions to the same perl and architecture you've already tested to make sure it builds fine. Defaults to false, and you can say C<--no-notest> to override when it is set in the default options in C<PERL_CPANM_OPT>. =item --test-only Run the tests only, and do not install the specified module or distributions. Handy if you want to verify the new (or even old) releases pass its unit tests without installing the module. Note that if you specify this option with a module or distribution that has dependencies, these dependencies will be installed if you don't currently have them. =item -S, --sudo Switch to the root user with C<sudo> when installing modules. Use this if you want to install modules to the system perl include path. Defaults to false, and you can say C<--no-sudo> to override when it is set in the default options in C<PERL_CPANM_OPT>. =item -v, --verbose Makes the output verbose. It also enables the interactive configuration. (See --interactive) =item -q, --quiet Makes the output even more quiet than the default. It only shows the successful/failed dependencies to the output. =item -l, --local-lib Sets the L<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. =item -L, --local-lib-contained Same with C<--local-lib> but with L<--self-contained> set. All non-core dependencies will be installed even if they're already installed. For instance, cpanm -L extlib Plack would install Plack and all of its non-core dependencies into the directory C<extlib>, which can be loaded from your application with: use local::lib '/path/to/extlib'; 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. =item --self-contained When examining the dependencies, assume no non-core modules are installed on the system. Handy if you want to bundle application dependencies in one directory so you can distribute to other machines. =item --exclude-vendor Don't include modules installed under the 'vendor' paths when searching for core modules when the C<--self-contained> flag is in effect. This restores the behaviour from before version 1.7023 =item --mirror Specifies the base URL for the CPAN mirror to use, such as C<http://cpan.cpantesters.org/> (you can omit the trailing slash). You can specify multiple mirror URLs by repeating the command line option. You can use a local directory that has a CPAN mirror structure (created by tools such as L<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. cpanm --mirror file:///path/to/mirror cpanm --mirror ~/minicpan # Because shell expands ~ to /home/user Defaults to C<http://www.cpan.org/>. =item --mirror-only Download the mirror's 02packages.details.txt.gz index file instead of querying the CPAN Meta DB. This will also effectively opt out sending your local perl versions to backend database servers such as CPAN Meta DB and MetaCPAN. Select this option if you are using a local mirror of CPAN, such as minicpan when you're offline, or your own CPAN index (a.k.a darkpan). =item --from, -M cpanm -M https://cpan.metacpan.org/ cpanm --from https://cpan.metacpan.org/ Use the given mirror URL and its index as the I<only> source to search and download modules from. It works similar to C<--mirror> and C<--mirror-only> combined, with a small difference: unlike C<--mirror> which I<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. B<Tip:> It might be useful if you name these options with your shell aliases, like: alias minicpanm='cpanm --from ~/minicpan' alias darkpan='cpanm --from http://mycompany.example.com/DPAN' =item --mirror-index B<EXPERIMENTAL>: Specifies the file path to C<02packages.details.txt> for module search index. =item --cpanmetadb B<EXPERIMENTAL>: Specifies an alternate URI for CPAN MetaDB index lookups. =item --metacpan Prefers MetaCPAN API over CPAN MetaDB. =item --cpanfile B<EXPERIMENTAL>: Specified an alternate path for cpanfile to search for, when C<--installdeps> command is in use. Defaults to C<cpanfile>. =item --prompt Prompts when a test fails so that you can skip, force install, retry or look in the shell to see what's going wrong. It also prompts when one of the dependency failed if you want to proceed the installation. Defaults to false, and you can say C<--no-prompt> to override if it's set in the default options in C<PERL_CPANM_OPT>. =item --dev B<EXPERIMENTAL>: search for a newer developer release as well. Defaults to false. =item --reinstall cpanm, when given a module name in the command line (i.e. C<cpanm Plack>), checks the locally installed version first and skips if it is already installed. This option makes it skip the check, so: cpanm --reinstall Plack would reinstall L<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). Defaults to false. =item --interactive 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. 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>. =item --pp, --pureperl 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. =item --with-recommends, --with-suggests 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. 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. There's also C<--without-recommend> and C<--without-suggests> to override the default decision made earlier in C<PERL_CPANM_OPT>. Defaults to false for both. =item --with-develop B<EXPERIMENTAL>: Installs develop phase dependencies in META files or C<cpanfile> when used with C<--installdeps>. Defaults to false. =item --with-configure B<EXPERIMENTAL>: Installs configure phase dependencies in C<cpanfile> when used with C<--installdeps>. Defaults to false. =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. cpanm --with-feature=opt_csv Spreadsheet::Read the features can also be interactively chosen when C<--interactive> option is enabled. C<--with-all-features> enables all the optional features, and C<--without-feature> can select a feature to disable. =item --configure-timeout, --build-timeout, --test-timeout Specify the timeout length (in seconds) to wait for the configure, build and test process. Current default values are: 60 for configure, 3600 for build and 1800 for test. =item --configure-args, --build-args, --test-args, --install-args B<EXPERIMENTAL>: Pass arguments for configure/build/test/install commands respectively, for a given module to install. cpanm DBD::mysql --configure-args="--cflags=... --libs=..." The argument is only enabled for the module passed as a command line argument, not dependencies. =item --scandeps B<DEPRECATED>: Scans the depencencies of given modules and output the tree in a text format. (See C<--format> below for more options) Because this command doesn't actually install any distributions, it will be useful that by typing: cpanm --scandeps Catalyst::Runtime you can make sure what modules will be installed. This command takes into account which modules you already have installed in your system. If you want to see what modules will be installed against a vanilla perl installation, you might want to combine it with C<-L> option. =item --format B<DEPRECATED>: Determines what format to display the scanned dependency tree. Available options are C<tree>, C<json>, C<yaml> and C<dists>. =over 8 =item tree Displays the tree in a plain text format. This is the default value. =item json, yaml Outputs the tree in a JSON or YAML format. L<JSON> and L<YAML> modules need to be installed respectively. The output tree is represented as a recursive tuple of: [ distribution, dependencies ] and the container is an array containing the root elements. Note that there may be multiple root nodes, since you can give multiple modules to the C<--scandeps> command. =item dists C<dists> is a special output format, where it prints the distribution filename in the I<depth first order> after the dependency resolution, like: GAAS/MIME-Base64-3.13.tar.gz GAAS/URI-1.58.tar.gz PETDANCE/HTML-Tagset-3.20.tar.gz GAAS/HTML-Parser-3.68.tar.gz GAAS/libwww-perl-5.837.tar.gz which means you can install these distributions in this order without extra dependencies. When combined with C<-L> option, it will be useful to replay installations on other machines. =back =item --save-dists Specifies the optional directory path to copy downloaded tarballs in the CPAN mirror compatible directory structure i.e. I<authors/id/A/AU/AUTHORS/Foo-Bar-version.tar.gz> 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>. =item --uninst-shadows Uninstalls the shadow files of the distribution that you're installing. This eliminates the confusion if you're trying to install core (dual-life) modules from CPAN against perl 5.10 or older, or modules that used to be XS-based but switched to pure perl at some version. If you run cpanm as root and use C<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. Defaults to true if your perl version is smaller than 5.12, and you can disable that with C<--no-uninst-shadows>. 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. =item --uninstall, -U Uninstalls a module from the library path. It finds a packlist for given modules, and removes all the files included in the same distribution. If you enable local::lib, it only removes files from the local::lib directory. If you try to uninstall a module in C<perl> directory (i.e. core module), an error will be thrown. A dialog will be prompted to confirm the files to be deleted. If you pass C<-f> option as well, the dialog will be skipped and uninstallation will be forced. =item --cascade-search B<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. =item --skip-installed Specifies whether a module given in the command line is skipped if its latest version is already installed. Defaults to true. B<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. =item --skip-satisfied B<EXPERIMENTAL>: Specifies whether a module (and version) given in the command line is skipped if it's already installed. If you run: cpanm --skip-satisfied CGI DBI~1.2 cpanm won't install them if you already have CGI (for whatever versions) or have DBI with version higher than 1.2. It is similar to C<--skip-installed> but while C<--skip-installed> checks if the I<latest> version of CPAN is installed, C<--skip-satisfied> checks if a requested version (or not, which means any version) is installed. Defaults to false. =item --verify Verify the integrity of distribution files retrieved from CPAN using CHECKSUMS file, and SIGNATURES file (if found in the distribution). Defaults to false. Using this option does not verify the integrity of the CHECKSUMS file, and it's unsafe to rely on this option if you're using a CPAN mirror that you do not trust. =item --report-perl-version Whether it reports the locally installed perl version to the various web server as part of User-Agent. Defaults to true unless CI related environment variables such as C<TRAVIS>, C<CI> or C<AUTOMATED_TESTING> is enabled. You can disable it by using C<--no-report-perl-version>. =item --auto-cleanup Specifies the number of days in which cpanm's work directories expire. Defaults to 7, which means old work directories will be cleaned up in one week. You can set the value to C<0> to make cpan never cleanup those directories. =item --man-pages Generates man pages for executables (man1) and libraries (man3). Defaults to true (man pages generated) unless C<-L|--local-lib-contained> option is supplied in which case it's set to false. You can disable it with C<--no-man-pages>. =item --lwp Uses L<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. =item --wget Uses GNU Wget (if available) to download stuff. Defaults to true, and you can say C<--no-wget> to disable using Wget (versions of Wget older than 1.9 don't support the C<--retry-connrefused> option used by cpanm). =item --curl Uses cURL (if available) to download stuff. Defaults to true, and you can say C<--no-curl> to disable using cURL. Normally with C<--lwp>, C<--wget> and C<--curl> options set to true (which is the default) cpanm tries L<LWP>, Wget, cURL and L<HTTP::Tiny> (in that order) and uses the first one available. =back =head1 ENVIRONMENT VARIABLES =over 4 =item PERL_CPANM_HOME 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. =item PERL_CPANM_OPT If set, adds a set of default options to every cpanm command. These options come first, and so are overridden by command-line options. =back =head1 SEE ALSO L<App::cpanminus> =head1 COPYRIGHT Copyright 2010- Tatsuhiko Miyagawa. =head1 AUTHOR Tatsuhiko Miyagawa =cut PK jA[��b b ' blib/man3/App::cpanminus::fatscript.3pmnu �[��� .\" Automatically generated by Pod::Man 4.14 (Pod::Simple 3.42) .\" .\" Standard preamble: .\" ======================================================================== .de Sp \" Vertical space (when we can't use .PP) .if t .sp .5v .if n .sp .. .de Vb \" Begin verbatim text .ft CW .nf .ne \\$1 .. .de Ve \" End verbatim text .ft R .fi .. .\" Set up some character translations and predefined strings. \*(-- will .\" give an unbreakable dash, \*(PI will give pi, \*(L" will give a left .\" double quote, and \*(R" will give a right double quote. \*(C+ will .\" give a nicer C++. Capital omega is used to do unbreakable dashes and .\" therefore won't be available. \*(C` and \*(C' expand to `' in nroff, .\" nothing in troff, for use with C<>. .tr \(*W- .ds C+ C\v'-.1v'\h'-1p'\s-2+\h'-1p'+\s0\v'.1v'\h'-1p' .ie n \{\ . ds -- \(*W- . ds PI pi . if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch . if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch . ds L" "" . ds R" "" . ds C` "" . ds C' "" 'br\} .el\{\ . ds -- \|\(em\| . ds PI \(*p . ds L" `` . ds R" '' . ds C` . ds C' 'br\} .\" .\" Escape single quotes in literal strings from groff's Unicode transform. .ie \n(.g .ds Aq \(aq .el .ds Aq ' .\" .\" If the F register is >0, we'll generate index entries on stderr for .\" titles (.TH), headers (.SH), subsections (.SS), items (.Ip), and index .\" entries marked with X<> in POD. Of course, you'll have to process the .\" output yourself in some meaningful fashion. .\" .\" Avoid warning from groff about undefined register 'F'. .de IX .. .nr rF 0 .if \n(.g .if rF .nr rF 1 .if (\n(rF:(\n(.g==0)) \{\ . if \nF \{\ . de IX . tm Index:\\$1\t\\n%\t"\\$2" .. . if !\nF==2 \{\ . nr % 0 . nr F 2 . \} . \} .\} .rr rF .\" ======================================================================== .\" .IX Title "App::cpanminus::fatscript 3" .TH App::cpanminus::fatscript 3 "2023-07-30" "perl v5.32.1" "User Contributed Perl Documentation" .\" For nroff, turn off justification. Always turn off hyphenation; it makes .\" way too many mistakes in technical documents. .if n .ad l .nh .SH "NAME" cpanm \- get, unpack build and install modules from CPAN .SH "SYNOPSIS" .IX Header "SYNOPSIS" .Vb 10 \& 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 .Ve .SH "COMMANDS" .IX Header "COMMANDS" .IP "(arguments)" 4 .IX Item "(arguments)" Command line arguments can be either a module name, distribution file, local file path, \s-1HTTP URL\s0 or git repository \s-1URL.\s0 Following commands will all work as you expect. .Sp .Vb 6 \& 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 .Ve .Sp Additionally, you can use the notation using \f(CW\*(C`~\*(C'\fR and \f(CW\*(C`@\*(C'\fR to specify version for a given module. \f(CW\*(C`~\*(C'\fR specifies the version requirement in the CPAN::Meta::Spec format, while \f(CW\*(C`@\*(C'\fR pins the exact version, and is a shortcut for \f(CW\*(C`~"== VERSION"\*(C'\fR. .Sp .Vb 3 \& 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" .Ve .Sp The version query including specific version or range will be sent to MetaCPAN to search for previous releases. The query will search for BackPAN archives by default, unless you specify \f(CW\*(C`\-\-dev\*(C'\fR option, in which case, archived versions will be filtered out. .Sp For a git repository, you can specify a branch, tag, or commit \s-1SHA\s0 to build. The default is \f(CW\*(C`master\*(C'\fR .Sp .Vb 2 \& cpanm git://github.com/plack/Plack.git@1.0000 # tag \& cpanm git://github.com/plack/Plack.git@devel # branch .Ve .IP "\-i, \-\-install" 4 .IX Item "-i, --install" Installs the modules. This is a default behavior and this is just a compatibility option to make it work like cpan or cpanp. .IP "\-\-self\-upgrade" 4 .IX Item "--self-upgrade" Upgrades itself. It's just an alias for: .Sp .Vb 1 \& cpanm App::cpanminus .Ve .IP "\-\-info" 4 .IX Item "--info" Displays the distribution information in \&\f(CW\*(C`AUTHOR/Dist\-Name\-ver.tar.gz\*(C'\fR format in the standard out. .IP "\-\-installdeps" 4 .IX Item "--installdeps" Installs the dependencies of the target distribution but won't build itself. Handy if you want to try the application from a version controlled repository such as git. .Sp .Vb 1 \& cpanm \-\-installdeps . .Ve .IP "\-\-look" 4 .IX Item "--look" Download and unpack the distribution and then open the directory with your shell. Handy to poke around the source code or do manual testing. .IP "\-h, \-\-help" 4 .IX Item "-h, --help" Displays the help message. .IP "\-V, \-\-version" 4 .IX Item "-V, --version" Displays the version number. .SH "OPTIONS" .IX Header "OPTIONS" You can specify the default options in \f(CW\*(C`PERL_CPANM_OPT\*(C'\fR environment variable. .IP "\-f, \-\-force" 4 .IX Item "-f, --force" Force install modules even when testing failed. .IP "\-n, \-\-notest" 4 .IX Item "-n, --notest" Skip the testing of modules. Use this only when you just want to save time for installing hundreds of distributions to the same perl and architecture you've already tested to make sure it builds fine. .Sp Defaults to false, and you can say \f(CW\*(C`\-\-no\-notest\*(C'\fR to override when it is set in the default options in \f(CW\*(C`PERL_CPANM_OPT\*(C'\fR. .IP "\-\-test\-only" 4 .IX Item "--test-only" Run the tests only, and do not install the specified module or distributions. Handy if you want to verify the new (or even old) releases pass its unit tests without installing the module. .Sp 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. .IP "\-S, \-\-sudo" 4 .IX Item "-S, --sudo" Switch to the root user with \f(CW\*(C`sudo\*(C'\fR when installing modules. Use this if you want to install modules to the system perl include path. .Sp Defaults to false, and you can say \f(CW\*(C`\-\-no\-sudo\*(C'\fR to override when it is set in the default options in \f(CW\*(C`PERL_CPANM_OPT\*(C'\fR. .IP "\-v, \-\-verbose" 4 .IX Item "-v, --verbose" Makes the output verbose. It also enables the interactive configuration. (See \-\-interactive) .IP "\-q, \-\-quiet" 4 .IX Item "-q, --quiet" Makes the output even more quiet than the default. It only shows the successful/failed dependencies to the output. .IP "\-l, \-\-local\-lib" 4 .IX Item "-l, --local-lib" Sets the local::lib compatible path to install modules to. You don't need to set this if you already configure the shell environment variables using local::lib, but this can be used to override that as well. .IP "\-L, \-\-local\-lib\-contained" 4 .IX Item "-L, --local-lib-contained" Same with \f(CW\*(C`\-\-local\-lib\*(C'\fR but with \-\-self\-contained set. All non-core dependencies will be installed even if they're already installed. .Sp For instance, .Sp .Vb 1 \& cpanm \-L extlib Plack .Ve .Sp would install Plack and all of its non-core dependencies into the directory \f(CW\*(C`extlib\*(C'\fR, which can be loaded from your application with: .Sp .Vb 1 \& use local::lib \*(Aq/path/to/extlib\*(Aq; .Ve .Sp Note that this option does \fB\s-1NOT\s0\fR reliably work with perl installations supplied by operating system vendors that strips standard modules from perl, such as \s-1RHEL,\s0 Fedora and CentOS, \fB\s-1UNLESS\s0\fR you also install packages supplying all the modules that have been stripped. For these systems you will probably want to install the \f(CW\*(C`perl\-core\*(C'\fR meta-package which does just that. .IP "\-\-self\-contained" 4 .IX Item "--self-contained" When examining the dependencies, assume no non-core modules are installed on the system. Handy if you want to bundle application dependencies in one directory so you can distribute to other machines. .IP "\-\-exclude\-vendor" 4 .IX Item "--exclude-vendor" Don't include modules installed under the 'vendor' paths when searching for core modules when the \f(CW\*(C`\-\-self\-contained\*(C'\fR flag is in effect. This restores the behaviour from before version 1.7023 .IP "\-\-mirror" 4 .IX Item "--mirror" Specifies the base \s-1URL\s0 for the \s-1CPAN\s0 mirror to use, such as \&\f(CW\*(C`http://cpan.cpantesters.org/\*(C'\fR (you can omit the trailing slash). You can specify multiple mirror URLs by repeating the command line option. .Sp You can use a local directory that has a \s-1CPAN\s0 mirror structure (created by tools such as OrePAN or Pinto) by using a special \&\s-1URL\s0 scheme \f(CW\*(C`file://\*(C'\fR. If the given \s-1URL\s0 begins with `/` (without any scheme), it is considered as a file scheme as well. .Sp .Vb 2 \& cpanm \-\-mirror file:///path/to/mirror \& cpanm \-\-mirror ~/minicpan # Because shell expands ~ to /home/user .Ve .Sp Defaults to \f(CW\*(C`http://www.cpan.org/\*(C'\fR. .IP "\-\-mirror\-only" 4 .IX Item "--mirror-only" Download the mirror's 02packages.details.txt.gz index file instead of querying the \s-1CPAN\s0 Meta \s-1DB.\s0 This will also effectively opt out sending your local perl versions to backend database servers such as \s-1CPAN\s0 Meta \&\s-1DB\s0 and MetaCPAN. .Sp Select this option if you are using a local mirror of \s-1CPAN,\s0 such as minicpan when you're offline, or your own \s-1CPAN\s0 index (a.k.a darkpan). .IP "\-\-from, \-M" 4 .IX Item "--from, -M" .Vb 2 \& cpanm \-M https://cpan.metacpan.org/ \& cpanm \-\-from https://cpan.metacpan.org/ .Ve .Sp Use the given mirror \s-1URL\s0 and its index as the \fIonly\fR source to search and download modules from. .Sp It works similar to \f(CW\*(C`\-\-mirror\*(C'\fR and \f(CW\*(C`\-\-mirror\-only\*(C'\fR combined, with a small difference: unlike \f(CW\*(C`\-\-mirror\*(C'\fR which \fIappends\fR the \s-1URL\s0 to the list of mirrors, \f(CW\*(C`\-\-from\*(C'\fR (or \f(CW\*(C`\-M\*(C'\fR for short) uses the specified \s-1URL\s0 as its \fIonly\fR 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 \f(CW\*(C`PERL_CPANM_OPT\*(C'\fR environment variable. .Sp \&\fBTip:\fR It might be useful if you name these options with your shell aliases, like: .Sp .Vb 2 \& alias minicpanm=\*(Aqcpanm \-\-from ~/minicpan\*(Aq \& alias darkpan=\*(Aqcpanm \-\-from http://mycompany.example.com/DPAN\*(Aq .Ve .IP "\-\-mirror\-index" 4 .IX Item "--mirror-index" \&\fB\s-1EXPERIMENTAL\s0\fR: Specifies the file path to \f(CW\*(C`02packages.details.txt\*(C'\fR for module search index. .IP "\-\-cpanmetadb" 4 .IX Item "--cpanmetadb" \&\fB\s-1EXPERIMENTAL\s0\fR: Specifies an alternate \s-1URI\s0 for \s-1CPAN\s0 MetaDB index lookups. .IP "\-\-metacpan" 4 .IX Item "--metacpan" Prefers MetaCPAN \s-1API\s0 over \s-1CPAN\s0 MetaDB. .IP "\-\-cpanfile" 4 .IX Item "--cpanfile" \&\fB\s-1EXPERIMENTAL\s0\fR: Specified an alternate path for cpanfile to search for, when \f(CW\*(C`\-\-installdeps\*(C'\fR command is in use. Defaults to \f(CW\*(C`cpanfile\*(C'\fR. .IP "\-\-prompt" 4 .IX Item "--prompt" Prompts when a test fails so that you can skip, force install, retry or look in the shell to see what's going wrong. It also prompts when one of the dependency failed if you want to proceed the installation. .Sp Defaults to false, and you can say \f(CW\*(C`\-\-no\-prompt\*(C'\fR to override if it's set in the default options in \f(CW\*(C`PERL_CPANM_OPT\*(C'\fR. .IP "\-\-dev" 4 .IX Item "--dev" \&\fB\s-1EXPERIMENTAL\s0\fR: search for a newer developer release as well. Defaults to false. .IP "\-\-reinstall" 4 .IX Item "--reinstall" cpanm, when given a module name in the command line (i.e. \f(CW\*(C`cpanm Plack\*(C'\fR), checks the locally installed version first and skips if it is already installed. This option makes it skip the check, so: .Sp .Vb 1 \& cpanm \-\-reinstall Plack .Ve .Sp would reinstall 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). .Sp Defaults to false. .IP "\-\-interactive" 4 .IX Item "--interactive" Makes the configuration (such as \f(CW\*(C`Makefile.PL\*(C'\fR and \f(CW\*(C`Build.PL\*(C'\fR) interactive, so you can answer questions in the distribution that requires custom configuration or Task:: distributions. .Sp Defaults to false, and you can say \f(CW\*(C`\-\-no\-interactive\*(C'\fR to override when it's set in the default options in \f(CW\*(C`PERL_CPANM_OPT\*(C'\fR. .IP "\-\-pp, \-\-pureperl" 4 .IX Item "--pp, --pureperl" Prefer Pure perl build of modules by setting \f(CW\*(C`PUREPERL_ONLY=1\*(C'\fR for MakeMaker and \f(CW\*(C`\-\-pureperl\-only\*(C'\fR for Build.PL based distributions. Note that not all of the \s-1CPAN\s0 modules support this convention yet. .IP "\-\-with\-recommends, \-\-with\-suggests" 4 .IX Item "--with-recommends, --with-suggests" \&\fB\s-1EXPERIMENTAL\s0\fR: Installs dependencies declared as \f(CW\*(C`recommends\*(C'\fR and \&\f(CW\*(C`suggests\*(C'\fR respectively, per \s-1META\s0 spec. When these dependencies fail to install, cpanm continues the installation, since they're just recommendation/suggestion. .Sp Enabling this could potentially make a circular dependency for a few modules on \s-1CPAN,\s0 when \f(CW\*(C`recommends\*(C'\fR adds a module that \f(CW\*(C`recommends\*(C'\fR back the module in return. .Sp There's also \f(CW\*(C`\-\-without\-recommend\*(C'\fR and \f(CW\*(C`\-\-without\-suggests\*(C'\fR to override the default decision made earlier in \f(CW\*(C`PERL_CPANM_OPT\*(C'\fR. .Sp Defaults to false for both. .IP "\-\-with\-develop" 4 .IX Item "--with-develop" \&\fB\s-1EXPERIMENTAL\s0\fR: Installs develop phase dependencies in \s-1META\s0 files or \&\f(CW\*(C`cpanfile\*(C'\fR when used with \f(CW\*(C`\-\-installdeps\*(C'\fR. Defaults to false. .IP "\-\-with\-configure" 4 .IX Item "--with-configure" \&\fB\s-1EXPERIMENTAL\s0\fR: Installs configure phase dependencies in \f(CW\*(C`cpanfile\*(C'\fR when used with \f(CW\*(C`\-\-installdeps\*(C'\fR. Defaults to false. .IP "\-\-with\-feature, \-\-without\-feature, \-\-with\-all\-features" 4 .IX Item "--with-feature, --without-feature, --with-all-features" \&\fB\s-1EXPERIMENTAL\s0\fR: Specifies the feature to enable, if a module supports optional features per \s-1META\s0 spec 2.0. .Sp .Vb 1 \& cpanm \-\-with\-feature=opt_csv Spreadsheet::Read .Ve .Sp the features can also be interactively chosen when \f(CW\*(C`\-\-interactive\*(C'\fR option is enabled. .Sp \&\f(CW\*(C`\-\-with\-all\-features\*(C'\fR enables all the optional features, and \&\f(CW\*(C`\-\-without\-feature\*(C'\fR can select a feature to disable. .IP "\-\-configure\-timeout, \-\-build\-timeout, \-\-test\-timeout" 4 .IX Item "--configure-timeout, --build-timeout, --test-timeout" Specify the timeout length (in seconds) to wait for the configure, build and test process. Current default values are: 60 for configure, 3600 for build and 1800 for test. .IP "\-\-configure\-args, \-\-build\-args, \-\-test\-args, \-\-install\-args" 4 .IX Item "--configure-args, --build-args, --test-args, --install-args" \&\fB\s-1EXPERIMENTAL\s0\fR: Pass arguments for configure/build/test/install commands respectively, for a given module to install. .Sp .Vb 1 \& cpanm DBD::mysql \-\-configure\-args="\-\-cflags=... \-\-libs=..." .Ve .Sp The argument is only enabled for the module passed as a command line argument, not dependencies. .IP "\-\-scandeps" 4 .IX Item "--scandeps" \&\fB\s-1DEPRECATED\s0\fR: Scans the depencencies of given modules and output the tree in a text format. (See \f(CW\*(C`\-\-format\*(C'\fR below for more options) .Sp Because this command doesn't actually install any distributions, it will be useful that by typing: .Sp .Vb 1 \& cpanm \-\-scandeps Catalyst::Runtime .Ve .Sp you can make sure what modules will be installed. .Sp 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 \f(CW\*(C`\-L\*(C'\fR option. .IP "\-\-format" 4 .IX Item "--format" \&\fB\s-1DEPRECATED\s0\fR: Determines what format to display the scanned dependency tree. Available options are \f(CW\*(C`tree\*(C'\fR, \f(CW\*(C`json\*(C'\fR, \f(CW\*(C`yaml\*(C'\fR and \&\f(CW\*(C`dists\*(C'\fR. .RS 4 .IP "tree" 8 .IX Item "tree" Displays the tree in a plain text format. This is the default value. .IP "json, yaml" 8 .IX Item "json, yaml" Outputs the tree in a \s-1JSON\s0 or \s-1YAML\s0 format. \s-1JSON\s0 and \s-1YAML\s0 modules need to be installed respectively. The output tree is represented as a recursive tuple of: .Sp .Vb 1 \& [ distribution, dependencies ] .Ve .Sp 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 \f(CW\*(C`\-\-scandeps\*(C'\fR command. .IP "dists" 8 .IX Item "dists" \&\f(CW\*(C`dists\*(C'\fR is a special output format, where it prints the distribution filename in the \fIdepth first order\fR after the dependency resolution, like: .Sp .Vb 5 \& 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 .Ve .Sp which means you can install these distributions in this order without extra dependencies. When combined with \f(CW\*(C`\-L\*(C'\fR option, it will be useful to replay installations on other machines. .RE .RS 4 .RE .IP "\-\-save\-dists" 4 .IX Item "--save-dists" Specifies the optional directory path to copy downloaded tarballs in the \s-1CPAN\s0 mirror compatible directory structure i.e. \fIauthors/id/A/AU/AUTHORS/Foo\-Bar\-version.tar.gz\fR .Sp If the distro tarball did not come from \s-1CPAN,\s0 for example from a local file or from GitHub, then it will be saved under \&\fIvendor/Foo\-Bar\-version.tar.gz\fR. .IP "\-\-uninst\-shadows" 4 .IX Item "--uninst-shadows" Uninstalls the shadow files of the distribution that you're installing. This eliminates the confusion if you're trying to install core (dual-life) modules from \s-1CPAN\s0 against perl 5.10 or older, or modules that used to be XS-based but switched to pure perl at some version. .Sp If you run cpanm as root and use \f(CW\*(C`INSTALL_BASE\*(C'\fR or equivalent to specify custom installation path, you \s-1SHOULD\s0 disable this option so you won't accidentally uninstall dual-life modules from the core include path. .Sp Defaults to true if your perl version is smaller than 5.12, and you can disable that with \f(CW\*(C`\-\-no\-uninst\-shadows\*(C'\fR. .Sp \&\fB\s-1NOTE\s0\fR: Since version 1.3000 this flag is turned off by default for perl newer than 5.12, since with 5.12 \f(CW@INC\fR contains site_perl directory \&\fIbefore\fR the perl core library path, and uninstalling shadows is not necessary anymore and does more harm by deleting files from the core library path. .IP "\-\-uninstall, \-U" 4 .IX Item "--uninstall, -U" Uninstalls a module from the library path. It finds a packlist for given modules, and removes all the files included in the same distribution. .Sp If you enable local::lib, it only removes files from the local::lib directory. .Sp If you try to uninstall a module in \f(CW\*(C`perl\*(C'\fR directory (i.e. core module), an error will be thrown. .Sp A dialog will be prompted to confirm the files to be deleted. If you pass \&\f(CW\*(C`\-f\*(C'\fR option as well, the dialog will be skipped and uninstallation will be forced. .IP "\-\-cascade\-search" 4 .IX Item "--cascade-search" \&\fB\s-1EXPERIMENTAL\s0\fR: 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. .IP "\-\-skip\-installed" 4 .IX Item "--skip-installed" Specifies whether a module given in the command line is skipped if its latest version is already installed. Defaults to true. .Sp \&\fB\s-1NOTE\s0\fR: The \f(CW\*(C`PERL5LIB\*(C'\fR environment variable have to be correctly set for this to work with modules installed using local::lib, unless you always use the \f(CW\*(C`\-l\*(C'\fR option. .IP "\-\-skip\-satisfied" 4 .IX Item "--skip-satisfied" \&\fB\s-1EXPERIMENTAL\s0\fR: Specifies whether a module (and version) given in the command line is skipped if it's already installed. .Sp If you run: .Sp .Vb 1 \& cpanm \-\-skip\-satisfied CGI DBI~1.2 .Ve .Sp cpanm won't install them if you already have \s-1CGI\s0 (for whatever versions) or have \s-1DBI\s0 with version higher than 1.2. It is similar to \&\f(CW\*(C`\-\-skip\-installed\*(C'\fR but while \f(CW\*(C`\-\-skip\-installed\*(C'\fR checks if the \&\fIlatest\fR version of \s-1CPAN\s0 is installed, \f(CW\*(C`\-\-skip\-satisfied\*(C'\fR checks if a requested version (or not, which means any version) is installed. .Sp Defaults to false. .IP "\-\-verify" 4 .IX Item "--verify" Verify the integrity of distribution files retrieved from \s-1CPAN\s0 using \s-1CHECKSUMS\s0 file, and \s-1SIGNATURES\s0 file (if found in the distribution). Defaults to false. .Sp Using this option does not verify the integrity of the \s-1CHECKSUMS\s0 file, and it's unsafe to rely on this option if you're using a \s-1CPAN\s0 mirror that you do not trust. .IP "\-\-report\-perl\-version" 4 .IX Item "--report-perl-version" Whether it reports the locally installed perl version to the various web server as part of User-Agent. Defaults to true unless \s-1CI\s0 related environment variables such as \f(CW\*(C`TRAVIS\*(C'\fR, \f(CW\*(C`CI\*(C'\fR or \f(CW\*(C`AUTOMATED_TESTING\*(C'\fR is enabled. You can disable it by using \f(CW\*(C`\-\-no\-report\-perl\-version\*(C'\fR. .IP "\-\-auto\-cleanup" 4 .IX Item "--auto-cleanup" Specifies the number of days in which cpanm's work directories expire. Defaults to 7, which means old work directories will be cleaned up in one week. .Sp You can set the value to \f(CW0\fR to make cpan never cleanup those directories. .IP "\-\-man\-pages" 4 .IX Item "--man-pages" Generates man pages for executables (man1) and libraries (man3). .Sp Defaults to true (man pages generated) unless \f(CW\*(C`\-L|\-\-local\-lib\-contained\*(C'\fR option is supplied in which case it's set to false. You can disable it with \f(CW\*(C`\-\-no\-man\-pages\*(C'\fR. .IP "\-\-lwp" 4 .IX Item "--lwp" Uses \s-1LWP\s0 module to download stuff over \s-1HTTP.\s0 Defaults to true, and you can say \f(CW\*(C`\-\-no\-lwp\*(C'\fR to disable using \s-1LWP,\s0 when you want to upgrade \&\s-1LWP\s0 from \s-1CPAN\s0 on some broken perl systems. .IP "\-\-wget" 4 .IX Item "--wget" Uses \s-1GNU\s0 Wget (if available) to download stuff. Defaults to true, and you can say \f(CW\*(C`\-\-no\-wget\*(C'\fR to disable using Wget (versions of Wget older than 1.9 don't support the \f(CW\*(C`\-\-retry\-connrefused\*(C'\fR option used by cpanm). .IP "\-\-curl" 4 .IX Item "--curl" Uses cURL (if available) to download stuff. Defaults to true, and you can say \f(CW\*(C`\-\-no\-curl\*(C'\fR to disable using cURL. .Sp Normally with \f(CW\*(C`\-\-lwp\*(C'\fR, \f(CW\*(C`\-\-wget\*(C'\fR and \f(CW\*(C`\-\-curl\*(C'\fR options set to true (which is the default) cpanm tries \s-1LWP\s0, Wget, cURL and HTTP::Tiny (in that order) and uses the first one available. .SH "ENVIRONMENT VARIABLES" .IX Header "ENVIRONMENT VARIABLES" .IP "\s-1PERL_CPANM_HOME\s0" 4 .IX Item "PERL_CPANM_HOME" The directory cpanm should use to store downloads and build and test modules. Defaults to the \f(CW\*(C`.cpanm\*(C'\fR directory in your user's home directory. .IP "\s-1PERL_CPANM_OPT\s0" 4 .IX Item "PERL_CPANM_OPT" If set, adds a set of default options to every cpanm command. These options come first, and so are overridden by command-line options. .SH "SEE ALSO" .IX Header "SEE ALSO" App::cpanminus .SH "COPYRIGHT" .IX Header "COPYRIGHT" Copyright 2010\- Tatsuhiko Miyagawa. .SH "AUTHOR" .IX Header "AUTHOR" Tatsuhiko Miyagawa PK jA[�?��2 2 blib/man3/App::cpanminus.3pmnu �[��� .\" Automatically generated by Pod::Man 4.14 (Pod::Simple 3.42) .\" .\" Standard preamble: .\" ======================================================================== .de Sp \" Vertical space (when we can't use .PP) .if t .sp .5v .if n .sp .. .de Vb \" Begin verbatim text .ft CW .nf .ne \\$1 .. .de Ve \" End verbatim text .ft R .fi .. .\" Set up some character translations and predefined strings. \*(-- will .\" give an unbreakable dash, \*(PI will give pi, \*(L" will give a left .\" double quote, and \*(R" will give a right double quote. \*(C+ will .\" give a nicer C++. Capital omega is used to do unbreakable dashes and .\" therefore won't be available. \*(C` and \*(C' expand to `' in nroff, .\" nothing in troff, for use with C<>. .tr \(*W- .ds C+ C\v'-.1v'\h'-1p'\s-2+\h'-1p'+\s0\v'.1v'\h'-1p' .ie n \{\ . ds -- \(*W- . ds PI pi . if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch . if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch . ds L" "" . ds R" "" . ds C` "" . ds C' "" 'br\} .el\{\ . ds -- \|\(em\| . ds PI \(*p . ds L" `` . ds R" '' . ds C` . ds C' 'br\} .\" .\" Escape single quotes in literal strings from groff's Unicode transform. .ie \n(.g .ds Aq \(aq .el .ds Aq ' .\" .\" If the F register is >0, we'll generate index entries on stderr for .\" titles (.TH), headers (.SH), subsections (.SS), items (.Ip), and index .\" entries marked with X<> in POD. Of course, you'll have to process the .\" output yourself in some meaningful fashion. .\" .\" Avoid warning from groff about undefined register 'F'. .de IX .. .nr rF 0 .if \n(.g .if rF .nr rF 1 .if (\n(rF:(\n(.g==0)) \{\ . if \nF \{\ . de IX . tm Index:\\$1\t\\n%\t"\\$2" .. . if !\nF==2 \{\ . nr % 0 . nr F 2 . \} . \} .\} .rr rF .\" ======================================================================== .\" .IX Title "App::cpanminus 3" .TH App::cpanminus 3 "2023-07-30" "perl v5.32.1" "User Contributed Perl Documentation" .\" For nroff, turn off justification. Always turn off hyphenation; it makes .\" way too many mistakes in technical documents. .if n .ad l .nh .SH "NAME" App::cpanminus \- get, unpack, build and install modules from CPAN .SH "SYNOPSIS" .IX Header "SYNOPSIS" .Vb 1 \& cpanm Module .Ve .PP Run \f(CW\*(C`cpanm \-h\*(C'\fR or \f(CW\*(C`perldoc cpanm\*(C'\fR for more options. .SH "DESCRIPTION" .IX Header "DESCRIPTION" cpanminus is a script to get, unpack, build and install modules from \&\s-1CPAN\s0 and does nothing else. .PP It's dependency free (can bootstrap itself), requires zero configuration, and stands alone. When running, it requires only 10MB of \s-1RAM.\s0 .SH "INSTALLATION" .IX Header "INSTALLATION" There are several ways to install cpanminus to your system. .SS "Package management system" .IX Subsection "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 \f(CW\*(C`cpanm\*(C'\fR to your system without thinking about where to install, and later upgrade. .SS "Installing to system perl" .IX Subsection "Installing to system perl" You can also use the latest cpanminus to install cpanminus itself: .PP .Vb 1 \& curl \-L https://cpanmin.us | perl \- \-\-sudo App::cpanminus .Ve .PP This will install \f(CW\*(C`cpanm\*(C'\fR to your bin directory like \&\f(CW\*(C`/usr/local/bin\*(C'\fR and you'll need the \f(CW\*(C`\-\-sudo\*(C'\fR option to write to the directory, unless you configured \f(CW\*(C`INSTALL_BASE\*(C'\fR with local::lib. .SS "Installing to local perl (perlbrew, plenv etc.)" .IX Subsection "Installing to local perl (perlbrew, plenv etc.)" If you have perl in your home directory, which is the case if you use tools like perlbrew or plenv, you don't need the \f(CW\*(C`\-\-sudo\*(C'\fR option, since you're most likely to have a write permission to the perl's library path. You can just do: .PP .Vb 1 \& curl \-L https://cpanmin.us | perl \- App::cpanminus .Ve .PP to install the \f(CW\*(C`cpanm\*(C'\fR executable to the perl's bin path, like \&\f(CW\*(C`~/perl5/perlbrew/bin/cpanm\*(C'\fR. .SS "Downloading the standalone executable" .IX Subsection "Downloading the standalone executable" You can also copy the standalone executable to whatever location you'd like. .PP .Vb 3 \& cd ~/bin \& curl \-L https://cpanmin.us/ \-o cpanm \& chmod +x cpanm .Ve .PP This just works, but be sure to grab the new version manually when you upgrade because \f(CW\*(C`\-\-self\-upgrade\*(C'\fR might not work with this installation setup. .SS "Troubleshoot: \s-1HTTPS\s0 warnings" .IX Subsection "Troubleshoot: HTTPS warnings" When you run \f(CW\*(C`curl\*(C'\fR commands above, you may encounter \s-1SSL\s0 handshake errors or certification warnings. This is due to your \s-1HTTP\s0 client (curl) being old, or \s-1SSL\s0 certificates installed on your system needs to be updated. .PP You're recommended to update the software or system if you can. If that is impossible or difficult, use the \f(CW\*(C`\-k\*(C'\fR option with curl. .SH "DEPENDENCIES" .IX Header "DEPENDENCIES" perl 5.8.1 or later. .IP "\(bu" 4 \&'tar' executable (bsdtar or \s-1GNU\s0 tar version 1.22 are recommended) or Archive::Tar to unpack files. .IP "\(bu" 4 C compiler, if you want to build \s-1XS\s0 modules. .IP "\(bu" 4 make .IP "\(bu" 4 Module::Build (core in 5.10) .SH "QUESTIONS" .IX Header "QUESTIONS" .SS "How does cpanm get/parse/update the \s-1CPAN\s0 index?" .IX Subsection "How does cpanm get/parse/update the CPAN index?" It queries the \s-1CPAN\s0 Meta \s-1DB\s0 site at <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 <http://metacpan.org/> using its search \s-1API.\s0 .PP Upon calling these \s-1API\s0 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 \f(CW\*(C`\-\-no\-report\-perl\-version\*(C'\fR option. Read more about the option with cpanm, and read more about the privacy policy about this data collection at <http://cpanmetadb.plackperl.org/#privacy> .PP Fetched files are unpacked in \f(CW\*(C`~/.cpanm\*(C'\fR and automatically cleaned up periodically. You can configure the location of this with the \&\f(CW\*(C`PERL_CPANM_HOME\*(C'\fR environment variable. .SS "Where does this install modules to? Do I need root access?" .IX Subsection "Where does this install modules to? Do I need root access?" It installs to wherever ExtUtils::MakeMaker and Module::Build are configured to (via \f(CW\*(C`PERL_MM_OPT\*(C'\fR and \f(CW\*(C`PERL_MB_OPT\*(C'\fR). .PP By default, it installs to the site_perl directory that belongs to your perl. You can see the locations for that by running \f(CW\*(C`perl \-V\*(C'\fR and it will be likely something under \f(CW\*(C`/opt/local/perl/...\*(C'\fR if you're using system perl, or under your home directory if you have built perl yourself using perlbrew or plenv. .PP If you've already configured local::lib on your shell, cpanm respects that settings and modules will be installed to your local perl5 directory. .PP 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 \f(CW\*(C`perl5\*(C'\fR directory under your home directory. .PP To avoid this, run \f(CW\*(C`cpanm\*(C'\fR either as a root user, with \f(CW\*(C`\-\-sudo\*(C'\fR option, or with \f(CW\*(C`\-\-local\-lib\*(C'\fR option. .SS "cpanminus can't install the module \s-1XYZ.\s0 Is it a bug?" .IX Subsection "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: .IP "\(bu" 4 Tests that require input from \s-1STDIN.\s0 .IP "\(bu" 4 Build.PL or Makefile.PL that prompts for input even when \&\f(CW\*(C`PERL_MM_USE_DEFAULT\*(C'\fR is enabled. .IP "\(bu" 4 Modules that have invalid numeric values as \s-1VERSION\s0 (such as \f(CW\*(C`1.1a\*(C'\fR) .PP These failures can be reported back to the author of the module so that they can fix it accordingly, rather than to cpanminus. .SS "Does cpanm support the feature \s-1XYZ\s0 of \s-1CPAN\s0 and \s-1CPANPLUS\s0?" .IX Subsection "Does cpanm support the feature XYZ of CPAN and CPANPLUS?" Most likely not. Here are the things that cpanm doesn't do by itself. .PP If you need these features, use \s-1CPAN\s0, \s-1CPANPLUS\s0 or the standalone tools that are mentioned. .IP "\(bu" 4 \&\s-1CPAN\s0 testers reporting. See App::cpanminus::reporter .IP "\(bu" 4 Building \s-1RPM\s0 packages from \s-1CPAN\s0 modules .IP "\(bu" 4 Listing the outdated modules that needs upgrading. See App::cpanoutdated .IP "\(bu" 4 Showing the changes of the modules you're about to upgrade. See cpan-listchanges .IP "\(bu" 4 Patching \s-1CPAN\s0 modules with distroprefs. .PP See cpanm or \f(CW\*(C`cpanm \-h\*(C'\fR to see what cpanminus \fIcan\fR do :) .SH "COPYRIGHT" .IX Header "COPYRIGHT" Copyright 2010\- Tatsuhiko Miyagawa .PP The standalone executable contains the following modules embedded. .IP "CPAN::DistnameInfo Copyright 2003 Graham Barr" 4 .IX Item "CPAN::DistnameInfo Copyright 2003 Graham Barr" .PD 0 .IP "local::lib Copyright 2007\-2009 Matt S Trout" 4 .IX Item "local::lib Copyright 2007-2009 Matt S Trout" .IP "HTTP::Tiny Copyright 2011 Christian Hansen" 4 .IX Item "HTTP::Tiny Copyright 2011 Christian Hansen" .IP "Module::Metadata Copyright 2001\-2006 Ken Williams. 2010 Matt S Trout" 4 .IX Item "Module::Metadata Copyright 2001-2006 Ken Williams. 2010 Matt S Trout" .IP "version Copyright 2004\-2010 John Peacock" 4 .IX Item "version Copyright 2004-2010 John Peacock" .IP "\s-1JSON::PP\s0 Copyright 2007\-2011 by Makamaka Hannyaharamitu" 4 .IX Item "JSON::PP Copyright 2007-2011 by Makamaka Hannyaharamitu" .IP "CPAN::Meta, CPAN::Meta::Requirements Copyright (c) 2010 by David Golden and Ricardo Signes" 4 .IX Item "CPAN::Meta, CPAN::Meta::Requirements Copyright (c) 2010 by David Golden and Ricardo Signes" .IP "CPAN::Meta::YAML Copyright 2010 Adam Kennedy" 4 .IX Item "CPAN::Meta::YAML Copyright 2010 Adam Kennedy" .IP "CPAN::Meta::Check Copyright (c) 2012 by Leon Timmermans" 4 .IX Item "CPAN::Meta::Check Copyright (c) 2012 by Leon Timmermans" .IP "File::pushd Copyright 2012 David Golden" 4 .IX Item "File::pushd Copyright 2012 David Golden" .IP "parent Copyright (c) 2007\-10 Max Maischein" 4 .IX Item "parent Copyright (c) 2007-10 Max Maischein" .IP "Parse::PMFile Copyright 1995 \- 2013 by Andreas Koenig, Copyright 2013 by Kenichi Ishigaki" 4 .IX Item "Parse::PMFile Copyright 1995 - 2013 by Andreas Koenig, Copyright 2013 by Kenichi Ishigaki" .IP "String::ShellQuote by Roderick Schertler" 4 .IX Item "String::ShellQuote by Roderick Schertler" .PD .SH "LICENSE" .IX Header "LICENSE" This software is licensed under the same terms as Perl. .SH "CREDITS" .IX Header "CREDITS" .SS "\s-1CONTRIBUTORS\s0" .IX Subsection "CONTRIBUTORS" Patches and code improvements were contributed by: .PP Goro Fuji, Kazuhiro Osawa, Tokuhiro Matsuno, Kenichi Ishigaki, Ian Wells, Pedro Melo, Masayoshi Sekimura, Matt S Trout (mst), squeeky, horus and Ingy dot Net. .SS "\s-1ACKNOWLEDGEMENTS\s0" .IX Subsection "ACKNOWLEDGEMENTS" Bug reports, suggestions and feedbacks were sent by, or general acknowledgement goes to: .PP 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. .SH "COMMUNITY" .IX Header "COMMUNITY" .IP "<http://github.com/miyagawa/cpanminus> \- source code repository, issue tracker" 4 .IX Item "<http://github.com/miyagawa/cpanminus> - source code repository, issue tracker" .PD 0 .IP "<irc://irc.perl.org/#cpanm> \- discussions about cpanm and its related tools" 4 .IX Item "<irc://irc.perl.org/#cpanm> - discussions about cpanm and its related tools" .PD .SH "NO WARRANTY" .IX Header "NO WARRANTY" This software is provided \*(L"as-is,\*(R" 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. .SH "SEE ALSO" .IX Header "SEE ALSO" \&\s-1CPAN\s0 \s-1CPANPLUS\s0 pip PK jA[ blib/man3/.existsnu �[��� PK jA[ blib/man1/.existsnu �[��� PK jA[އ�}�a �a blib/man1/cpanm.1nu �[��� .\" Automatically generated by Pod::Man 4.14 (Pod::Simple 3.42) .\" .\" Standard preamble: .\" ======================================================================== .de Sp \" Vertical space (when we can't use .PP) .if t .sp .5v .if n .sp .. .de Vb \" Begin verbatim text .ft CW .nf .ne \\$1 .. .de Ve \" End verbatim text .ft R .fi .. .\" Set up some character translations and predefined strings. \*(-- will .\" give an unbreakable dash, \*(PI will give pi, \*(L" will give a left .\" double quote, and \*(R" will give a right double quote. \*(C+ will .\" give a nicer C++. Capital omega is used to do unbreakable dashes and .\" therefore won't be available. \*(C` and \*(C' expand to `' in nroff, .\" nothing in troff, for use with C<>. .tr \(*W- .ds C+ C\v'-.1v'\h'-1p'\s-2+\h'-1p'+\s0\v'.1v'\h'-1p' .ie n \{\ . ds -- \(*W- . ds PI pi . if (\n(.H=4u)&(1m=24u) .ds -- \(*W\h'-12u'\(*W\h'-12u'-\" diablo 10 pitch . if (\n(.H=4u)&(1m=20u) .ds -- \(*W\h'-12u'\(*W\h'-8u'-\" diablo 12 pitch . ds L" "" . ds R" "" . ds C` "" . ds C' "" 'br\} .el\{\ . ds -- \|\(em\| . ds PI \(*p . ds L" `` . ds R" '' . ds C` . ds C' 'br\} .\" .\" Escape single quotes in literal strings from groff's Unicode transform. .ie \n(.g .ds Aq \(aq .el .ds Aq ' .\" .\" If the F register is >0, we'll generate index entries on stderr for .\" titles (.TH), headers (.SH), subsections (.SS), items (.Ip), and index .\" entries marked with X<> in POD. Of course, you'll have to process the .\" output yourself in some meaningful fashion. .\" .\" Avoid warning from groff about undefined register 'F'. .de IX .. .nr rF 0 .if \n(.g .if rF .nr rF 1 .if (\n(rF:(\n(.g==0)) \{\ . if \nF \{\ . de IX . tm Index:\\$1\t\\n%\t"\\$2" .. . if !\nF==2 \{\ . nr % 0 . nr F 2 . \} . \} .\} .rr rF .\" ======================================================================== .\" .IX Title "CPANM 1" .TH CPANM 1 "2023-07-30" "perl v5.32.1" "User Contributed Perl Documentation" .\" For nroff, turn off justification. Always turn off hyphenation; it makes .\" way too many mistakes in technical documents. .if n .ad l .nh .SH "NAME" cpanm \- get, unpack build and install modules from CPAN .SH "SYNOPSIS" .IX Header "SYNOPSIS" .Vb 10 \& 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 .Ve .SH "COMMANDS" .IX Header "COMMANDS" .IP "(arguments)" 4 .IX Item "(arguments)" Command line arguments can be either a module name, distribution file, local file path, \s-1HTTP URL\s0 or git repository \s-1URL.\s0 Following commands will all work as you expect. .Sp .Vb 6 \& 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 .Ve .Sp Additionally, you can use the notation using \f(CW\*(C`~\*(C'\fR and \f(CW\*(C`@\*(C'\fR to specify version for a given module. \f(CW\*(C`~\*(C'\fR specifies the version requirement in the CPAN::Meta::Spec format, while \f(CW\*(C`@\*(C'\fR pins the exact version, and is a shortcut for \f(CW\*(C`~"== VERSION"\*(C'\fR. .Sp .Vb 3 \& 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" .Ve .Sp The version query including specific version or range will be sent to MetaCPAN to search for previous releases. The query will search for BackPAN archives by default, unless you specify \f(CW\*(C`\-\-dev\*(C'\fR option, in which case, archived versions will be filtered out. .Sp For a git repository, you can specify a branch, tag, or commit \s-1SHA\s0 to build. The default is \f(CW\*(C`master\*(C'\fR .Sp .Vb 2 \& cpanm git://github.com/plack/Plack.git@1.0000 # tag \& cpanm git://github.com/plack/Plack.git@devel # branch .Ve .IP "\-i, \-\-install" 4 .IX Item "-i, --install" Installs the modules. This is a default behavior and this is just a compatibility option to make it work like cpan or cpanp. .IP "\-\-self\-upgrade" 4 .IX Item "--self-upgrade" Upgrades itself. It's just an alias for: .Sp .Vb 1 \& cpanm App::cpanminus .Ve .IP "\-\-info" 4 .IX Item "--info" Displays the distribution information in \&\f(CW\*(C`AUTHOR/Dist\-Name\-ver.tar.gz\*(C'\fR format in the standard out. .IP "\-\-installdeps" 4 .IX Item "--installdeps" Installs the dependencies of the target distribution but won't build itself. Handy if you want to try the application from a version controlled repository such as git. .Sp .Vb 1 \& cpanm \-\-installdeps . .Ve .IP "\-\-look" 4 .IX Item "--look" Download and unpack the distribution and then open the directory with your shell. Handy to poke around the source code or do manual testing. .IP "\-h, \-\-help" 4 .IX Item "-h, --help" Displays the help message. .IP "\-V, \-\-version" 4 .IX Item "-V, --version" Displays the version number. .SH "OPTIONS" .IX Header "OPTIONS" You can specify the default options in \f(CW\*(C`PERL_CPANM_OPT\*(C'\fR environment variable. .IP "\-f, \-\-force" 4 .IX Item "-f, --force" Force install modules even when testing failed. .IP "\-n, \-\-notest" 4 .IX Item "-n, --notest" Skip the testing of modules. Use this only when you just want to save time for installing hundreds of distributions to the same perl and architecture you've already tested to make sure it builds fine. .Sp Defaults to false, and you can say \f(CW\*(C`\-\-no\-notest\*(C'\fR to override when it is set in the default options in \f(CW\*(C`PERL_CPANM_OPT\*(C'\fR. .IP "\-\-test\-only" 4 .IX Item "--test-only" Run the tests only, and do not install the specified module or distributions. Handy if you want to verify the new (or even old) releases pass its unit tests without installing the module. .Sp 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. .IP "\-S, \-\-sudo" 4 .IX Item "-S, --sudo" Switch to the root user with \f(CW\*(C`sudo\*(C'\fR when installing modules. Use this if you want to install modules to the system perl include path. .Sp Defaults to false, and you can say \f(CW\*(C`\-\-no\-sudo\*(C'\fR to override when it is set in the default options in \f(CW\*(C`PERL_CPANM_OPT\*(C'\fR. .IP "\-v, \-\-verbose" 4 .IX Item "-v, --verbose" Makes the output verbose. It also enables the interactive configuration. (See \-\-interactive) .IP "\-q, \-\-quiet" 4 .IX Item "-q, --quiet" Makes the output even more quiet than the default. It only shows the successful/failed dependencies to the output. .IP "\-l, \-\-local\-lib" 4 .IX Item "-l, --local-lib" Sets the local::lib compatible path to install modules to. You don't need to set this if you already configure the shell environment variables using local::lib, but this can be used to override that as well. .IP "\-L, \-\-local\-lib\-contained" 4 .IX Item "-L, --local-lib-contained" Same with \f(CW\*(C`\-\-local\-lib\*(C'\fR but with \-\-self\-contained set. All non-core dependencies will be installed even if they're already installed. .Sp For instance, .Sp .Vb 1 \& cpanm \-L extlib Plack .Ve .Sp would install Plack and all of its non-core dependencies into the directory \f(CW\*(C`extlib\*(C'\fR, which can be loaded from your application with: .Sp .Vb 1 \& use local::lib \*(Aq/path/to/extlib\*(Aq; .Ve .Sp Note that this option does \fB\s-1NOT\s0\fR reliably work with perl installations supplied by operating system vendors that strips standard modules from perl, such as \s-1RHEL,\s0 Fedora and CentOS, \fB\s-1UNLESS\s0\fR you also install packages supplying all the modules that have been stripped. For these systems you will probably want to install the \f(CW\*(C`perl\-core\*(C'\fR meta-package which does just that. .IP "\-\-self\-contained" 4 .IX Item "--self-contained" When examining the dependencies, assume no non-core modules are installed on the system. Handy if you want to bundle application dependencies in one directory so you can distribute to other machines. .IP "\-\-exclude\-vendor" 4 .IX Item "--exclude-vendor" Don't include modules installed under the 'vendor' paths when searching for core modules when the \f(CW\*(C`\-\-self\-contained\*(C'\fR flag is in effect. This restores the behaviour from before version 1.7023 .IP "\-\-mirror" 4 .IX Item "--mirror" Specifies the base \s-1URL\s0 for the \s-1CPAN\s0 mirror to use, such as \&\f(CW\*(C`http://cpan.cpantesters.org/\*(C'\fR (you can omit the trailing slash). You can specify multiple mirror URLs by repeating the command line option. .Sp You can use a local directory that has a \s-1CPAN\s0 mirror structure (created by tools such as OrePAN or Pinto) by using a special \&\s-1URL\s0 scheme \f(CW\*(C`file://\*(C'\fR. If the given \s-1URL\s0 begins with `/` (without any scheme), it is considered as a file scheme as well. .Sp .Vb 2 \& cpanm \-\-mirror file:///path/to/mirror \& cpanm \-\-mirror ~/minicpan # Because shell expands ~ to /home/user .Ve .Sp Defaults to \f(CW\*(C`http://www.cpan.org/\*(C'\fR. .IP "\-\-mirror\-only" 4 .IX Item "--mirror-only" Download the mirror's 02packages.details.txt.gz index file instead of querying the \s-1CPAN\s0 Meta \s-1DB.\s0 This will also effectively opt out sending your local perl versions to backend database servers such as \s-1CPAN\s0 Meta \&\s-1DB\s0 and MetaCPAN. .Sp Select this option if you are using a local mirror of \s-1CPAN,\s0 such as minicpan when you're offline, or your own \s-1CPAN\s0 index (a.k.a darkpan). .IP "\-\-from, \-M" 4 .IX Item "--from, -M" .Vb 2 \& cpanm \-M https://cpan.metacpan.org/ \& cpanm \-\-from https://cpan.metacpan.org/ .Ve .Sp Use the given mirror \s-1URL\s0 and its index as the \fIonly\fR source to search and download modules from. .Sp It works similar to \f(CW\*(C`\-\-mirror\*(C'\fR and \f(CW\*(C`\-\-mirror\-only\*(C'\fR combined, with a small difference: unlike \f(CW\*(C`\-\-mirror\*(C'\fR which \fIappends\fR the \s-1URL\s0 to the list of mirrors, \f(CW\*(C`\-\-from\*(C'\fR (or \f(CW\*(C`\-M\*(C'\fR for short) uses the specified \s-1URL\s0 as its \fIonly\fR 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 \f(CW\*(C`PERL_CPANM_OPT\*(C'\fR environment variable. .Sp \&\fBTip:\fR It might be useful if you name these options with your shell aliases, like: .Sp .Vb 2 \& alias minicpanm=\*(Aqcpanm \-\-from ~/minicpan\*(Aq \& alias darkpan=\*(Aqcpanm \-\-from http://mycompany.example.com/DPAN\*(Aq .Ve .IP "\-\-mirror\-index" 4 .IX Item "--mirror-index" \&\fB\s-1EXPERIMENTAL\s0\fR: Specifies the file path to \f(CW\*(C`02packages.details.txt\*(C'\fR for module search index. .IP "\-\-cpanmetadb" 4 .IX Item "--cpanmetadb" \&\fB\s-1EXPERIMENTAL\s0\fR: Specifies an alternate \s-1URI\s0 for \s-1CPAN\s0 MetaDB index lookups. .IP "\-\-metacpan" 4 .IX Item "--metacpan" Prefers MetaCPAN \s-1API\s0 over \s-1CPAN\s0 MetaDB. .IP "\-\-cpanfile" 4 .IX Item "--cpanfile" \&\fB\s-1EXPERIMENTAL\s0\fR: Specified an alternate path for cpanfile to search for, when \f(CW\*(C`\-\-installdeps\*(C'\fR command is in use. Defaults to \f(CW\*(C`cpanfile\*(C'\fR. .IP "\-\-prompt" 4 .IX Item "--prompt" Prompts when a test fails so that you can skip, force install, retry or look in the shell to see what's going wrong. It also prompts when one of the dependency failed if you want to proceed the installation. .Sp Defaults to false, and you can say \f(CW\*(C`\-\-no\-prompt\*(C'\fR to override if it's set in the default options in \f(CW\*(C`PERL_CPANM_OPT\*(C'\fR. .IP "\-\-dev" 4 .IX Item "--dev" \&\fB\s-1EXPERIMENTAL\s0\fR: search for a newer developer release as well. Defaults to false. .IP "\-\-reinstall" 4 .IX Item "--reinstall" cpanm, when given a module name in the command line (i.e. \f(CW\*(C`cpanm Plack\*(C'\fR), checks the locally installed version first and skips if it is already installed. This option makes it skip the check, so: .Sp .Vb 1 \& cpanm \-\-reinstall Plack .Ve .Sp would reinstall 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). .Sp Defaults to false. .IP "\-\-interactive" 4 .IX Item "--interactive" Makes the configuration (such as \f(CW\*(C`Makefile.PL\*(C'\fR and \f(CW\*(C`Build.PL\*(C'\fR) interactive, so you can answer questions in the distribution that requires custom configuration or Task:: distributions. .Sp Defaults to false, and you can say \f(CW\*(C`\-\-no\-interactive\*(C'\fR to override when it's set in the default options in \f(CW\*(C`PERL_CPANM_OPT\*(C'\fR. .IP "\-\-pp, \-\-pureperl" 4 .IX Item "--pp, --pureperl" Prefer Pure perl build of modules by setting \f(CW\*(C`PUREPERL_ONLY=1\*(C'\fR for MakeMaker and \f(CW\*(C`\-\-pureperl\-only\*(C'\fR for Build.PL based distributions. Note that not all of the \s-1CPAN\s0 modules support this convention yet. .IP "\-\-with\-recommends, \-\-with\-suggests" 4 .IX Item "--with-recommends, --with-suggests" \&\fB\s-1EXPERIMENTAL\s0\fR: Installs dependencies declared as \f(CW\*(C`recommends\*(C'\fR and \&\f(CW\*(C`suggests\*(C'\fR respectively, per \s-1META\s0 spec. When these dependencies fail to install, cpanm continues the installation, since they're just recommendation/suggestion. .Sp Enabling this could potentially make a circular dependency for a few modules on \s-1CPAN,\s0 when \f(CW\*(C`recommends\*(C'\fR adds a module that \f(CW\*(C`recommends\*(C'\fR back the module in return. .Sp There's also \f(CW\*(C`\-\-without\-recommend\*(C'\fR and \f(CW\*(C`\-\-without\-suggests\*(C'\fR to override the default decision made earlier in \f(CW\*(C`PERL_CPANM_OPT\*(C'\fR. .Sp Defaults to false for both. .IP "\-\-with\-develop" 4 .IX Item "--with-develop" \&\fB\s-1EXPERIMENTAL\s0\fR: Installs develop phase dependencies in \s-1META\s0 files or \&\f(CW\*(C`cpanfile\*(C'\fR when used with \f(CW\*(C`\-\-installdeps\*(C'\fR. Defaults to false. .IP "\-\-with\-configure" 4 .IX Item "--with-configure" \&\fB\s-1EXPERIMENTAL\s0\fR: Installs configure phase dependencies in \f(CW\*(C`cpanfile\*(C'\fR when used with \f(CW\*(C`\-\-installdeps\*(C'\fR. Defaults to false. .IP "\-\-with\-feature, \-\-without\-feature, \-\-with\-all\-features" 4 .IX Item "--with-feature, --without-feature, --with-all-features" \&\fB\s-1EXPERIMENTAL\s0\fR: Specifies the feature to enable, if a module supports optional features per \s-1META\s0 spec 2.0. .Sp .Vb 1 \& cpanm \-\-with\-feature=opt_csv Spreadsheet::Read .Ve .Sp the features can also be interactively chosen when \f(CW\*(C`\-\-interactive\*(C'\fR option is enabled. .Sp \&\f(CW\*(C`\-\-with\-all\-features\*(C'\fR enables all the optional features, and \&\f(CW\*(C`\-\-without\-feature\*(C'\fR can select a feature to disable. .IP "\-\-configure\-timeout, \-\-build\-timeout, \-\-test\-timeout" 4 .IX Item "--configure-timeout, --build-timeout, --test-timeout" Specify the timeout length (in seconds) to wait for the configure, build and test process. Current default values are: 60 for configure, 3600 for build and 1800 for test. .IP "\-\-configure\-args, \-\-build\-args, \-\-test\-args, \-\-install\-args" 4 .IX Item "--configure-args, --build-args, --test-args, --install-args" \&\fB\s-1EXPERIMENTAL\s0\fR: Pass arguments for configure/build/test/install commands respectively, for a given module to install. .Sp .Vb 1 \& cpanm DBD::mysql \-\-configure\-args="\-\-cflags=... \-\-libs=..." .Ve .Sp The argument is only enabled for the module passed as a command line argument, not dependencies. .IP "\-\-scandeps" 4 .IX Item "--scandeps" \&\fB\s-1DEPRECATED\s0\fR: Scans the depencencies of given modules and output the tree in a text format. (See \f(CW\*(C`\-\-format\*(C'\fR below for more options) .Sp Because this command doesn't actually install any distributions, it will be useful that by typing: .Sp .Vb 1 \& cpanm \-\-scandeps Catalyst::Runtime .Ve .Sp you can make sure what modules will be installed. .Sp 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 \f(CW\*(C`\-L\*(C'\fR option. .IP "\-\-format" 4 .IX Item "--format" \&\fB\s-1DEPRECATED\s0\fR: Determines what format to display the scanned dependency tree. Available options are \f(CW\*(C`tree\*(C'\fR, \f(CW\*(C`json\*(C'\fR, \f(CW\*(C`yaml\*(C'\fR and \&\f(CW\*(C`dists\*(C'\fR. .RS 4 .IP "tree" 8 .IX Item "tree" Displays the tree in a plain text format. This is the default value. .IP "json, yaml" 8 .IX Item "json, yaml" Outputs the tree in a \s-1JSON\s0 or \s-1YAML\s0 format. \s-1JSON\s0 and \s-1YAML\s0 modules need to be installed respectively. The output tree is represented as a recursive tuple of: .Sp .Vb 1 \& [ distribution, dependencies ] .Ve .Sp 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 \f(CW\*(C`\-\-scandeps\*(C'\fR command. .IP "dists" 8 .IX Item "dists" \&\f(CW\*(C`dists\*(C'\fR is a special output format, where it prints the distribution filename in the \fIdepth first order\fR after the dependency resolution, like: .Sp .Vb 5 \& 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 .Ve .Sp which means you can install these distributions in this order without extra dependencies. When combined with \f(CW\*(C`\-L\*(C'\fR option, it will be useful to replay installations on other machines. .RE .RS 4 .RE .IP "\-\-save\-dists" 4 .IX Item "--save-dists" Specifies the optional directory path to copy downloaded tarballs in the \s-1CPAN\s0 mirror compatible directory structure i.e. \fIauthors/id/A/AU/AUTHORS/Foo\-Bar\-version.tar.gz\fR .Sp If the distro tarball did not come from \s-1CPAN,\s0 for example from a local file or from GitHub, then it will be saved under \&\fIvendor/Foo\-Bar\-version.tar.gz\fR. .IP "\-\-uninst\-shadows" 4 .IX Item "--uninst-shadows" Uninstalls the shadow files of the distribution that you're installing. This eliminates the confusion if you're trying to install core (dual-life) modules from \s-1CPAN\s0 against perl 5.10 or older, or modules that used to be XS-based but switched to pure perl at some version. .Sp If you run cpanm as root and use \f(CW\*(C`INSTALL_BASE\*(C'\fR or equivalent to specify custom installation path, you \s-1SHOULD\s0 disable this option so you won't accidentally uninstall dual-life modules from the core include path. .Sp Defaults to true if your perl version is smaller than 5.12, and you can disable that with \f(CW\*(C`\-\-no\-uninst\-shadows\*(C'\fR. .Sp \&\fB\s-1NOTE\s0\fR: Since version 1.3000 this flag is turned off by default for perl newer than 5.12, since with 5.12 \f(CW@INC\fR contains site_perl directory \&\fIbefore\fR the perl core library path, and uninstalling shadows is not necessary anymore and does more harm by deleting files from the core library path. .IP "\-\-uninstall, \-U" 4 .IX Item "--uninstall, -U" Uninstalls a module from the library path. It finds a packlist for given modules, and removes all the files included in the same distribution. .Sp If you enable local::lib, it only removes files from the local::lib directory. .Sp If you try to uninstall a module in \f(CW\*(C`perl\*(C'\fR directory (i.e. core module), an error will be thrown. .Sp A dialog will be prompted to confirm the files to be deleted. If you pass \&\f(CW\*(C`\-f\*(C'\fR option as well, the dialog will be skipped and uninstallation will be forced. .IP "\-\-cascade\-search" 4 .IX Item "--cascade-search" \&\fB\s-1EXPERIMENTAL\s0\fR: 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. .IP "\-\-skip\-installed" 4 .IX Item "--skip-installed" Specifies whether a module given in the command line is skipped if its latest version is already installed. Defaults to true. .Sp \&\fB\s-1NOTE\s0\fR: The \f(CW\*(C`PERL5LIB\*(C'\fR environment variable have to be correctly set for this to work with modules installed using local::lib, unless you always use the \f(CW\*(C`\-l\*(C'\fR option. .IP "\-\-skip\-satisfied" 4 .IX Item "--skip-satisfied" \&\fB\s-1EXPERIMENTAL\s0\fR: Specifies whether a module (and version) given in the command line is skipped if it's already installed. .Sp If you run: .Sp .Vb 1 \& cpanm \-\-skip\-satisfied CGI DBI~1.2 .Ve .Sp cpanm won't install them if you already have \s-1CGI\s0 (for whatever versions) or have \s-1DBI\s0 with version higher than 1.2. It is similar to \&\f(CW\*(C`\-\-skip\-installed\*(C'\fR but while \f(CW\*(C`\-\-skip\-installed\*(C'\fR checks if the \&\fIlatest\fR version of \s-1CPAN\s0 is installed, \f(CW\*(C`\-\-skip\-satisfied\*(C'\fR checks if a requested version (or not, which means any version) is installed. .Sp Defaults to false. .IP "\-\-verify" 4 .IX Item "--verify" Verify the integrity of distribution files retrieved from \s-1CPAN\s0 using \s-1CHECKSUMS\s0 file, and \s-1SIGNATURES\s0 file (if found in the distribution). Defaults to false. .Sp Using this option does not verify the integrity of the \s-1CHECKSUMS\s0 file, and it's unsafe to rely on this option if you're using a \s-1CPAN\s0 mirror that you do not trust. .IP "\-\-report\-perl\-version" 4 .IX Item "--report-perl-version" Whether it reports the locally installed perl version to the various web server as part of User-Agent. Defaults to true unless \s-1CI\s0 related environment variables such as \f(CW\*(C`TRAVIS\*(C'\fR, \f(CW\*(C`CI\*(C'\fR or \f(CW\*(C`AUTOMATED_TESTING\*(C'\fR is enabled. You can disable it by using \f(CW\*(C`\-\-no\-report\-perl\-version\*(C'\fR. .IP "\-\-auto\-cleanup" 4 .IX Item "--auto-cleanup" Specifies the number of days in which cpanm's work directories expire. Defaults to 7, which means old work directories will be cleaned up in one week. .Sp You can set the value to \f(CW0\fR to make cpan never cleanup those directories. .IP "\-\-man\-pages" 4 .IX Item "--man-pages" Generates man pages for executables (man1) and libraries (man3). .Sp Defaults to true (man pages generated) unless \f(CW\*(C`\-L|\-\-local\-lib\-contained\*(C'\fR option is supplied in which case it's set to false. You can disable it with \f(CW\*(C`\-\-no\-man\-pages\*(C'\fR. .IP "\-\-lwp" 4 .IX Item "--lwp" Uses \s-1LWP\s0 module to download stuff over \s-1HTTP.\s0 Defaults to true, and you can say \f(CW\*(C`\-\-no\-lwp\*(C'\fR to disable using \s-1LWP,\s0 when you want to upgrade \&\s-1LWP\s0 from \s-1CPAN\s0 on some broken perl systems. .IP "\-\-wget" 4 .IX Item "--wget" Uses \s-1GNU\s0 Wget (if available) to download stuff. Defaults to true, and you can say \f(CW\*(C`\-\-no\-wget\*(C'\fR to disable using Wget (versions of Wget older than 1.9 don't support the \f(CW\*(C`\-\-retry\-connrefused\*(C'\fR option used by cpanm). .IP "\-\-curl" 4 .IX Item "--curl" Uses cURL (if available) to download stuff. Defaults to true, and you can say \f(CW\*(C`\-\-no\-curl\*(C'\fR to disable using cURL. .Sp Normally with \f(CW\*(C`\-\-lwp\*(C'\fR, \f(CW\*(C`\-\-wget\*(C'\fR and \f(CW\*(C`\-\-curl\*(C'\fR options set to true (which is the default) cpanm tries \s-1LWP\s0, Wget, cURL and HTTP::Tiny (in that order) and uses the first one available. .SH "ENVIRONMENT VARIABLES" .IX Header "ENVIRONMENT VARIABLES" .IP "\s-1PERL_CPANM_HOME\s0" 4 .IX Item "PERL_CPANM_HOME" The directory cpanm should use to store downloads and build and test modules. Defaults to the \f(CW\*(C`.cpanm\*(C'\fR directory in your user's home directory. .IP "\s-1PERL_CPANM_OPT\s0" 4 .IX Item "PERL_CPANM_OPT" If set, adds a set of default options to every cpanm command. These options come first, and so are overridden by command-line options. .SH "SEE ALSO" .IX Header "SEE ALSO" App::cpanminus .SH "COPYRIGHT" .IX Header "COPYRIGHT" Copyright 2010\- Tatsuhiko Miyagawa. .SH "AUTHOR" .IX Header "AUTHOR" Tatsuhiko Miyagawa PK jA[ blib/arch/.existsnu �[��� PK jA[ $ blib/arch/auto/App/cpanminus/.existsnu �[��� PK jA[ blib/bin/.existsnu �[��� PK jA[{%�O� O� blib/script/cpanmnu ȯ�� #!/usr/bin/perl # # This is a pre-compiled source code for the cpanm (cpanminus) program. # For more details about how to install cpanm, go to the following URL: # # https://github.com/miyagawa/cpanminus # # Quickstart: Run the following command and it will install itself for # you. You might want to run it as a root with sudo if you want to install # to places like /usr/local/bin. # # % curl -L https://cpanmin.us | perl - App::cpanminus # # If you don't have curl but wget, replace `curl -L` with `wget -O -`. # DO NOT EDIT -- this is an auto generated file # This chunk of stuff was generated by App::FatPacker. To find the original # file's code, look for the end of this BEGIN block or the string 'FATPACK' BEGIN { my %fatpacked; $fatpacked{"App/cpanminus.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_CPANMINUS'; package App::cpanminus;our$VERSION="1.7047";1; APP_CPANMINUS $fatpacked{"App/cpanminus/Dependency.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_CPANMINUS_DEPENDENCY'; package App::cpanminus::Dependency;use strict;use CPAN::Meta::Requirements;sub from_prereqs {my($class,$prereqs,$phases,$types)=@_;my@deps;for my$type (@$types){push@deps,$class->from_versions($prereqs->merged_requirements($phases,[$type])->as_string_hash,$type,)}return@deps}sub from_versions {my($class,$versions,$type)=@_;my@deps;while (my($module,$version)=each %$versions){push@deps,$class->new($module,$version,$type)}@deps}sub merge_with {my($self,$requirements)=@_;$self->{original_version}=$self->version;eval {$requirements->add_string_requirement($self->module,$self->version)};if ($@ =~ /illegal requirements/){warn sprintf("Can't merge requirements for %s: '%s' and '%s'",$self->module,$self->version,$requirements->requirements_for_module($self->module))}$self->{version}=$requirements->requirements_for_module($self->module)}sub new {my($class,$module,$version,$type)=@_;bless {module=>$module,version=>$version,type=>$type || 'requires',},$class}sub module {$_[0]->{module}}sub version {$_[0]->{version}}sub type {$_[0]->{type}}sub requires_version {my$self=shift;if (defined$self->{original_version}){return$self->{original_version}}$self->version}sub is_requirement {$_[0]->{type}eq 'requires'}1; APP_CPANMINUS_DEPENDENCY $fatpacked{"App/cpanminus/script.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_CPANMINUS_SCRIPT'; package App::cpanminus::script;use strict;use Config;use Cwd ();use App::cpanminus;use App::cpanminus::Dependency;use File::Basename ();use File::Find ();use File::Path ();use File::Spec ();use File::Copy ();use File::Temp ();use Getopt::Long ();use Symbol ();use String::ShellQuote ();use version ();use constant WIN32=>$^O eq 'MSWin32';use constant BAD_TAR=>($^O eq 'solaris' || $^O eq 'hpux');use constant CAN_SYMLINK=>eval {symlink("","");1};our$VERSION=$App::cpanminus::VERSION;if ($INC{"App/FatPacker/Trace.pm"}){require version::vpp}my$quote=WIN32 ? q/"/ : q/'/;sub agent {my$self=shift;my$agent="cpanminus/$VERSION";$agent .= " perl/$]" if$self->{report_perl_version};$agent}sub determine_home {my$class=shift;my$homedir=$ENV{HOME}|| eval {require File::HomeDir;File::HomeDir->my_home}|| join('',@ENV{qw(HOMEDRIVE HOMEPATH)});if (WIN32){require Win32;$homedir=Win32::GetShortPathName($homedir)}return "$homedir/.cpanm"}sub new {my$class=shift;bless {home=>$class->determine_home,cmd=>'install',seen=>{},notest=>undef,test_only=>undef,installdeps=>undef,force=>undef,sudo=>undef,make=>undef,verbose=>undef,quiet=>undef,interactive=>undef,log=>undef,mirrors=>[],mirror_only=>undef,mirror_index=>undef,cpanmetadb=>"http://cpanmetadb.plackperl.org/v1.0/",perl=>$^X,argv=>[],local_lib=>undef,self_contained=>undef,exclude_vendor=>undef,prompt_timeout=>0,prompt=>undef,configure_timeout=>60,build_timeout=>3600,test_timeout=>1800,try_lwp=>1,try_wget=>1,try_curl=>1,uninstall_shadows=>($] < 5.012),skip_installed=>1,skip_satisfied=>0,auto_cleanup=>7,pod2man=>1,installed_dists=>0,install_types=>['requires'],with_develop=>0,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){push@ARGV,$self->load_argv_from_fh(\*STDIN);$self->{load_from_stdin}=1}$self->{argv}=\@ARGV}sub check_upgrade {my$self=shift;my$install_base=$ENV{PERL_LOCAL_LIB_ROOT}? $self->local_lib_target($ENV{PERL_LOCAL_LIB_ROOT}): $Config{installsitebin};if ($0 eq '-'){return}elsif ($0 !~ /^$install_base/){if ($0 =~ m!perlbrew/bin!){die <<DIE}else {die <<DIE}}}sub check_libs {my$self=shift;return if$self->{_checked}++;$self->bootstrap_local_lib}sub setup_verify {my$self=shift;my$has_modules=eval {require Module::Signature;require Digest::SHA;1};$self->{cpansign}=$self->which('cpansign');unless ($has_modules && $self->{cpansign}){warn "WARNING: Module::Signature and Digest::SHA is required for distribution verifications.\n";$self->{verify}=0}}sub parse_module_args {my($self,$module)=@_;$module =~ s/^([A-Za-z0-9_:]+)@([v\d\._]+)$/$1~== $2/;if ($module =~ /\~[v\d\._,\!<>= ]+$/){return split /\~/,$module,2}else {return$module,undef}}sub doit {my$self=shift;my$code;eval {$code=($self->_doit==0)};if (my$e=$@){warn$e;$code=1}return$code}sub _doit {my$self=shift;$self->setup_home;$self->init_tools;$self->setup_verify if$self->{verify};if (my$action=$self->{action}){$self->$action()and return 1}return$self->show_help(1)unless @{$self->{argv}}or $self->{load_from_stdin};$self->configure_mirrors;my$cwd=Cwd::cwd;my@fail;for my$module (@{$self->{argv}}){if ($module =~ s/\.pm$//i){my ($volume,$dirs,$file)=File::Spec->splitpath($module);$module=join '::',grep {$_}File::Spec->splitdir($dirs),$file}($module,my$version)=$self->parse_module_args($module);$self->chdir($cwd);if ($self->{cmd}eq 'uninstall'){$self->uninstall_module($module)or push@fail,$module}else {$self->install_module($module,0,$version)or push@fail,$module}}if ($self->{base}&& $self->{auto_cleanup}){$self->cleanup_workdirs}if ($self->{installed_dists}){my$dists=$self->{installed_dists}> 1 ? "distributions" : "distribution";$self->diag("$self->{installed_dists} $dists installed\n",1)}if ($self->{scandeps}){$self->dump_scandeps()}$self->chdir($cwd);return!@fail}sub setup_home {my$self=shift;$self->{home}=$self->env('HOME')if$self->env('HOME');unless (_writable($self->{home})){die "Can't write to cpanm home '$self->{home}': You should fix it with chown/chmod first.\n"}$self->{base}="$self->{home}/work/" .time .".$$";File::Path::mkpath([$self->{base}],0,0777);$self->{log}=File::Spec->catfile($self->{base},"build.log");my$final_log="$self->{home}/build.log";{open my$out,">$self->{log}" or die "$self->{log}: $!"}if (CAN_SYMLINK){my$build_link="$self->{home}/latest-build";unlink$build_link;symlink$self->{base},$build_link;unlink$final_log;symlink$self->{log},$final_log}else {my$log=$self->{log};my$home=$self->{home};$self->{at_exit}=sub {my$self=shift;my$temp_log="$home/build.log." .time .".$$";File::Copy::copy($log,$temp_log)&& unlink($final_log);rename($temp_log,$final_log)}}$self->chat("cpanm (App::cpanminus) $VERSION on perl $] built for $Config{archname}\n" ."Work directory is $self->{base}\n")}sub package_index_for {my ($self,$mirror)=@_;return$self->source_for($mirror)."/02packages.details.txt"}sub generate_mirror_index {my ($self,$mirror)=@_;my$file=$self->package_index_for($mirror);my$gz_file=$file .'.gz';my$index_mtime=(stat$gz_file)[9];unless (-e $file && (stat$file)[9]>= $index_mtime){$self->chat("Uncompressing index file...\n");if (eval {require Compress::Zlib}){my$gz=Compress::Zlib::gzopen($gz_file,"rb")or do {$self->diag_fail("$Compress::Zlib::gzerrno opening compressed index");return};open my$fh,'>',$file or do {$self->diag_fail("$! opening uncompressed index for write");return};my$buffer;while (my$status=$gz->gzread($buffer)){if ($status < 0){$self->diag_fail($gz->gzerror ." reading compressed index");return}print$fh $buffer}}else {if (system("gunzip -c $gz_file > $file")){$self->diag_fail("Cannot uncompress -- please install gunzip or Compress::Zlib");return}}utime$index_mtime,$index_mtime,$file}return 1}sub search_mirror_index {my ($self,$mirror,$module,$version)=@_;$self->search_mirror_index_file($self->package_index_for($mirror),$module,$version)}sub search_mirror_index_file {my($self,$file,$module,$version)=@_;open my$fh,'<',$file or return;my$found;while (<$fh>){if (m!^\Q$module\E\s+([\w\.]+)\s+(\S*)!m){$found=$self->cpan_module($module,$2,$1);last}}return$found unless$self->{cascade_search};if ($found){if ($self->satisfy_version($module,$found->{module_version},$version)){return$found}else {$self->chat("Found $module $found->{module_version} which doesn't satisfy $version.\n")}}return}sub with_version_range {my($self,$version)=@_;defined($version)&& $version =~ /(?:<|!=|==)/}sub encode_json {my($self,$data)=@_;require JSON::PP;my$json=JSON::PP::encode_json($data);$self->uri_escape($json)}sub decode_json {my($self,$json)=@_;require JSON::PP;JSON::PP::decode_json($json)}sub uri_escape {my($self,$fragment)=@_;$fragment =~ s/([^A-Za-z0-9\-\._~])/uc sprintf("%%%02X", ord($1))/eg;$fragment}sub uri_params {my($self,@params)=@_;my@param_strings;while (my$key=shift@params){my$value=shift@params;push@param_strings,join '=',map$self->uri_escape($_),$key,$value}return join '&',@param_strings}sub numify_ver {my($self,$ver)=@_;eval version->new($ver)->numify}sub search_metacpan {my($self,$module,$version,$dev_release)=@_;my$metacpan_uri='http://fastapi.metacpan.org/v1/download_url/';my$url=$metacpan_uri .$module;my$query=$self->uri_params(($version ? (version=>$version): ()),($dev_release ? (dev=>1): ()),);$url .= '?' .$query if length$query;my$dist_json=$self->get($url);my$dist_meta=eval {$self->decode_json($dist_json)};if ($dist_meta && $dist_meta->{download_url}){(my$distfile=$dist_meta->{download_url})=~ s!.+/authors/id/!!;local$self->{mirrors}=$self->{mirrors};$self->{mirrors}=['http://cpan.metacpan.org' ];return$self->cpan_module($module,$distfile,$dist_meta->{version})}$self->chat("! Could not find a release matching $module".($version?" ($version)":'')." on MetaCPAN.\n");return}sub search_database {my($self,$module,$version)=@_;my$found;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}}sub search_cpanmetadb {my($self,$module,$version,$dev_release)=@_;$self->chat("Searching $module ($version) on cpanmetadb ...\n");if ($self->with_version_range($version)){return$self->search_cpanmetadb_history($module,$version,$dev_release)}else {return$self->search_cpanmetadb_package($module,$version,$dev_release)}}sub search_cpanmetadb_package {my($self,$module,$version,$dev_release)=@_;require CPAN::Meta::YAML;(my$uri=$self->{cpanmetadb})=~ s{/?$}{/package/$module};my$yaml=$self->get($uri);my$meta=eval {CPAN::Meta::YAML::Load($yaml)};if ($meta && $meta->{distfile}){return$self->cpan_module($module,$meta->{distfile},$meta->{version})}$self->diag_fail("Finding $module on cpanmetadb failed.");return}sub search_cpanmetadb_history {my($self,$module,$version)=@_;(my$uri=$self->{cpanmetadb})=~ s{/?$}{/history/$module};my$content=$self->get($uri)or return;my@found;for my$line (split /\r?\n/,$content){if ($line =~ /^$module\s+(\S+)\s+(\S+)$/){push@found,{version=>$1,version_obj=>version::->parse($1),distfile=>$2,}}}return unless@found;$found[-1]->{latest}=1;my$match;for my$try (sort {$b->{version_obj}cmp $a->{version_obj}}@found){if ($self->satisfy_version($module,$try->{version_obj},$version)){local$self->{mirrors}=$self->{mirrors};unshift @{$self->{mirrors}},'http://backpan.perl.org' unless$try->{latest};return$self->cpan_module($module,$try->{distfile},$try->{version})}}$self->diag_fail("Finding $module ($version) on cpanmetadb failed.");return}sub search_module {my($self,$module,$version)=@_;if ($self->{mirror_index}){$self->mask_output(chat=>"Searching $module on mirror index $self->{mirror_index} ...\n");my$pkg=$self->search_mirror_index_file($self->{mirror_index},$module,$version);return$pkg if$pkg;unless ($self->{cascade_search}){$self->mask_output(diag_fail=>"Finding $module ($version) on mirror index $self->{mirror_index} failed.");return}}unless ($self->{mirror_only}){my$found=$self->search_database($module,$version);return$found if$found}MIRROR: for my$mirror (@{$self->{mirrors}}){$self->mask_output(chat=>"Searching $module on mirror $mirror ...\n");my$name='02packages.details.txt.gz';my$uri="$mirror/modules/$name";my$gz_file=$self->package_index_for($mirror).'.gz';unless ($self->{pkgs}{$uri}){$self->mask_output(chat=>"Downloading index file $uri ...\n");$self->mirror($uri,$gz_file);$self->generate_mirror_index($mirror)or next MIRROR;$self->{pkgs}{$uri}="!!retrieved!!"}my$pkg=$self->search_mirror_index($mirror,$module,$version);return$pkg if$pkg;$self->mask_output(diag_fail=>"Finding $module ($version) on mirror $mirror failed.")}return}sub source_for {my($self,$mirror)=@_;$mirror =~ s/[^\w\.\-]+/%/g;my$dir="$self->{home}/sources/$mirror";File::Path::mkpath([$dir ],0,0777);return$dir}sub load_argv_from_fh {my($self,$fh)=@_;my@argv;while(defined(my$line=<$fh>)){chomp$line;$line =~ s/#.+$//;$line =~ s/^\s+//;$line =~ s/\s+$//;push@argv,split ' ',$line if$line}return@argv}sub show_version {my$self=shift;print "cpanm (App::cpanminus) version $VERSION ($0)\n";print "perl version $] ($^X)\n\n";print " \%Config:\n";for my$key (qw(archname installsitelib installsitebin installman1dir installman3dir sitearchexp sitelibexp vendorarch vendorlibexp archlibexp privlibexp)){print " $key=$Config{$key}\n" if$Config{$key}}print " \%ENV:\n";for my$key (grep /^PERL/,sort keys%ENV){print " $key=$ENV{$key}\n"}print " \@INC:\n";for my$inc (@INC){print " $inc\n" unless ref($inc)eq 'CODE'}return 1}sub show_help {my$self=shift;if ($_[0]){print <<USAGE;return}print <<HELP;return 1}sub _writable {my$dir=shift;my@dir=File::Spec->splitdir($dir);while (@dir){$dir=File::Spec->catdir(@dir);if (-e $dir){return -w _}pop@dir}return}sub maybe_abs {my($self,$lib)=@_;if ($lib eq '_' or $lib =~ /^~/ or File::Spec->file_name_is_absolute($lib)){return$lib}else {return File::Spec->canonpath(File::Spec->catdir(Cwd::cwd(),$lib))}}sub local_lib_target {my($self,$root)=@_;(grep {$_ ne ''}split /\Q$Config{path_sep}/,$root)[0]}sub bootstrap_local_lib {my$self=shift;if ($self->{local_lib}){return$self->setup_local_lib($self->{local_lib})}if ($ENV{PERL_LOCAL_LIB_ROOT}&& $ENV{PERL_MM_OPT}){return$self->setup_local_lib($self->local_lib_target($ENV{PERL_LOCAL_LIB_ROOT}),1)}return if$self->{sudo}or (_writable($Config{installsitelib})and _writable($Config{installsitebin}));if ($ENV{PERL_MM_OPT}and ($ENV{MODULEBUILDRC}or $ENV{PERL_MB_OPT})){return}$self->setup_local_lib;$self->diag(<<DIAG,1);sleep 2}sub upgrade_toolchain {my($self,$config_deps)=@_;my%deps=map {$_->module=>$_}@$config_deps;my$reqs=CPAN::Meta::Requirements->from_string_hash({'Module::Build'=>'0.38','ExtUtils::MakeMaker'=>'6.58','ExtUtils::Install'=>'1.46',});if ($deps{"ExtUtils::MakeMaker"}){$deps{"ExtUtils::MakeMaker"}->merge_with($reqs)}elsif ($deps{"Module::Build"}){$deps{"Module::Build"}->merge_with($reqs);$deps{"ExtUtils::Install"}||= App::cpanminus::Dependency->new("ExtUtils::Install",0,'configure');$deps{"ExtUtils::Install"}->merge_with($reqs)}@$config_deps=values%deps}sub _core_only_inc {my($self,$base)=@_;require local::lib;(local::lib->resolve_path(local::lib->install_base_arch_path($base)),local::lib->resolve_path(local::lib->install_base_perl_path($base)),(!$self->{exclude_vendor}? grep {$_}@Config{qw(vendorarch vendorlibexp)}: ()),@Config{qw(archlibexp privlibexp)},)}sub _diff {my($self,$old,$new)=@_;my@diff;my%old=map {$_=>1}@$old;for my$n (@$new){push@diff,$n unless exists$old{$n}}@diff}sub _setup_local_lib_env {my($self,$base)=@_;$self->diag(<<WARN,1)if$base =~ /\s/;local$SIG{__WARN__}=sub {};local::lib->setup_env_hash_for($base,0)}sub setup_local_lib {my($self,$base,$no_env)=@_;$base=undef if$base eq '_';require local::lib;{local $0='cpanm';$base ||= "~/perl5";$base=local::lib->resolve_path($base);if ($self->{self_contained}){my@inc=$self->_core_only_inc($base);$self->{search_inc}=[@inc ]}else {$self->{search_inc}=[local::lib->install_base_arch_path($base),local::lib->install_base_perl_path($base),@INC,]}$self->_setup_local_lib_env($base)unless$no_env;$self->{local_lib}=$base}}sub prompt_bool {my($self,$mess,$def)=@_;my$val=$self->prompt($mess,$def);return lc$val eq 'y'}sub prompt {my($self,$mess,$def)=@_;my$isa_tty=-t STDIN && (-t STDOUT ||!(-f STDOUT || -c STDOUT));my$dispdef=defined$def ? "[$def] " : " ";$def=defined$def ? $def : "";if (!$self->{prompt}|| (!$isa_tty && eof STDIN)){return$def}local $|=1;local $\;my$ans;eval {local$SIG{ALRM}=sub {undef$ans;die "alarm\n"};print STDOUT "$mess $dispdef";alarm$self->{prompt_timeout}if$self->{prompt_timeout};$ans=<STDIN>;alarm 0};if (defined$ans){chomp$ans}else {print STDOUT "\n"}return (!defined$ans || $ans eq '')? $def : $ans}sub diag_ok {my($self,$msg)=@_;chomp$msg;$msg ||= "OK";if ($self->{in_progress}){$self->_diag("$msg\n");$self->{in_progress}=0}$self->log("-> $msg\n")}sub diag_fail {my($self,$msg,$always)=@_;chomp$msg;if ($self->{in_progress}){$self->_diag("FAIL\n");$self->{in_progress}=0}if ($msg){$self->_diag("! $msg\n",$always,1);$self->log("-> FAIL $msg\n")}}sub diag_progress {my($self,$msg)=@_;chomp$msg;$self->{in_progress}=1;$self->_diag("$msg ... ");$self->log("$msg\n")}sub _diag {my($self,$msg,$always,$error)=@_;my$fh=$error ? *STDERR : *STDOUT;print {$fh}$msg if$always or $self->{verbose}or!$self->{quiet}}sub diag {my($self,$msg,$always)=@_;$self->_diag($msg,$always);$self->log($msg)}sub chat {my$self=shift;print STDERR @_ if$self->{verbose};$self->log(@_)}sub mask_output {my$self=shift;my$method=shift;$self->$method($self->mask_uri_passwords(@_))}sub log {my$self=shift;open my$out,">>$self->{log}";print$out @_}sub run {my($self,$cmd)=@_;if (WIN32){$cmd=$self->shell_quote(@$cmd)if ref$cmd eq 'ARRAY';unless ($self->{verbose}){$cmd .= " >> " .$self->shell_quote($self->{log})." 2>&1"}!system$cmd}else {my$pid=fork;if ($pid){waitpid$pid,0;return!$?}else {$self->run_exec($cmd)}}}sub run_exec {my($self,$cmd)=@_;if (ref$cmd eq 'ARRAY'){unless ($self->{verbose}){open my$logfh,">>",$self->{log};open STDERR,'>&',$logfh;open STDOUT,'>&',$logfh;close$logfh}exec @$cmd}else {unless ($self->{verbose}){$cmd .= " >> " .$self->shell_quote($self->{log})." 2>&1"}exec$cmd}}sub run_timeout {my($self,$cmd,$timeout)=@_;return$self->run($cmd)if WIN32 || $self->{verbose}||!$timeout;my$pid=fork;if ($pid){eval {local$SIG{ALRM}=sub {die "alarm\n"};alarm$timeout;waitpid$pid,0;alarm 0};if ($@ && $@ eq "alarm\n"){$self->diag_fail("Timed out (> ${timeout}s). Use --verbose to retry.");local$SIG{TERM}='IGNORE';kill TERM=>0;waitpid$pid,0;return}return!$?}elsif ($pid==0){$self->run_exec($cmd)}else {$self->chat("! fork failed: falling back to system()\n");$self->run($cmd)}}sub append_args {my($self,$cmd,$phase)=@_;if (my$args=$self->{build_args}{$phase}){$cmd=join ' ',$self->shell_quote(@$cmd),$args}$cmd}sub configure {my($self,$cmd,$depth)=@_;local$ENV{PERL5_CPAN_IS_RUNNING}=local$ENV{PERL5_CPANPLUS_IS_RUNNING}=$$;local$ENV{PERL5_CPANM_IS_RUNNING}=$$;my$use_default=!$self->{interactive};local$ENV{PERL_MM_USE_DEFAULT}=$use_default;local$ENV{PERL_MM_OPT}=$ENV{PERL_MM_OPT};local$ENV{PERL_MB_OPT}=$ENV{PERL_MB_OPT};unless ($self->{pod2man}){$ENV{PERL_MM_OPT}.= " INSTALLMAN1DIR=none INSTALLMAN3DIR=none";$ENV{PERL_MB_OPT}.= " --config installman1dir= --config installsiteman1dir= --config installman3dir= --config installsiteman3dir="}if ($self->{pure_perl}){$ENV{PERL_MM_OPT}.= " PUREPERL_ONLY=1";$ENV{PERL_MB_OPT}.= " --pureperl-only"}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};local$ENV{PERL_MM_USE_DEFAULT}=!$self->{interactive};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){system("$pager < $self->{log}")}else {$self->diag_fail("You don't seem to have a PAGER :/")}}sub chdir {my$self=shift;Cwd::chdir(File::Spec->canonpath($_[0]))or die "$_[0]: $!"}sub configure_mirrors {my$self=shift;unless (@{$self->{mirrors}}){$self->{mirrors}=['http://www.cpan.org' ]}for (@{$self->{mirrors}}){s!^/!file:///!;s!/$!!}}sub self_upgrade {my$self=shift;$self->check_upgrade;$self->{argv}=['App::cpanminus' ];return}sub install_module {my($self,$module,$depth,$version)=@_;$self->check_libs;if ($self->{seen}{$module}++){$self->chat("Already tried $module. Skipping.\n");return 1}if ($self->{skip_satisfied}){my($ok,$local)=$self->check_module($module,$version || 0);if ($ok){$self->diag("You have $module ($local)\n",1);return 1}}my$dist=$self->resolve_name($module,$version);unless ($dist){my$what=$module .($version ? " ($version)" : "");$self->diag_fail("Couldn't find module or a distribution $what",1);return}if ($dist->{distvname}&& $self->{seen}{$dist->{distvname}}++){$self->chat("Already tried $dist->{distvname}. Skipping.\n");return 1}if ($self->{cmd}eq 'info'){print$self->format_dist($dist),"\n";return 1}$dist->{depth}=$depth;if ($dist->{module}){unless ($self->satisfy_version($dist->{module},$dist->{module_version},$version)){$self->diag("Found $dist->{module} $dist->{module_version} which doesn't satisfy $version.\n",1);return}my$cmp=$version ? "==" : "";my$requirement=$dist->{module_version}? "$cmp$dist->{module_version}" : 0;my($ok,$local)=$self->check_module($dist->{module},$requirement);if ($self->{skip_installed}&& $ok){$self->diag("$dist->{module} is up to date. ($local)\n",1);return 1}}if ($dist->{dist}eq 'perl'){$self->diag("skipping $dist->{pathname}\n");return 1}$self->diag("--> Working on $module\n");$dist->{dir}||= $self->fetch_module($dist);unless ($dist->{dir}){$self->diag_fail("Failed to fetch distribution $dist->{distvname}",1);return}$self->chat("Entering $dist->{dir}\n");$self->chdir($self->{base});$self->chdir($dist->{dir});if ($self->{cmd}eq 'look'){$self->look;return 1}return$self->build_stuff($module,$dist,$depth)}sub uninstall_search_path {my$self=shift;$self->{local_lib}? (local::lib->install_base_arch_path($self->{local_lib}),local::lib->install_base_perl_path($self->{local_lib})): @Config{qw(installsitearch installsitelib)}}sub uninstall_module {my ($self,$module)=@_;$self->check_libs;my@inc=$self->uninstall_search_path;my($metadata,$packlist)=$self->packlists_containing($module,\@inc);unless ($packlist){$self->diag_fail(<<DIAG,1);return}my@uninst_files=$self->uninstall_target($metadata,$packlist);$self->ask_permission($module,\@uninst_files)or return;$self->uninstall_files(@uninst_files,$packlist);$self->diag("Successfully uninstalled $module\n",1);return 1}sub packlists_containing {my($self,$module,$inc)=@_;require Module::Metadata;my$metadata=Module::Metadata->new_from_module($module,inc=>$inc)or return;my$packlist;my$wanted=sub {return unless $_ eq '.packlist' && -f $_;for my$file ($self->unpack_packlist($File::Find::name)){$packlist ||= $File::Find::name if$file eq $metadata->filename}};{require File::pushd;my$pushd=File::pushd::pushd();my@search=grep -d $_,map File::Spec->catdir($_,'auto'),@$inc;File::Find::find($wanted,@search)}return$metadata,$packlist}sub uninstall_target {my($self,$metadata,$packlist)=@_;if ($self->has_shadow_install($metadata)or $self->{local_lib}){grep$self->should_unlink($_),$self->unpack_packlist($packlist)}else {$self->unpack_packlist($packlist)}}sub has_shadow_install {my($self,$metadata)=@_;my@shadow=grep defined,map Module::Metadata->new_from_module($metadata->name,inc=>[$_]),@INC;@shadow >= 2}sub should_unlink {my($self,$file)=@_;if ($self->{local_lib}){$file =~ /^\Q$self->{local_lib}\E/}else {!(grep$file =~ /^\Q$_\E/,@Config{qw(installbin installscript installman1dir installman3dir)})}}sub ask_permission {my ($self,$module,$files)=@_;$self->diag("$module contains the following files:\n\n");for my$file (@$files){$self->diag(" $file\n")}$self->diag("\n");return 'force uninstall' if$self->{force};local$self->{prompt}=1;return$self->prompt_bool("Are you sure you want to uninstall $module?",'y')}sub unpack_packlist {my ($self,$packlist)=@_;open my$fh,'<',$packlist or die "$packlist: $!";map {chomp;$_}<$fh>}sub uninstall_files {my ($self,@files)=@_;$self->diag("\n");for my$file (@files){$self->diag("Unlink: $file\n");unlink$file or $self->diag_fail("$!: $file")}$self->diag("\n");return 1}sub format_dist {my($self,$dist)=@_;return "$dist->{cpanid}/$dist->{filename}"}sub trim {local $_=shift;tr/\n/ /d;s/^\s*|\s*$//g;$_}sub fetch_module {my($self,$dist)=@_;$self->chdir($self->{base});for my$uri (@{$dist->{uris}}){$self->mask_output(diag_progress=>"Fetching $uri");my$filename=$dist->{filename}|| $uri;my$name=File::Basename::basename($filename);my$cancelled;my$fetch=sub {my$file;eval {local$SIG{INT}=sub {$cancelled=1;die "SIGINT\n"};$self->mirror($uri,$name);$file=$name if -e $name};$self->diag("ERROR: " .trim("$@")."\n",1)if $@ && $@ ne "SIGINT\n";return$file};my($try,$file);while ($try++ < 3){$file=$fetch->();last if$cancelled or $file;$self->mask_output(diag_fail=>"Download $uri failed. Retrying ... ")}if ($cancelled){$self->diag_fail("Download cancelled.");return}unless ($file){$self->mask_output(diag_fail=>"Failed to download $uri");next}$self->diag_ok;$dist->{local_path}=File::Spec->rel2abs($name);my$dir=$self->unpack($file,$uri,$dist);next unless$dir;if (my$save=$self->{save_dists}){my$path=$dist->{pathname}? "$save/authors/id/$dist->{pathname}" : "$save/vendor/$file";$self->chat("Copying $name to $path\n");File::Path::mkpath([File::Basename::dirname($path)],0,0777);File::Copy::copy($file,$path)or warn $!}return$dist,$dir}}sub unpack {my($self,$file,$uri,$dist)=@_;if ($self->{verify}){$self->verify_archive($file,$uri,$dist)or return}$self->chat("Unpacking $file\n");my$dir=$file =~ /\.zip/i ? $self->unzip($file): $self->untar($file);unless ($dir){$self->diag_fail("Failed to unpack $file: no directory")}return$dir}sub verify_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_checksum($file,$chk_file)}sub verify_checksum {my($self,$file,$chk_file)=@_;$self->chat("Verifying the SHA1 for $file\n");open my$fh,"<$chk_file" or die "$chk_file: $!";my$data=join '',<$fh>;$data =~ s/\015?\012/\n/g;require Safe;my$chksum=Safe->new->reval($data);if (!ref$chksum or ref$chksum ne 'HASH'){$self->diag_fail("! Checksum file downloaded from $chk_file is broken.\n");return}if (my$sha=$chksum->{$file}{sha256}){my$hex=$self->sha1_for($file);if ($hex eq $sha){$self->chat("Checksum for $file: Verified!\n")}else {$self->diag_fail("Checksum mismatch for $file\n");return}}else {$self->chat("Checksum for $file not found in CHECKSUMS.\n");return}}sub sha1_for {my($self,$file)=@_;require Digest::SHA;open my$fh,"<",$file or die "$file: $!";my$dg=Digest::SHA->new(256);my($data);while (read($fh,$data,4096)){$dg->add($data)}return$dg->hexdigest}sub verify_signature {my($self,$dist)=@_;$self->diag_progress("Verifying the SIGNATURE file");my$out=`$self->{cpansign} -v --skip 2>&1`;$self->log($out);if ($out =~ /Signature verified OK/){$self->diag_ok("Verified OK");return 1}else {$self->diag_fail("SIGNATURE verification for $dist->{filename} failed\n");return}}sub resolve_name {my($self,$module,$version)=@_;if ($module =~ /(?:^git:|\.git(?:@.+)?$)/){return$self->git_uri($module)}if ($module =~ /^(ftp|https?|file):/){if ($module =~ m!authors/id/(.*)!){return$self->cpan_dist($1,$module)}else {return {uris=>[$module ]}}}if ($module =~ m!^[\./]! && -d $module){return {source=>'local',dir=>Cwd::abs_path($module),}}if (-f $module){return {source=>'local',uris=>["file://" .Cwd::abs_path($module)],}}if ($module =~ s!^cpan:///distfile/!!){return$self->cpan_dist($module)}if ($module =~ m!^(?:[A-Z]/[A-Z]{2}/)?([A-Z]{2}[\-A-Z0-9]*/.*)$!){return$self->cpan_dist($1)}return$self->search_module($module,$version)}sub cpan_module {my($self,$module,$dist_file,$version)=@_;my$dist=$self->cpan_dist($dist_file);$dist->{module}=$module;$dist->{module_version}=$version if$version && $version ne 'undef';return$dist}sub cpan_dist {my($self,$dist,$url)=@_;$dist =~ s!^([A-Z]{2})!substr($1,0,1)."/".substr($1,0,2)."/".$1!e;require CPAN::DistnameInfo;my$d=CPAN::DistnameInfo->new($dist);if ($url){$url=[$url ]unless ref$url eq 'ARRAY'}else {my$id=$d->cpanid;my$fn=substr($id,0,1)."/" .substr($id,0,2)."/" .$id ."/" .$d->filename;my@mirrors=@{$self->{mirrors}};my@urls=map "$_/authors/id/$fn",@mirrors;$url=\@urls,}return {$d->properties,source=>'cpan',uris=>$url,}}sub git_uri {my ($self,$uri)=@_;($uri,my$commitish)=split /(?<=\.git)@/i,$uri,2;my$dir=File::Temp::tempdir(CLEANUP=>1);$self->mask_output(diag_progress=>"Cloning $uri");$self->run(['git','clone',$uri,$dir ]);unless (-e "$dir/.git"){$self->diag_fail("Failed cloning git repository $uri",1);return}if ($commitish){require File::pushd;my$dir=File::pushd::pushd($dir);unless ($self->run(['git','checkout',$commitish ])){$self->diag_fail("Failed to checkout '$commitish' in git repository $uri\n");return}}$self->diag_ok;return {source=>'local',dir=>$dir,}}sub setup_module_build_patch {my$self=shift;open my$out,">$self->{base}/ModuleBuildSkipMan.pm" or die $!;print$out <<EOF}sub core_version_for {my($self,$module)=@_;require Module::CoreList;unless (exists$Module::CoreList::version{$]+0}){die sprintf("Module::CoreList %s (loaded from %s) doesn't seem to have entries for perl $]. " ."You're strongly recommended to upgrade Module::CoreList from CPAN.\n",$Module::CoreList::VERSION,$INC{"Module/CoreList.pm"})}unless (exists$Module::CoreList::version{$]+0}{$module}){return -1}return$Module::CoreList::version{$]+0}{$module}}sub search_inc {my$self=shift;$self->{search_inc}||= do {if (defined$::Bin){[grep!/^\Q$::Bin\E\/..\/(?:fat)?lib$/,@INC]}else {[@INC]}}}sub check_module {my($self,$mod,$want_ver)=@_;require Module::Metadata;my$meta=Module::Metadata->new_from_module($mod,inc=>$self->search_inc)or return 0,undef;my$version=$meta->version;if ($self->{self_contained}&& $self->loaded_from_perl_lib($meta)){$version=$self->core_version_for($mod);return 0,undef if$version && $version==-1}$self->{local_versions}{$mod}=$version;if ($self->is_deprecated($meta)){return 0,$version}elsif ($self->satisfy_version($mod,$version,$want_ver)){return 1,($version || 'undef')}else {return 0,$version}}sub satisfy_version {my($self,$mod,$version,$want_ver)=@_;$want_ver='0' unless defined($want_ver)&& length($want_ver);require CPAN::Meta::Requirements;my$requirements=CPAN::Meta::Requirements->new;$requirements->add_string_requirement($mod,$want_ver);$requirements->accepts_module($mod,$version)}sub unsatisfy_how {my($self,$ver,$want_ver)=@_;if ($want_ver =~ /^[v0-9\.\_]+$/){return "$ver < $want_ver"}else {return "$ver doesn't satisfy $want_ver"}}sub is_deprecated {my($self,$meta)=@_;my$deprecated=eval {require Module::CoreList;Module::CoreList::is_deprecated($meta->{module})};return$deprecated && $self->loaded_from_perl_lib($meta)}sub loaded_from_perl_lib {my($self,$meta)=@_;require Config;my@dirs=qw(archlibexp privlibexp);if ($self->{self_contained}&&!$self->{exclude_vendor}&& $Config{vendorarch}){unshift@dirs,qw(vendorarch vendorlibexp)}for my$dir (@dirs){my$confdir=$Config{$dir};if ($confdir eq substr($meta->filename,0,length($confdir))){return 1}}return}sub should_install {my($self,$mod,$ver)=@_;$self->chat("Checking if you have $mod $ver ... ");my($ok,$local)=$self->check_module($mod,$ver);if ($ok){$self->chat("Yes ($local)\n")}elsif ($local){$self->chat("No (" .$self->unsatisfy_how($local,$ver).")\n")}else {$self->chat("No\n")}return$mod unless$ok;return}sub check_perl_version {my($self,$version)=@_;require CPAN::Meta::Requirements;my$req=CPAN::Meta::Requirements->from_string_hash({perl=>$version });$req->accepts_module(perl=>$])}sub install_deps {my($self,$dir,$depth,@deps)=@_;my(@install,%seen,@fail);for my$dep (@deps){next if$seen{$dep->module};if ($dep->module eq 'perl'){if ($dep->is_requirement &&!$self->check_perl_version($dep->version)){$self->diag("Needs perl @{[$dep->version]}, you have $]\n");push@fail,'perl'}}elsif ($self->should_install($dep->module,$dep->version)){push@install,$dep;$seen{$dep->module}=1}}if (@install){$self->diag("==> Found dependencies: " .join(", ",map $_->module,@install)."\n")}for my$dep (@install){$self->install_module($dep->module,$depth + 1,$dep->version)}$self->chdir($self->{base});$self->chdir($dir)if$dir;if ($self->{scandeps}){return 1}my@not_ok=$self->unsatisfied_deps(@deps);if (@not_ok){return 0,\@not_ok}else {return 1}}sub unsatisfied_deps {my($self,@deps)=@_;require CPAN::Meta::Check;require CPAN::Meta::Requirements;my$reqs=CPAN::Meta::Requirements->new;for my$dep (grep $_->is_requirement,@deps){$reqs->add_string_requirement($dep->module=>$dep->requires_version || '0')}my$ret=CPAN::Meta::Check::check_requirements($reqs,'requires',$self->{search_inc});grep defined,values %$ret}sub install_deps_bailout {my($self,$target,$dir,$depth,@deps)=@_;my($ok,$fail)=$self->install_deps($dir,$depth,@deps);if (!$ok){$self->diag_fail("Installing the dependencies failed: " .join(", ",@$fail),1);unless ($self->prompt_bool("Do you want to continue building $target anyway?","n")){$self->diag_fail("Bailing out the installation for $target.",1);return}}return 1}sub build_stuff {my($self,$stuff,$dist,$depth)=@_;if ($self->{verify}&& -e 'SIGNATURE'){$self->verify_signature($dist)or return}require CPAN::Meta;my($meta_file)=grep -f,qw(META.json META.yml);if ($meta_file){$self->chat("Checking configure dependencies from $meta_file\n");$dist->{cpanmeta}=eval {CPAN::Meta->load_file($meta_file)}}elsif ($dist->{dist}&& $dist->{version}){$self->chat("META.yml/json not found. Creating skeleton for it.\n");$dist->{cpanmeta}=CPAN::Meta->new({name=>$dist->{dist},version=>$dist->{version}})}$dist->{meta}=$dist->{cpanmeta}? $dist->{cpanmeta}->as_struct : {};my@config_deps;if ($dist->{cpanmeta}){push@config_deps,App::cpanminus::Dependency->from_prereqs($dist->{cpanmeta}->effective_prereqs,['configure'],$self->{install_types},)}if (-e 'Build.PL' &&!$self->should_use_mm($dist->{dist})&&!@config_deps){push@config_deps,App::cpanminus::Dependency->from_versions({'Module::Build'=>'0.38' },'configure',)}$self->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},".")}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;if (@config_deps){my@tree=@{$self->{scandeps_tree}};$diag .= "!\n" .join("",map "! * $_->[0]{module}\n",@tree[0..$#tree-1])if@tree}$self->diag("!\n$diag!\n",1)}$walkup->();return 1}if ($self->{installdeps}&& $depth==0){if ($configure_state->{configured_ok}){$self->diag("<== Installed dependencies for $stuff. Finishing.\n");return 1}else {$self->diag("! Configuring $distname failed. See $self->{log} for details.\n",1);return}}my$installed;if ($configure_state->{use_module_build}&& -e 'Build' && -f _){$self->diag_progress("Building " .($self->{notest}? "" : "and testing ").$distname);$self->build([$self->{perl},"./Build" ],$distname,$depth)&& $self->test([$self->{perl},"./Build","test" ],$distname,$depth)&& $self->install([$self->{perl},"./Build","install" ],["--uninst",1 ],$depth)&& $installed++}elsif ($self->{make}&& -e 'Makefile'){$self->diag_progress("Building " .($self->{notest}? "" : "and testing ").$distname);$self->build([$self->{make}],$distname,$depth)&& $self->test([$self->{make},"test" ],$distname,$depth)&& $self->install([$self->{make},"install" ],["UNINST=1" ],$depth)&& $installed++}else {my$why;my$configure_failed=$configure_state->{configured}&&!$configure_state->{configured_ok};if ($configure_failed){$why="Configure failed for $distname."}elsif ($self->{make}){$why="The distribution doesn't have a proper Makefile.PL/Build.PL"}else {$why="Can't configure the distribution. You probably need to have 'make'."}$self->diag_fail("$why See $self->{log} for details.",1);return}if ($installed && $self->{test_only}){$self->diag_ok;$self->diag("Successfully tested $distname\n",1)}elsif ($installed){my$local=$self->{local_versions}{$dist->{module}|| ''};my$version=$dist->{module_version}|| $dist->{meta}{version}|| $dist->{version};my$reinstall=$local && ($local eq $version);my$action=$local &&!$reinstall ? $self->numify_ver($version)< $self->numify_ver($local)? "downgraded" : "upgraded" : undef;my$how=$reinstall ? "reinstalled $distname" : $local ? "installed $distname ($action from $local)" : "installed $distname" ;my$msg="Successfully $how";$self->diag_ok;$self->diag("$msg\n",1);$self->{installed_dists}++;$self->save_meta($stuff,$dist,$module_name,\@config_deps,\@deps);return 1}else {my$what=$self->{test_only}? "Testing" : "Installing";$self->diag_fail("$what $stuff failed. See $self->{log} for details. Retry with --force to force install it.",1);return}}sub perl_requirements {my($self,@requires)=@_;my@perl;for my$requires (grep defined,@requires){if (exists$requires->{perl}){push@perl,App::cpanminus::Dependency->new(perl=>$requires->{perl})}}return@perl}sub should_use_mm {my($self,$dist)=@_;my%should_use_mm=map {$_=>1}qw(version ExtUtils-ParseXS ExtUtils-Install ExtUtils-Manifest);$should_use_mm{$dist}}sub configure_this {my($self,$dist,$depth)=@_;if (-e $self->{cpanfile_path}&& $self->{installdeps}&& $depth==0){require Module::CPANfile;$dist->{cpanfile}=eval {Module::CPANfile->load($self->{cpanfile_path})};$self->diag_fail($@,1)if $@;return {configured=>1,configured_ok=>!!$dist->{cpanfile},use_module_build=>0,}}if ($self->{skip_configure}){my$eumm=-e 'Makefile';my$mb=-e 'Build' && -f _;return {configured=>1,configured_ok=>$eumm || $mb,use_module_build=>$mb,}}my$state={};my$try_eumm=sub {if (-e 'Makefile.PL'){$self->chat("Running Makefile.PL\n");if ($self->configure([$self->{perl},"Makefile.PL" ],$depth)){$state->{configured_ok}=-e 'Makefile'}$state->{configured}++}};my$try_mb=sub {if (-e 'Build.PL'){$self->chat("Running Build.PL\n");if ($self->configure([$self->{perl},"Build.PL" ],$depth)){$state->{configured_ok}=-e 'Build' && -f _}$state->{use_module_build}++;$state->{configured}++}};my@try;if ($dist->{dist}&& $self->should_use_mm($dist->{dist})){@try=($try_eumm,$try_mb)}else {@try=($try_mb,$try_eumm)}for my$try (@try){$try->();last if$state->{configured_ok}}unless ($state->{configured_ok}){while (1){my$ans=lc$self->prompt("Configuring $dist->{dist} failed.\nYou can s)kip, r)etry, e)xamine build log, or l)ook ?","s");last if$ans eq 's';return$self->configure_this($dist,$depth)if$ans eq 'r';$self->show_build_log if$ans eq 'e';$self->look if$ans eq 'l'}}return$state}sub find_module_name {my($self,$state)=@_;return unless$state->{configured_ok};if ($state->{use_module_build}&& -e "_build/build_params"){my$params=do {open my$in,"_build/build_params";$self->safe_eval(join "",<$in>)};return eval {$params->[2]{module_name}}|| undef}elsif (-e "Makefile"){open my$mf,"Makefile";while (<$mf>){if (/^\#\s+NAME\s+=>\s+(.*)/){return$self->safe_eval($1)}}}return}sub list_files {my$self=shift;if (-e 'MANIFEST'){require ExtUtils::Manifest;my$manifest=eval {ExtUtils::Manifest::manifind()}|| {};return sort {lc$a cmp lc$b}keys %$manifest}else {require File::Find;my@files;my$finder=sub {my$name=$File::Find::name;$name =~ s!\.[/\\]!!;push@files,$name};File::Find::find($finder,".");return sort {lc$a cmp lc$b}@files}}sub extract_packages {my($self,$meta,$dir)=@_;my$try=sub {my$file=shift;return 0 if$file =~ m!^(?:x?t|inc|local|perl5|fatlib|_build)/!;return 1 unless$meta->{no_index};return 0 if grep {$file =~ m!^$_/!}@{$meta->{no_index}{directory}|| []};return 0 if grep {$file eq $_}@{$meta->{no_index}{file}|| []};return 1};require Parse::PMFile;my@files=grep {/\.pm(?:\.PL)?$/ && $try->($_)}$self->list_files;my$provides={};for my$file (@files){my$parser=Parse::PMFile->new($meta,{UNSAFE=>1,ALLOW_DEV_VERSION=>1 });my$packages=$parser->parse($file);while (my($package,$meta)=each %$packages){$provides->{$package}||= {file=>$meta->{infile},($meta->{version}eq 'undef')? (): (version=>$meta->{version}),}}}return$provides}sub save_meta {my($self,$module,$dist,$module_name,$config_deps,$build_deps)=@_;return unless$dist->{distvname}&& $dist->{source}eq 'cpan';my$base=($ENV{PERL_MM_OPT}|| '')=~ /INSTALL_BASE=/ ? ($self->install_base($ENV{PERL_MM_OPT})."/lib/perl5"): $Config{sitelibexp};my$provides=$dist->{provides};File::Path::mkpath("blib/meta",0,0777);my$local={name=>$module_name,target=>$module,version=>exists$provides->{$module_name}? ($provides->{$module_name}{version}|| $dist->{version}): $dist->{version},dist=>$dist->{distvname},pathname=>$dist->{pathname},provides=>$provides,};require JSON::PP;open my$fh,">","blib/meta/install.json" or die $!;print$fh JSON::PP::encode_json($local);if (-e "MYMETA.json"){File::Copy::copy("MYMETA.json","blib/meta/MYMETA.json")}my@cmd=(($self->{sudo}? 'sudo' : ()),$^X,'-MExtUtils::Install=install','-e',qq[install({ 'blib/meta' => '$base/$Config{archname}/.meta/$dist->{distvname}' })],);$self->run(\@cmd)}sub _merge_hashref {my($self,@hashrefs)=@_;my%hash;for my$h (@hashrefs){%hash=(%hash,%$h)}return \%hash}sub install_base {my($self,$mm_opt)=@_;$mm_opt =~ /INSTALL_BASE=(\S+)/ and return $1;die "Your PERL_MM_OPT doesn't contain INSTALL_BASE"}sub safe_eval {my($self,$code)=@_;eval$code}sub configure_features {my($self,$dist,@features)=@_;map $_->identifier,grep {$self->effective_feature($dist,$_)}@features}sub effective_feature {my($self,$dist,$feature)=@_;if ($dist->{depth}==0){my$value=$self->{features}{$feature->identifier};return$value if defined$value;return 1 if$self->{features}{__all}}if ($self->{interactive}){require CPAN::Meta::Requirements;$self->diag("[@{[ $feature->description ]}]\n",1);my$req=CPAN::Meta::Requirements->new;for my$phase (@{$dist->{want_phases}}){for my$type (@{$self->{install_types}}){$req->add_requirements($feature->prereqs->requirements_for($phase,$type))}}my$reqs=$req->as_string_hash;my@missing;for my$module (keys %$reqs){if ($self->should_install($module,$req->{$module})){push@missing,$module}}if (@missing){my$howmany=@missing;$self->diag("==> Found missing dependencies: " .join(", ",@missing)."\n",1);local$self->{prompt}=1;return$self->prompt_bool("Install the $howmany optional module(s)?","y")}}return}sub find_prereqs {my($self,$dist)=@_;my@deps=$self->extract_meta_prereqs($dist);if ($dist->{module}=~ /^Bundle::/i){push@deps,$self->bundle_deps($dist)}$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);$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})}sub soften_makemaker_prereqs {my($self,$prereqs)=@_;return$prereqs unless -e "inc/Module/Install.pm";for my$phase (qw(build test runtime)){my$reqs=$prereqs->requirements_for($phase,'requires');if ($reqs->requirements_for_module('ExtUtils::MakeMaker')){$reqs->clear_requirement('ExtUtils::MakeMaker');$reqs->add_minimum('ExtUtils::MakeMaker'=>0)}}$prereqs}sub cleanup_workdirs {my$self=shift;my$expire=time - 24 * 60 * 60 * $self->{auto_cleanup};my@targets;opendir my$dh,"$self->{home}/work";while (my$e=readdir$dh){next if$e !~ /^(\d+)\.\d+$/;my$time=$1;if ($time < $expire){push@targets,"$self->{home}/work/$e"}}if (@targets){if (@targets >= 64){$self->diag("Expiring " .scalar(@targets)." work directories. This might take a while...\n")}else {$self->chat("Expiring " .scalar(@targets)." work directories.\n")}File::Path::rmtree(\@targets,0,0)}}sub scandeps_append_child {my($self,$dist)=@_;my$new_node=[$dist,[]];my$curr_node=$self->{scandeps_current}|| [undef,$self->{scandeps_tree}];push @{$curr_node->[1]},$new_node;$self->{scandeps_current}=$new_node;return sub {$self->{scandeps_current}=$curr_node}}sub dump_scandeps {my$self=shift;if ($self->{format}eq 'tree'){$self->walk_down(sub {my($dist,$depth)=@_;if ($depth==0){print "$dist->{distvname}\n"}else {print " " x ($depth - 1);print "\\_ $dist->{distvname}\n"}},1)}elsif ($self->{format}=~ /^dists?$/){$self->walk_down(sub {my($dist,$depth)=@_;print$self->format_dist($dist),"\n"},0)}elsif ($self->{format}eq 'json'){require JSON::PP;print JSON::PP::encode_json($self->{scandeps_tree})}elsif ($self->{format}eq 'yaml'){require YAML;print YAML::Dump($self->{scandeps_tree})}else {$self->diag("Unknown format: $self->{format}\n")}}sub walk_down {my($self,$cb,$pre)=@_;$self->_do_walk_down($self->{scandeps_tree},$cb,0,$pre)}sub _do_walk_down {my($self,$children,$cb,$depth,$pre)=@_;for my$node (@$children){$cb->($node->[0],$depth)if$pre;$self->_do_walk_down($node->[1],$cb,$depth + 1,$pre);$cb->($node->[0],$depth)unless$pre}}sub DESTROY {my$self=shift;$self->{at_exit}->($self)if$self->{at_exit}}sub shell_quote {my($self,@stuff)=@_;if (WIN32){join ' ',map {/^${quote}.+${quote}$/ ? $_ : ($quote .$_ .$quote)}@stuff}else {String::ShellQuote::shell_quote_best_effort(@stuff)}}sub which {my($self,$name)=@_;if (File::Spec->file_name_is_absolute($name)){if (-x $name &&!-d _){return$name}}my$exe_ext=$Config{_exe};for my$dir (File::Spec->path){my$fullpath=File::Spec->catfile($dir,$name);if ((-x $fullpath || -x ($fullpath .= $exe_ext))&&!-d _){if ($fullpath =~ /\s/){$fullpath=$self->shell_quote($fullpath)}return$fullpath}}return}sub get {my($self,$uri)=@_;if ($uri =~ /^file:/){$self->file_get($uri)}else {$self->{_backends}{get}->(@_)}}sub mirror {my($self,$uri,$local)=@_;if ($uri =~ /^file:/){$self->file_mirror($uri,$local)}else {$self->{_backends}{mirror}->(@_)}}sub untar {$_[0]->{_backends}{untar}->(@_)};sub unzip {$_[0]->{_backends}{unzip}->(@_)};sub uri_to_file {my($self,$uri)=@_;if ($uri =~ s!file:/+!!){$uri="/$uri" unless$uri =~ m![a-zA-Z]:!}return$uri}sub file_get {my($self,$uri)=@_;my$file=$self->uri_to_file($uri);open my$fh,"<$file" or return;join '',<$fh>}sub file_mirror {my($self,$uri,$path)=@_;my$file=$self->uri_to_file($uri);my$source_mtime=(stat$file)[9];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;LWP::UserAgent->VERSION(5.802);require LWP::Protocol::https if$https;1}}sub init_tools {my$self=shift;return if$self->{initialized}++;if ($self->{make}=$self->which($Config{make})){$self->chat("You have make $self->{make}\n")}if ($self->{try_lwp}&& $self->has_working_lwp($self->{mirrors})){$self->chat("You have LWP $LWP::VERSION\n");my$ua=sub {LWP::UserAgent->new(parse_head=>0,env_proxy=>1,agent=>$self->agent,timeout=>30,@_,)};$self->{_backends}{get}=sub {my$self=shift;my$res=$ua->()->request(HTTP::Request->new(GET=>$_[0]));return unless$res->is_success;return$res->decoded_content};$self->{_backends}{mirror}=sub {my$self=shift;my$res=$ua->()->mirror(@_);die$res->content if$res->code==501;$res->code}}elsif ($self->{try_wget}and my$wget=$self->which('wget')){$self->chat("You have $wget\n");my@common=('--user-agent',$self->agent,'--retry-connrefused',($self->{verbose}? (): ('-q')),);$self->{_backends}{get}=sub {my($self,$uri)=@_;$self->safeexec(my$fh,$wget,$uri,@common,'-O','-')or die "wget $uri: $!";local $/;<$fh>};$self->{_backends}{mirror}=sub {my($self,$uri,$path)=@_;$self->safeexec(my$fh,$wget,$uri,@common,'-O',$path)or die "wget $uri: $!";local $/;<$fh>}}elsif ($self->{try_curl}and my$curl=$self->which('curl')){$self->chat("You have $curl\n");my@common=('--location','--user-agent',$self->agent,($self->{verbose}? (): '-s'),);$self->{_backends}{get}=sub {my($self,$uri)=@_;$self->safeexec(my$fh,$curl,@common,$uri)or die "curl $uri: $!";local $/;<$fh>};$self->{_backends}{mirror}=sub {my($self,$uri,$path)=@_;$self->safeexec(my$fh,$curl,@common,$uri,'-#','-o',$path)or die "curl $uri: $!";local $/;<$fh>}}else {require HTTP::Tiny;$self->chat("Falling back to HTTP::Tiny $HTTP::Tiny::VERSION\n");my%common=(agent=>$self->agent,);$self->{_backends}{get}=sub {my$self=shift;my$res=HTTP::Tiny->new(%common)->get($_[0]);return unless$res->{success};return$res->{content}};$self->{_backends}{mirror}=sub {my$self=shift;my$res=HTTP::Tiny->new(%common)->mirror(@_);return$res->{status}}}my$tar=$self->which('tar');my$tar_ver;my$maybe_bad_tar=sub {WIN32 || BAD_TAR || (($tar_ver=`$tar --version 2>/dev/null`)=~ /GNU.*1\.13/i)};if ($tar &&!$maybe_bad_tar->()){chomp$tar_ver;$self->chat("You have $tar: $tar_ver\n");$self->{_backends}{untar}=sub {my($self,$tarfile)=@_;my$xf=($self->{verbose}? 'v' : '')."xf";my$ar=$tarfile =~ /bz2$/ ? 'j' : 'z';my($root,@others)=`$tar ${ar}tf $tarfile` or return undef;FILE: {chomp$root;$root =~ s!^\./!!;$root =~ s{^(.+?)/.*$}{$1};if (!length($root)){$root=shift(@others);redo FILE if$root}}system "$tar $ar$xf $tarfile";return$root if -d $root;$self->diag_fail("Bad archive: $tarfile");return undef}}elsif ($tar and my$gzip=$self->which('gzip')and my$bzip2=$self->which('bzip2')){$self->chat("You have $tar, $gzip and $bzip2\n");$self->{_backends}{untar}=sub {my($self,$tarfile)=@_;my$x="x" .($self->{verbose}? 'v' : '')."f -";my$ar=$tarfile =~ /bz2$/ ? $bzip2 : $gzip;my($root,@others)=`$ar -dc $tarfile | $tar tf -` or return undef;FILE: {chomp$root;$root =~ s!^\./!!;$root =~ s{^(.+?)/.*$}{$1};if (!length($root)){$root=shift(@others);redo FILE if$root}}system "$ar -dc $tarfile | $tar $x";return$root if -d $root;$self->diag_fail("Bad archive: $tarfile");return undef}}elsif (eval {require Archive::Tar}){$self->chat("Falling back to Archive::Tar $Archive::Tar::VERSION\n");$self->{_backends}{untar}=sub {my$self=shift;my$t=Archive::Tar->new($_[0]);my($root,@others)=$t->list_files;FILE: {$root =~ s!^\./!!;$root =~ s{^(.+?)/.*$}{$1};if (!length($root)){$root=shift(@others);redo FILE if$root}}$t->extract;return -d $root ? $root : undef}}else {$self->{_backends}{untar}=sub {die "Failed to extract $_[1] - You need to have tar or Archive::Tar installed.\n"}}if (my$unzip=$self->which('unzip')){$self->chat("You have $unzip\n");$self->{_backends}{unzip}=sub {my($self,$zipfile)=@_;my$opt=$self->{verbose}? '' : '-q';my(undef,$root,@others)=`$unzip -t $zipfile` or return undef;FILE: {chomp$root;if ($root !~ s{^\s+testing:\s+([^/]+)/.*?\s+OK$}{$1}){$root=shift(@others);redo FILE if$root}}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; 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 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 Usage: cpanm [options] Module [...] Try `cpanm --help` or `man cpanm` for more options. USAGE 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 ! ! 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 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 $module is not found in the following directories and can't be uninstalled. @{[ join(" \n", map " $_", @inc) ]} DIAG package ModuleBuildSkipMan; CHECK { if (%Module::Build::) { no warnings 'redefine'; *Module::Build::Base::ACTION_manpages = sub {}; *Module::Build::Base::ACTION_docs = sub {}; } } 1; EOF ! Configuring $distname failed. See $self->{log} for details. ! You might have to install the following modules first to get --scandeps working correctly. DIAG 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//}$version =~ s/-withoutworldwriteables$//;if ($version =~ /^(-[Vv].*)-(\d.*)/){$dist .= $1;$version=$2}if ($version =~ /(.+_.*)-(\d.*)/){$dist .= $1;$version=$2}$dist =~ s{\.pm$}{};$version=$1 if!length$version and $dist =~ s/-(\d+\w)$//;$version=$1 .$version if$version =~ /^\d+$/ and $dist =~ s/-(\w+)$//;if ($version =~ /\d\.\d/){$version =~ s/^[-_.]+//}else {$version =~ s/^[-_]+//}my$dev;if (length$version){if ($file =~ /^perl-?\d+\.(\d+)(?:\D(\d+))?(-(?:TRIAL|RC)\d+)?$/){$dev=1 if (($1 > 6 and $1 & 1)or ($2 and $2 >= 50))or $3}elsif ($version =~ /\d\D\d+_\d/ or $version =~ /-TRIAL/){$dev=1}}else {$version=undef}($dist,$version,$dev)}sub new {my$class=shift;my$distfile=shift;$distfile =~ s,//+,/,g;my%info=(pathname=>$distfile);($info{filename}=$distfile)=~ s,^(((.*?/)?authors/)?id/)?([A-Z])/(\4[A-Z])/(\5[-A-Z0-9]*)/,, and $info{cpanid}=$6;if ($distfile =~ m,([^/]+)\.(tar\.(?:g?z|bz2)|zip|tgz)$,i){$info{distvname}=$1;$info{extension}=$2}@info{qw(dist version beta)}=distname_info($info{distvname});$info{maturity}=delete$info{beta}? 'developer' : 'released';return bless \%info,$class}sub dist {shift->{dist}}sub version {shift->{version}}sub maturity {shift->{maturity}}sub filename {shift->{filename}}sub cpanid {shift->{cpanid}}sub distvname {shift->{distvname}}sub extension {shift->{extension}}sub pathname {shift->{pathname}}sub properties {%{$_[0]}}1; CPAN_DISTNAMEINFO $fatpacked{"CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META'; use 5.006;use strict;use warnings;package CPAN::Meta;our$VERSION='2.150005';use Carp qw(carp croak);use CPAN::Meta::Feature;use CPAN::Meta::Prereqs;use CPAN::Meta::Converter;use CPAN::Meta::Validator;use Parse::CPAN::Meta 1.4414 ();BEGIN {*_dclone=\&CPAN::Meta::Converter::_dclone}BEGIN {my@STRING_READERS=qw(abstract description dynamic_config generated_by name release_status version);no strict 'refs';for my$attr (@STRING_READERS){*$attr=sub {$_[0]{$attr }}}}BEGIN {my@LIST_READERS=qw(author keywords license);no strict 'refs';for my$attr (@LIST_READERS){*$attr=sub {my$value=$_[0]{$attr };croak "$attr must be called in list context" unless wantarray;return @{_dclone($value)}if ref$value;return$value}}}sub authors {$_[0]->author}sub licenses {$_[0]->license}BEGIN {my@MAP_READERS=qw(meta-spec resources provides no_index prereqs optional_features);no strict 'refs';for my$attr (@MAP_READERS){(my$subname=$attr)=~ s/-/_/;*$subname=sub {my$value=$_[0]{$attr };return _dclone($value)if$value;return {}}}}sub custom_keys {return grep {/^x_/i}keys %{$_[0]}}sub custom {my ($self,$attr)=@_;my$value=$self->{$attr};return _dclone($value)if ref$value;return$value}sub _new {my ($class,$struct,$options)=@_;my$self;if ($options->{lazy_validation}){my$cmc=CPAN::Meta::Converter->new($struct);$self=$cmc->convert(version=>2);return bless$self,$class}else {my$cmv=CPAN::Meta::Validator->new($struct);unless ($cmv->is_valid){die "Invalid metadata structure. Errors: " .join(", ",$cmv->errors)."\n"}}my$version=$struct->{'meta-spec'}{version}|| '1.0';if ($version==2){$self=$struct}else {my$cmc=CPAN::Meta::Converter->new($struct);$self=$cmc->convert(version=>2)}return bless$self,$class}sub new {my ($class,$struct,$options)=@_;my$self=eval {$class->_new($struct,$options)};croak($@)if $@;return$self}sub create {my ($class,$struct,$options)=@_;my$version=__PACKAGE__->VERSION || 2;$struct->{generated_by}||= __PACKAGE__ ." version $version" ;$struct->{'meta-spec'}{version}||= int($version);my$self=eval {$class->_new($struct,$options)};croak ($@)if $@;return$self}sub load_file {my ($class,$file,$options)=@_;$options->{lazy_validation}=1 unless exists$options->{lazy_validation};croak "load_file() requires a valid, readable filename" unless -r $file;my$self;eval {my$struct=Parse::CPAN::Meta->load_file($file);$self=$class->_new($struct,$options)};croak($@)if $@;return$self}sub load_yaml_string {my ($class,$yaml,$options)=@_;$options->{lazy_validation}=1 unless exists$options->{lazy_validation};my$self;eval {my ($struct)=Parse::CPAN::Meta->load_yaml_string($yaml);$self=$class->_new($struct,$options)};croak($@)if $@;return$self}sub load_json_string {my ($class,$json,$options)=@_;$options->{lazy_validation}=1 unless exists$options->{lazy_validation};my$self;eval {my$struct=Parse::CPAN::Meta->load_json_string($json);$self=$class->_new($struct,$options)};croak($@)if $@;return$self}sub load_string {my ($class,$string,$options)=@_;$options->{lazy_validation}=1 unless exists$options->{lazy_validation};my$self;eval {my$struct=Parse::CPAN::Meta->load_string($string);$self=$class->_new($struct,$options)};croak($@)if $@;return$self}sub save {my ($self,$file,$options)=@_;my$version=$options->{version}|| '2';my$layer=$] ge '5.008001' ? ':utf8' : '';if ($version ge '2'){carp "'$file' should end in '.json'" unless$file =~ m{\.json$}}else {carp "'$file' should end in '.yml'" unless$file =~ m{\.yml$}}my$data=$self->as_string($options);open my$fh,">$layer",$file or die "Error opening '$file' for writing: $!\n";print {$fh}$data;close$fh or die "Error closing '$file': $!\n";return 1}sub meta_spec_version {my ($self)=@_;return$self->meta_spec->{version}}sub effective_prereqs {my ($self,$features)=@_;$features ||= [];my$prereq=CPAN::Meta::Prereqs->new($self->prereqs);return$prereq unless @$features;my@other=map {;$self->feature($_)->prereqs}@$features;return$prereq->with_merged_prereqs(\@other)}sub should_index_file {my ($self,$filename)=@_;for my$no_index_file (@{$self->no_index->{file}|| []}){return if$filename eq $no_index_file}for my$no_index_dir (@{$self->no_index->{directory}}){$no_index_dir =~ s{$}{/} unless$no_index_dir =~ m{/\z};return if index($filename,$no_index_dir)==0}return 1}sub should_index_package {my ($self,$package)=@_;for my$no_index_pkg (@{$self->no_index->{package}|| []}){return if$package eq $no_index_pkg}for my$no_index_ns (@{$self->no_index->{namespace}}){return if index($package,"${no_index_ns}::")==0}return 1}sub features {my ($self)=@_;my$opt_f=$self->optional_features;my@features=map {;CPAN::Meta::Feature->new($_=>$opt_f->{$_ })}keys %$opt_f;return@features}sub feature {my ($self,$ident)=@_;croak "no feature named $ident" unless my$f=$self->optional_features->{$ident };return CPAN::Meta::Feature->new($ident,$f)}sub as_struct {my ($self,$options)=@_;my$struct=_dclone($self);if ($options->{version}){my$cmc=CPAN::Meta::Converter->new($struct);$struct=$cmc->convert(version=>$options->{version})}return$struct}sub as_string {my ($self,$options)=@_;my$version=$options->{version}|| '2';my$struct;if ($self->meta_spec_version ne $version){my$cmc=CPAN::Meta::Converter->new($self->as_struct);$struct=$cmc->convert(version=>$version)}else {$struct=$self->as_struct}my ($data,$backend);if ($version ge '2'){$backend=Parse::CPAN::Meta->json_backend();local$struct->{x_serialization_backend}=sprintf '%s version %s',$backend,$backend->VERSION;$data=$backend->new->pretty->canonical->encode($struct)}else {$backend=Parse::CPAN::Meta->yaml_backend();local$struct->{x_serialization_backend}=sprintf '%s version %s',$backend,$backend->VERSION;$data=eval {no strict 'refs';&{"$backend\::Dump"}($struct)};if ($@){croak$backend->can('errstr')? $backend->errstr : $@}}return$data}sub TO_JSON {return {%{$_[0]}}}1; CPAN_META $fatpacked{"CPAN/Meta/Check.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_CHECK'; package CPAN::Meta::Check;$CPAN::Meta::Check::VERSION='0.018';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)=@_;return$reqs->accepts_module($module,$])? (): sprintf "Your Perl (%s) is not in the range '%s'",$],$reqs->requirements_for_module($module)if$module eq 'perl';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; CPAN_META_CHECK $fatpacked{"CPAN/Meta/Converter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_CONVERTER'; use 5.006;use strict;use warnings;package CPAN::Meta::Converter;our$VERSION='2.150005';use CPAN::Meta::Validator;use CPAN::Meta::Requirements;use Parse::CPAN::Meta 1.4400 ();BEGIN {eval "use version ()";if (my$err=$@){eval "use ExtUtils::MakeMaker::version" or die$err}}*_is_qv=version->can('is_qv')? sub {$_[0]->is_qv}: sub {exists $_[0]->{qv}};sub _dclone {my$ref=shift;no warnings 'once';no warnings 'redefine';local*UNIVERSAL::TO_JSON=sub {"$_[0]"};my$json=Parse::CPAN::Meta->json_backend()->new ->utf8 ->allow_blessed ->convert_blessed;$json->decode($json->encode($ref))}my%known_specs=('2'=>'http://search.cpan.org/perldoc?CPAN::Meta::Spec','1.4'=>'http://module-build.sourceforge.net/META-spec-v1.4.html','1.3'=>'http://module-build.sourceforge.net/META-spec-v1.3.html','1.2'=>'http://module-build.sourceforge.net/META-spec-v1.2.html','1.1'=>'http://module-build.sourceforge.net/META-spec-v1.1.html','1.0'=>'http://module-build.sourceforge.net/META-spec-v1.0.html');my@spec_list=sort {$a <=> $b}keys%known_specs;my ($LOWEST,$HIGHEST)=@spec_list[0,-1];sub _keep {$_[0]}sub _keep_or_one {defined($_[0])? $_[0]: 1}sub _keep_or_zero {defined($_[0])? $_[0]: 0}sub _keep_or_unknown {defined($_[0])&& length($_[0])? $_[0]: "unknown"}sub _generated_by {my$gen=shift;my$sig=__PACKAGE__ ." version " .(__PACKAGE__->VERSION || "<dev>");return$sig unless defined$gen and length$gen;return$gen if$gen =~ /\Q$sig/;return "$gen, $sig"}sub _listify {!defined $_[0]? undef : ref $_[0]eq 'ARRAY' ? $_[0]: [$_[0]]}sub _prefix_custom {my$key=shift;$key =~ s/^(?!x_) # Unless it already starts with x_ (?:x-?)? # Remove leading x- or x (if present) /x_/ix;return$key}sub _ucfirst_custom {my$key=shift;$key=ucfirst$key unless$key =~ /[A-Z]/;return$key}sub _no_prefix_ucfirst_custom {my$key=shift;$key =~ s/^x_//;return _ucfirst_custom($key)}sub _change_meta_spec {my ($element,undef,undef,$version)=@_;return {version=>$version,url=>$known_specs{$version},}}my@open_source=('perl','gpl','apache','artistic','artistic_2','lgpl','bsd','gpl','mit','mozilla','open_source',);my%is_open_source=map {;$_=>1}@open_source;my@valid_licenses_1=(@open_source,'unrestricted','restrictive','unknown',);my%license_map_1=((map {$_=>$_}@valid_licenses_1),artistic2=>'artistic_2',);sub _license_1 {my ($element)=@_;return 'unknown' unless defined$element;if ($license_map_1{lc$element}){return$license_map_1{lc$element}}else {return 'unknown'}}my@valid_licenses_2=qw(agpl_3 apache_1_1 apache_2_0 artistic_1 artistic_2 bsd freebsd gfdl_1_2 gfdl_1_3 gpl_1 gpl_2 gpl_3 lgpl_2_1 lgpl_3_0 mit mozilla_1_0 mozilla_1_1 openssl perl_5 qpl_1_0 ssleay sun zlib open_source restricted unrestricted unknown);my%license_map_2=((map {$_=>$_}@valid_licenses_2),apache=>'apache_2_0',artistic=>'artistic_1',artistic2=>'artistic_2',gpl=>'open_source',lgpl=>'open_source',mozilla=>'open_source',perl=>'perl_5',restrictive=>'restricted',);sub _license_2 {my ($element)=@_;return ['unknown' ]unless defined$element;$element=[$element ]unless ref$element eq 'ARRAY';my@new_list;for my$lic (@$element){next unless defined$lic;if (my$new=$license_map_2{lc$lic}){push@new_list,$new}}return@new_list ? \@new_list : ['unknown' ]}my%license_downgrade_map=qw(agpl_3 open_source apache_1_1 apache apache_2_0 apache artistic_1 artistic artistic_2 artistic_2 bsd bsd freebsd open_source gfdl_1_2 open_source gfdl_1_3 open_source gpl_1 gpl gpl_2 gpl gpl_3 gpl lgpl_2_1 lgpl lgpl_3_0 lgpl mit mit mozilla_1_0 mozilla mozilla_1_1 mozilla openssl open_source perl_5 perl qpl_1_0 open_source ssleay open_source sun open_source zlib open_source open_source open_source restricted restrictive unrestricted unrestricted unknown unknown);sub _downgrade_license {my ($element)=@_;if (!defined$element){return "unknown"}elsif(ref$element eq 'ARRAY'){if (@$element > 1){if (grep {!$is_open_source{$license_downgrade_map{lc $_}|| 'unknown' }}@$element){return 'unknown'}else {return 'open_source'}}elsif (@$element==1){return$license_downgrade_map{lc$element->[0]}|| "unknown"}}elsif (!ref$element){return$license_downgrade_map{lc$element}|| "unknown"}return "unknown"}my$no_index_spec_1_2={'file'=>\&_listify,'dir'=>\&_listify,'package'=>\&_listify,'namespace'=>\&_listify,};my$no_index_spec_1_3={'file'=>\&_listify,'directory'=>\&_listify,'package'=>\&_listify,'namespace'=>\&_listify,};my$no_index_spec_2={'file'=>\&_listify,'directory'=>\&_listify,'package'=>\&_listify,'namespace'=>\&_listify,':custom'=>\&_prefix_custom,};sub _no_index_1_2 {my (undef,undef,$meta)=@_;my$no_index=$meta->{no_index}|| $meta->{private};return unless$no_index;if (!ref$no_index){my$item=$no_index;$no_index={dir=>[$item ],file=>[$item ]}}elsif (ref$no_index eq 'ARRAY'){my$list=$no_index;$no_index={dir=>[@$list ],file=>[@$list ]}}if (exists$no_index->{files}){$no_index->{file}=delete$no_index->{files}}if (exists$no_index->{modules}){$no_index->{module}=delete$no_index->{modules}}return _convert($no_index,$no_index_spec_1_2)}sub _no_index_directory {my ($element,$key,$meta,$version)=@_;return unless$element;if (!ref$element){my$item=$element;$element={directory=>[$item ],file=>[$item ]}}elsif (ref$element eq 'ARRAY'){my$list=$element;$element={directory=>[@$list ],file=>[@$list ]}}if (exists$element->{dir}){$element->{directory}=delete$element->{dir}}if (exists$element->{files}){$element->{file}=delete$element->{files}}if (exists$element->{modules}){$element->{module}=delete$element->{modules}}my$spec=$version==2 ? $no_index_spec_2 : $no_index_spec_1_3;return _convert($element,$spec)}sub _is_module_name {my$mod=shift;return unless defined$mod && length$mod;return$mod =~ m{^[A-Za-z][A-Za-z0-9_]*(?:::[A-Za-z0-9_]+)*$}}sub _clean_version {my ($element)=@_;return 0 if!defined$element;$element =~ s{^\s*}{};$element =~ s{\s*$}{};$element =~ s{^\.}{0.};return 0 if!length$element;return 0 if ($element eq 'undef' || $element eq '<undef>');my$v=eval {version->new($element)};if (defined$v){return _is_qv($v)? $v->normal : $element}else {return 0}}sub _bad_version_hook {my ($v)=@_;$v =~ s{^\s*}{};$v =~ s{\s*$}{};$v =~ s{[a-z]+$}{};my$vobj=eval {version->new($v)};return defined($vobj)? $vobj : version->new(0)}sub _version_map {my ($element)=@_;return unless defined$element;if (ref$element eq 'HASH'){my$new_map=CPAN::Meta::Requirements->new({bad_version_hook=>\&_bad_version_hook });while (my ($k,$v)=each %$element){next unless _is_module_name($k);if (!defined($v)||!length($v)|| $v eq 'undef' || $v eq '<undef>'){$v=0}if (_is_module_name($v)&&!version::is_lax($v)){$new_map->add_minimum($k=>0);$new_map->add_minimum($v=>0)}$new_map->add_string_requirement($k=>$v)}return$new_map->as_string_hash}elsif (ref$element eq 'ARRAY'){my$hashref={map {$_=>0}@$element };return _version_map($hashref)}elsif (ref$element eq '' && length$element){return {$element=>0 }}return}sub _prereqs_from_1 {my (undef,undef,$meta)=@_;my$prereqs={};for my$phase (qw/build configure/){my$key="${phase}_requires";$prereqs->{$phase}{requires}=_version_map($meta->{$key})if$meta->{$key}}for my$rel (qw/requires recommends conflicts/){$prereqs->{runtime}{$rel}=_version_map($meta->{$rel})if$meta->{$rel}}return$prereqs}my$prereqs_spec={configure=>\&_prereqs_rel,build=>\&_prereqs_rel,test=>\&_prereqs_rel,runtime=>\&_prereqs_rel,develop=>\&_prereqs_rel,':custom'=>\&_prefix_custom,};my$relation_spec={requires=>\&_version_map,recommends=>\&_version_map,suggests=>\&_version_map,conflicts=>\&_version_map,':custom'=>\&_prefix_custom,};sub _cleanup_prereqs {my ($prereqs,$key,$meta,$to_version)=@_;return unless$prereqs && ref$prereqs eq 'HASH';return _convert($prereqs,$prereqs_spec,$to_version)}sub _prereqs_rel {my ($relation,$key,$meta,$to_version)=@_;return unless$relation && ref$relation eq 'HASH';return _convert($relation,$relation_spec,$to_version)}BEGIN {my@old_prereqs=qw(requires configure_requires recommends conflicts);for (@old_prereqs){my$sub="_get_$_";my ($phase,$type)=split qr/_/,$_;if (!defined$type){$type=$phase;$phase='runtime'}no strict 'refs';*{$sub}=sub {_extract_prereqs($_[2]->{prereqs},$phase,$type)}}}sub _get_build_requires {my ($data,$key,$meta)=@_;my$test_h=_extract_prereqs($_[2]->{prereqs},qw(test requires))|| {};my$build_h=_extract_prereqs($_[2]->{prereqs},qw(build requires))|| {};my$test_req=CPAN::Meta::Requirements->from_string_hash($test_h);my$build_req=CPAN::Meta::Requirements->from_string_hash($build_h);$test_req->add_requirements($build_req)->as_string_hash}sub _extract_prereqs {my ($prereqs,$phase,$type)=@_;return unless ref$prereqs eq 'HASH';return scalar _version_map($prereqs->{$phase}{$type})}sub _downgrade_optional_features {my (undef,undef,$meta)=@_;return unless exists$meta->{optional_features};my$origin=$meta->{optional_features};my$features={};for my$name (keys %$origin){$features->{$name}={description=>$origin->{$name}{description},requires=>_extract_prereqs($origin->{$name}{prereqs},'runtime','requires'),configure_requires=>_extract_prereqs($origin->{$name}{prereqs},'runtime','configure_requires'),build_requires=>_extract_prereqs($origin->{$name}{prereqs},'runtime','build_requires'),recommends=>_extract_prereqs($origin->{$name}{prereqs},'runtime','recommends'),conflicts=>_extract_prereqs($origin->{$name}{prereqs},'runtime','conflicts'),};for my$k (keys %{$features->{$name}}){delete$features->{$name}{$k}unless defined$features->{$name}{$k}}}return$features}sub _upgrade_optional_features {my (undef,undef,$meta)=@_;return unless exists$meta->{optional_features};my$origin=$meta->{optional_features};my$features={};for my$name (keys %$origin){$features->{$name}={description=>$origin->{$name}{description},prereqs=>_prereqs_from_1(undef,undef,$origin->{$name}),};delete$features->{$name}{prereqs}{configure}}return$features}my$optional_features_2_spec={description=>\&_keep,prereqs=>\&_cleanup_prereqs,':custom'=>\&_prefix_custom,};sub _feature_2 {my ($element,$key,$meta,$to_version)=@_;return unless$element && ref$element eq 'HASH';_convert($element,$optional_features_2_spec,$to_version)}sub _cleanup_optional_features_2 {my ($element,$key,$meta,$to_version)=@_;return unless$element && ref$element eq 'HASH';my$new_data={};for my$k (keys %$element){$new_data->{$k}=_feature_2($element->{$k},$k,$meta,$to_version)}return unless keys %$new_data;return$new_data}sub _optional_features_1_4 {my ($element)=@_;return unless$element;$element=_optional_features_as_map($element);for my$name (keys %$element){for my$drop (qw/requires_packages requires_os excluded_os/){delete$element->{$name}{$drop}}}return$element}sub _optional_features_as_map {my ($element)=@_;return unless$element;if (ref$element eq 'ARRAY'){my%map;for my$feature (@$element){my (@parts)=%$feature;$map{$parts[0]}=$parts[1]}$element=\%map}return$element}sub _is_urlish {defined $_[0]&& $_[0]=~ m{\A[-+.a-z0-9]+:.+}i}sub _url_or_drop {my ($element)=@_;return$element if _is_urlish($element);return}sub _url_list {my ($element)=@_;return unless$element;$element=_listify($element);$element=[grep {_is_urlish($_)}@$element ];return unless @$element;return$element}sub _author_list {my ($element)=@_;return ['unknown' ]unless$element;$element=_listify($element);$element=[map {defined $_ && length $_ ? $_ : 'unknown'}@$element ];return ['unknown' ]unless @$element;return$element}my$resource2_upgrade={license=>sub {return _is_urlish($_[0])? _listify($_[0]): undef},homepage=>\&_url_or_drop,bugtracker=>sub {my ($item)=@_;return unless$item;if ($item =~ m{^mailto:(.*)$}){return {mailto=>$1 }}elsif(_is_urlish($item)){return {web=>$item }}else {return}},repository=>sub {return _is_urlish($_[0])? {url=>$_[0]}: undef},':custom'=>\&_prefix_custom,};sub _upgrade_resources_2 {my (undef,undef,$meta,$version)=@_;return unless exists$meta->{resources};return _convert($meta->{resources},$resource2_upgrade)}my$bugtracker2_spec={web=>\&_url_or_drop,mailto=>\&_keep,':custom'=>\&_prefix_custom,};sub _repo_type {my ($element,$key,$meta,$to_version)=@_;return$element if defined$element;return unless exists$meta->{url};my$repo_url=$meta->{url};for my$type (qw/git svn/){return$type if$repo_url =~ m{\A$type}}return}my$repository2_spec={web=>\&_url_or_drop,url=>\&_url_or_drop,type=>\&_repo_type,':custom'=>\&_prefix_custom,};my$resources2_cleanup={license=>\&_url_list,homepage=>\&_url_or_drop,bugtracker=>sub {ref $_[0]? _convert($_[0],$bugtracker2_spec): undef},repository=>sub {my$data=shift;ref$data ? _convert($data,$repository2_spec): undef},':custom'=>\&_prefix_custom,};sub _cleanup_resources_2 {my ($resources,$key,$meta,$to_version)=@_;return unless$resources && ref$resources eq 'HASH';return _convert($resources,$resources2_cleanup,$to_version)}my$resource1_spec={license=>\&_url_or_drop,homepage=>\&_url_or_drop,bugtracker=>\&_url_or_drop,repository=>\&_url_or_drop,':custom'=>\&_keep,};sub _resources_1_3 {my (undef,undef,$meta,$version)=@_;return unless exists$meta->{resources};return _convert($meta->{resources},$resource1_spec)}*_resources_1_4=*_resources_1_3;sub _resources_1_2 {my (undef,undef,$meta)=@_;my$resources=$meta->{resources}|| {};if ($meta->{license_url}&&!$resources->{license}){$resources->{license}=$meta->{license_url}if _is_urlish($meta->{license_url})}return unless keys %$resources;return _convert($resources,$resource1_spec)}my$resource_downgrade_spec={license=>sub {return ref $_[0]? $_[0]->[0]: $_[0]},homepage=>\&_url_or_drop,bugtracker=>sub {return $_[0]->{web}},repository=>sub {return $_[0]->{url}|| $_[0]->{web}},':custom'=>\&_no_prefix_ucfirst_custom,};sub _downgrade_resources {my (undef,undef,$meta,$version)=@_;return unless exists$meta->{resources};return _convert($meta->{resources},$resource_downgrade_spec)}sub _release_status {my ($element,undef,$meta)=@_;return$element if$element && $element =~ m{\A(?:stable|testing|unstable)\z};return _release_status_from_version(undef,undef,$meta)}sub _release_status_from_version {my (undef,undef,$meta)=@_;my$version=$meta->{version}|| '';return ($version =~ /_/)? 'testing' : 'stable'}my$provides_spec={file=>\&_keep,version=>\&_keep,};my$provides_spec_2={file=>\&_keep,version=>\&_keep,':custom'=>\&_prefix_custom,};sub _provides {my ($element,$key,$meta,$to_version)=@_;return unless defined$element && ref$element eq 'HASH';my$spec=$to_version==2 ? $provides_spec_2 : $provides_spec;my$new_data={};for my$k (keys %$element){$new_data->{$k}=_convert($element->{$k},$spec,$to_version);$new_data->{$k}{version}=_clean_version($element->{$k}{version})if exists$element->{$k}{version}}return$new_data}sub _convert {my ($data,$spec,$to_version,$is_fragment)=@_;my$new_data={};for my$key (keys %$spec){next if$key eq ':custom' || $key eq ':drop';next unless my$fcn=$spec->{$key};if ($is_fragment && $key eq 'generated_by'){$fcn=\&_keep}die "spec for '$key' is not a coderef" unless ref$fcn && ref$fcn eq 'CODE';my$new_value=$fcn->($data->{$key},$key,$data,$to_version);$new_data->{$key}=$new_value if defined$new_value}my$drop_list=$spec->{':drop'};my$customizer=$spec->{':custom'}|| \&_keep;for my$key (keys %$data){next if$drop_list && grep {$key eq $_}@$drop_list;next if exists$spec->{$key};$new_data->{$customizer->($key)}=$data->{$key}}return$new_data}my%up_convert=('2-from-1.4'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_2,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'release_status'=>\&_release_status,'keywords'=>\&_keep,'no_index'=>\&_no_index_directory,'optional_features'=>\&_upgrade_optional_features,'provides'=>\&_provides,'resources'=>\&_upgrade_resources_2,'description'=>\&_keep,'prereqs'=>\&_prereqs_from_1,':drop'=>[qw(build_requires configure_requires conflicts distribution_type license_url private recommends requires) ],':custom'=>\&_prefix_custom,},'1.4-from-1.3'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'keywords'=>\&_keep,'no_index'=>\&_no_index_directory,'optional_features'=>\&_optional_features_1_4,'provides'=>\&_provides,'recommends'=>\&_version_map,'requires'=>\&_version_map,'resources'=>\&_resources_1_4,'configure_requires'=>\&_keep,':drop'=>[qw(license_url private)],':custom'=>\&_keep },'1.3-from-1.2'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'keywords'=>\&_keep,'no_index'=>\&_no_index_directory,'optional_features'=>\&_optional_features_as_map,'provides'=>\&_provides,'recommends'=>\&_version_map,'requires'=>\&_version_map,'resources'=>\&_resources_1_3,':drop'=>[qw(license_url private)],':custom'=>\&_keep },'1.2-from-1.1'=>{'version'=>\&_keep,'license'=>\&_license_1,'name'=>\&_keep,'generated_by'=>\&_generated_by,'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'meta-spec'=>\&_change_meta_spec,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'recommends'=>\&_version_map,'requires'=>\&_version_map,'keywords'=>\&_keep,'no_index'=>\&_no_index_1_2,'optional_features'=>\&_optional_features_as_map,'provides'=>\&_provides,'resources'=>\&_resources_1_2,':drop'=>[qw(license_url private)],':custom'=>\&_keep },'1.1-from-1.0'=>{'version'=>\&_keep,'name'=>\&_keep,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'recommends'=>\&_version_map,'requires'=>\&_version_map,'license_url'=>\&_url_or_drop,'private'=>\&_keep,':custom'=>\&_keep },);my%down_convert=('1.4-from-2'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_downgrade_license,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'build_requires'=>\&_get_build_requires,'configure_requires'=>\&_get_configure_requires,'conflicts'=>\&_get_conflicts,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'keywords'=>\&_keep,'no_index'=>\&_no_index_directory,'optional_features'=>\&_downgrade_optional_features,'provides'=>\&_provides,'recommends'=>\&_get_recommends,'requires'=>\&_get_requires,'resources'=>\&_downgrade_resources,':drop'=>[qw(description prereqs release_status)],':custom'=>\&_keep },'1.3-from-1.4'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'keywords'=>\&_keep,'no_index'=>\&_no_index_directory,'optional_features'=>\&_optional_features_as_map,'provides'=>\&_provides,'recommends'=>\&_version_map,'requires'=>\&_version_map,'resources'=>\&_resources_1_3,':drop'=>[qw(configure_requires)],':custom'=>\&_keep,},'1.2-from-1.3'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'keywords'=>\&_keep,'no_index'=>\&_no_index_1_2,'optional_features'=>\&_optional_features_as_map,'provides'=>\&_provides,'recommends'=>\&_version_map,'requires'=>\&_version_map,'resources'=>\&_resources_1_3,':custom'=>\&_keep,},'1.1-from-1.2'=>{'version'=>\&_keep,'name'=>\&_keep,'meta-spec'=>\&_change_meta_spec,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'private'=>\&_keep,'recommends'=>\&_version_map,'requires'=>\&_version_map,':drop'=>[qw(abstract author provides no_index keywords resources)],':custom'=>\&_keep,},'1.0-from-1.1'=>{'name'=>\&_keep,'meta-spec'=>\&_change_meta_spec,'version'=>\&_keep,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'recommends'=>\&_version_map,'requires'=>\&_version_map,':custom'=>\&_keep,},);my%cleanup=('2'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_2,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'release_status'=>\&_release_status,'keywords'=>\&_keep,'no_index'=>\&_no_index_directory,'optional_features'=>\&_cleanup_optional_features_2,'provides'=>\&_provides,'resources'=>\&_cleanup_resources_2,'description'=>\&_keep,'prereqs'=>\&_cleanup_prereqs,':drop'=>[qw(build_requires configure_requires conflicts distribution_type license_url private recommends requires) ],':custom'=>\&_prefix_custom,},'1.4'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'keywords'=>\&_keep,'no_index'=>\&_no_index_directory,'optional_features'=>\&_optional_features_1_4,'provides'=>\&_provides,'recommends'=>\&_version_map,'requires'=>\&_version_map,'resources'=>\&_resources_1_4,'configure_requires'=>\&_keep,':custom'=>\&_keep },'1.3'=>{'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'meta-spec'=>\&_change_meta_spec,'name'=>\&_keep,'version'=>\&_keep,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'keywords'=>\&_keep,'no_index'=>\&_no_index_directory,'optional_features'=>\&_optional_features_as_map,'provides'=>\&_provides,'recommends'=>\&_version_map,'requires'=>\&_version_map,'resources'=>\&_resources_1_3,':custom'=>\&_keep },'1.2'=>{'version'=>\&_keep,'license'=>\&_license_1,'name'=>\&_keep,'generated_by'=>\&_generated_by,'abstract'=>\&_keep_or_unknown,'author'=>\&_author_list,'meta-spec'=>\&_change_meta_spec,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'recommends'=>\&_version_map,'requires'=>\&_version_map,'keywords'=>\&_keep,'no_index'=>\&_no_index_1_2,'optional_features'=>\&_optional_features_as_map,'provides'=>\&_provides,'resources'=>\&_resources_1_2,':custom'=>\&_keep },'1.1'=>{'version'=>\&_keep,'name'=>\&_keep,'meta-spec'=>\&_change_meta_spec,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'recommends'=>\&_version_map,'requires'=>\&_version_map,'license_url'=>\&_url_or_drop,'private'=>\&_keep,':custom'=>\&_keep },'1.0'=>{'name'=>\&_keep,'meta-spec'=>\&_change_meta_spec,'version'=>\&_keep,'build_requires'=>\&_version_map,'conflicts'=>\&_version_map,'distribution_type'=>\&_keep,'dynamic_config'=>\&_keep_or_one,'generated_by'=>\&_generated_by,'license'=>\&_license_1,'recommends'=>\&_version_map,'requires'=>\&_version_map,':custom'=>\&_keep,},);my%fragments_generate=('2'=>{'abstract'=>'abstract','author'=>'author','generated_by'=>'generated_by','license'=>'license','name'=>'name','version'=>'version','dynamic_config'=>'dynamic_config','release_status'=>'release_status','keywords'=>'keywords','no_index'=>'no_index','optional_features'=>'optional_features','provides'=>'provides','resources'=>'resources','description'=>'description','prereqs'=>'prereqs',},'1.4'=>{'abstract'=>'abstract','author'=>'author','generated_by'=>'generated_by','license'=>'license','name'=>'name','version'=>'version','build_requires'=>'prereqs','conflicts'=>'prereqs','distribution_type'=>'distribution_type','dynamic_config'=>'dynamic_config','keywords'=>'keywords','no_index'=>'no_index','optional_features'=>'optional_features','provides'=>'provides','recommends'=>'prereqs','requires'=>'prereqs','resources'=>'resources','configure_requires'=>'prereqs',},);$fragments_generate{$_}=$fragments_generate{'1.4'}for qw/1.3 1.2 1.1 1.0/;sub new {my ($class,$data,%args)=@_;my$self={'data'=>$data,'spec'=>_extract_spec_version($data,$args{default_version}),};return bless$self,$class}sub _extract_spec_version {my ($data,$default)=@_;my$spec=$data->{'meta-spec'};return($default || "1.0")unless defined$spec && ref$spec eq 'HASH';my$v=$spec->{version};if (defined$v && $v =~ /^\d+(?:\.\d+)?$/){return$v if defined$v && grep {$v eq $_}keys%known_specs;return$v+0 if defined$v && grep {$v==$_}keys%known_specs}return "2" if exists$data->{prereqs};return "1.4" if exists$data->{configure_requires};return($default || "1.2")}sub convert {my ($self,%args)=@_;my$args={%args };my$new_version=$args->{version}|| $HIGHEST;my$is_fragment=$args->{is_fragment};my ($old_version)=$self->{spec};my$converted=_dclone($self->{data});if ($old_version==$new_version){$converted=_convert($converted,$cleanup{$old_version},$old_version,$is_fragment);unless ($args->{is_fragment}){my$cmv=CPAN::Meta::Validator->new($converted);unless ($cmv->is_valid){my$errs=join("\n",$cmv->errors);die "Failed to clean-up $old_version metadata. Errors:\n$errs\n"}}return$converted}elsif ($old_version > $new_version){my@vers=sort {$b <=> $a}keys%known_specs;for my$i (0 .. $#vers-1){next if$vers[$i]> $old_version;last if$vers[$i+1]< $new_version;my$spec_string="$vers[$i+1]-from-$vers[$i]";$converted=_convert($converted,$down_convert{$spec_string},$vers[$i+1],$is_fragment);unless ($args->{is_fragment}){my$cmv=CPAN::Meta::Validator->new($converted);unless ($cmv->is_valid){my$errs=join("\n",$cmv->errors);die "Failed to downconvert metadata to $vers[$i+1]. Errors:\n$errs\n"}}}return$converted}else {my@vers=sort {$a <=> $b}keys%known_specs;for my$i (0 .. $#vers-1){next if$vers[$i]< $old_version;last if$vers[$i+1]> $new_version;my$spec_string="$vers[$i+1]-from-$vers[$i]";$converted=_convert($converted,$up_convert{$spec_string},$vers[$i+1],$is_fragment);unless ($args->{is_fragment}){my$cmv=CPAN::Meta::Validator->new($converted);unless ($cmv->is_valid){my$errs=join("\n",$cmv->errors);die "Failed to upconvert metadata to $vers[$i+1]. Errors:\n$errs\n"}}}return$converted}}sub upgrade_fragment {my ($self)=@_;my ($old_version)=$self->{spec};my%expected=map {;$_=>1}grep {defined}map {$fragments_generate{$old_version}{$_}}keys %{$self->{data}};my$converted=$self->convert(version=>$HIGHEST,is_fragment=>1);for my$key (keys %$converted){next if$key =~ /^x_/i || $key eq 'meta-spec';delete$converted->{$key}unless$expected{$key}}return$converted}1; 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;sub new {my ($class,$identifier,$spec)=@_;my%guts=(identifier=>$identifier,description=>$spec->{description},prereqs=>CPAN::Meta::Prereqs->new($spec->{prereqs}),);bless \%guts=>$class}sub identifier {$_[0]{identifier}}sub description {$_[0]{description}}sub prereqs {$_[0]{prereqs}}1; CPAN_META_FEATURE $fatpacked{"CPAN/Meta/History.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_HISTORY'; use 5.006;use strict;use warnings;package CPAN::Meta::History;our$VERSION='2.150005';1; 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)|| (defined$left and defined$right and $left eq $right)}sub _identical {my ($left,$right,$path)=@_;croak sprintf "Can't merge attribute %s: '%s' does not equal '%s'",join('.',@{$path}),$left,$right unless _is_identical($left,$right);return$left}sub _merge {my ($current,$next,$mergers,$path)=@_;for my$key (keys %{$next}){if (not exists$current->{$key}){$current->{$key}=$next->{$key}}elsif (my$merger=$mergers->{$key}){$current->{$key}=$merger->($current->{$key},$next->{$key},[@{$path},$key ])}elsif ($merger=$mergers->{':default'}){$current->{$key}=$merger->($current->{$key},$next->{$key},[@{$path},$key ])}else {croak sprintf "Can't merge unknown attribute '%s'",join '.',@{$path},$key}}return$current}sub _uniq {my%seen=();return grep {not $seen{$_}++}@_}sub _set_addition {my ($left,$right)=@_;return [+_uniq(@{$left},@{$right})]}sub _uniq_map {my ($left,$right,$path)=@_;for my$key (keys %{$right}){if (not exists$left->{$key}){$left->{$key}=$right->{$key}}elsif (_is_identical($left->{$key},$right->{$key})){1}elsif (ref$left->{$key}eq 'HASH' and ref$right->{$key}eq 'HASH'){$left->{$key}=_uniq_map($left->{$key},$right->{$key},[@{$path},$key ])}else {croak 'Duplication of element ' .join '.',@{$path},$key}}return$left}sub _improvize {my ($left,$right,$path)=@_;my ($name)=reverse @{$path};if ($name =~ /^x_/){if (ref($left)eq 'ARRAY'){return _set_addition($left,$right,$path)}elsif (ref($left)eq 'HASH'){return _uniq_map($left,$right,$path)}else {return _identical($left,$right,$path)}}croak sprintf "Can't merge '%s'",join '.',@{$path}}sub _optional_features {my ($left,$right,$path)=@_;for my$key (keys %{$right}){if (not exists$left->{$key}){$left->{$key}=$right->{$key}}else {for my$subkey (keys %{$right->{$key}}){next if$subkey eq 'prereqs';if (not exists$left->{$key}{$subkey}){$left->{$key}{$subkey}=$right->{$key}{$subkey}}else {Carp::croak "Cannot merge two optional_features named '$key' with different '$subkey' values" if do {no warnings 'uninitialized';$left->{$key}{$subkey}ne $right->{$key}{$subkey}}}}require CPAN::Meta::Prereqs;$left->{$key}{prereqs}=CPAN::Meta::Prereqs->new($left->{$key}{prereqs})->with_merged_prereqs(CPAN::Meta::Prereqs->new($right->{$key}{prereqs}))->as_string_hash}}return$left}my%default=(abstract=>\&_identical,author=>\&_set_addition,dynamic_config=>sub {my ($left,$right)=@_;return$left || $right},generated_by=>sub {my ($left,$right)=@_;return join ', ',_uniq(split(/, /,$left),split(/, /,$right))},license=>\&_set_addition,'meta-spec'=>{version=>\&_identical,url=>\&_identical },name=>\&_identical,release_status=>\&_identical,version=>\&_identical,description=>\&_identical,keywords=>\&_set_addition,no_index=>{map {($_=>\&_set_addition)}qw/file directory package namespace/ },optional_features=>\&_optional_features,prereqs=>sub {require CPAN::Meta::Prereqs;my ($left,$right)=map {CPAN::Meta::Prereqs->new($_)}@_[0,1];return$left->with_merged_prereqs($right)->as_string_hash},provides=>\&_uniq_map,resources=>{license=>\&_set_addition,homepage=>\&_identical,bugtracker=>\&_uniq_map,repository=>\&_uniq_map,':default'=>\&_improvize,},':default'=>\&_improvize,);sub new {my ($class,%arguments)=@_;croak 'default version required' if not exists$arguments{default_version};my%mapping=%default;my%extra=%{$arguments{extra_mappings}|| {}};for my$key (keys%extra){if (ref($mapping{$key})eq 'HASH'){$mapping{$key}={%{$mapping{$key}},%{$extra{$key}}}}else {$mapping{$key}=$extra{$key}}}return bless {default_version=>$arguments{default_version},mapping=>_coerce_mapping(\%mapping,[]),},$class}my%coderef_for=(set_addition=>\&_set_addition,uniq_map=>\&_uniq_map,identical=>\&_identical,improvize=>\&_improvize,);sub _coerce_mapping {my ($orig,$map_path)=@_;my%ret;for my$key (keys %{$orig}){my$value=$orig->{$key};if (ref($orig->{$key})eq 'CODE'){$ret{$key}=$value}elsif (ref($value)eq 'HASH'){my$mapping=_coerce_mapping($value,[@{$map_path},$key ]);$ret{$key}=sub {my ($left,$right,$path)=@_;return _merge($left,$right,$mapping,[@{$path}])}}elsif ($coderef_for{$value}){$ret{$key}=$coderef_for{$value}}else {croak "Don't know what to do with " .join '.',@{$map_path},$key}}return \%ret}sub merge {my ($self,@items)=@_;my$current={};for my$next (@items){if (blessed($next)&& $next->isa('CPAN::Meta')){$next=$next->as_struct}elsif (ref($next)eq 'HASH'){my$cmc=CPAN::Meta::Converter->new($next,default_version=>$self->{default_version});$next=$cmc->upgrade_fragment}else {croak "Don't know how to merge '$next'"}$current=_merge($current,$next,$self->{mapping},[])}return$current}1; CPAN_META_MERGE $fatpacked{"CPAN/Meta/Prereqs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_PREREQS'; use 5.006;use strict;use warnings;package CPAN::Meta::Prereqs;our$VERSION='2.150005';use Carp qw(confess);use Scalar::Util qw(blessed);use CPAN::Meta::Requirements 2.121;sub __legal_phases {qw(configure build test runtime develop)}sub __legal_types {qw(requires recommends suggests conflicts)}sub new {my ($class,$prereq_spec)=@_;$prereq_spec ||= {};my%is_legal_phase=map {;$_=>1}$class->__legal_phases;my%is_legal_type=map {;$_=>1}$class->__legal_types;my%guts;PHASE: for my$phase (keys %$prereq_spec){next PHASE unless$phase =~ /\Ax_/i or $is_legal_phase{$phase};my$phase_spec=$prereq_spec->{$phase };next PHASE unless keys %$phase_spec;TYPE: for my$type (keys %$phase_spec){next TYPE unless$type =~ /\Ax_/i or $is_legal_type{$type};my$spec=$phase_spec->{$type };next TYPE unless keys %$spec;$guts{prereqs}{$phase}{$type}=CPAN::Meta::Requirements->from_string_hash($spec)}}return bless \%guts=>$class}sub requirements_for {my ($self,$phase,$type)=@_;confess "requirements_for called without phase" unless defined$phase;confess "requirements_for called without type" unless defined$type;unless ($phase =~ /\Ax_/i or grep {$phase eq $_}$self->__legal_phases){confess "requested requirements for unknown phase: $phase"}unless ($type =~ /\Ax_/i or grep {$type eq $_}$self->__legal_types){confess "requested requirements for unknown type: $type"}my$req=($self->{prereqs}{$phase}{$type}||= CPAN::Meta::Requirements->new);$req->finalize if$self->is_finalized;return$req}sub with_merged_prereqs {my ($self,$other)=@_;my@other=blessed($other)? $other : @$other;my@prereq_objs=($self,@other);my%new_arg;for my$phase ($self->__legal_phases){for my$type ($self->__legal_types){my$req=CPAN::Meta::Requirements->new;for my$prereq (@prereq_objs){my$this_req=$prereq->requirements_for($phase,$type);next unless$this_req->required_modules;$req->add_requirements($this_req)}next unless$req->required_modules;$new_arg{$phase }{$type }=$req->as_string_hash}}return (ref$self)->new(\%new_arg)}sub merged_requirements {my ($self,$phases,$types)=@_;$phases=[qw/runtime build test/]unless defined$phases;$types=[qw/requires recommends/]unless defined$types;confess "merged_requirements phases argument must be an arrayref" unless ref$phases eq 'ARRAY';confess "merged_requirements types argument must be an arrayref" unless ref$types eq 'ARRAY';my$req=CPAN::Meta::Requirements->new;for my$phase (@$phases){unless ($phase =~ /\Ax_/i or grep {$phase eq $_}$self->__legal_phases){confess "requested requirements for unknown phase: $phase"}for my$type (@$types){unless ($type =~ /\Ax_/i or grep {$type eq $_}$self->__legal_types){confess "requested requirements for unknown type: $type"}$req->add_requirements($self->requirements_for($phase,$type))}}$req->finalize if$self->is_finalized;return$req}sub as_string_hash {my ($self)=@_;my%hash;for my$phase ($self->__legal_phases){for my$type ($self->__legal_types){my$req=$self->requirements_for($phase,$type);next unless$req->required_modules;$hash{$phase }{$type }=$req->as_string_hash}}return \%hash}sub is_finalized {$_[0]{finalized}}sub finalize {my ($self)=@_;$self->{finalized}=1;for my$phase (keys %{$self->{prereqs}}){$_->finalize for values %{$self->{prereqs}{$phase}}}}sub clone {my ($self)=@_;my$clone=(ref$self)->new($self->as_string_hash)}1; CPAN_META_PREREQS $fatpacked{"CPAN/Meta/Requirements.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_REQUIREMENTS'; use strict;use warnings;package CPAN::Meta::Requirements;our$VERSION='2.133';use Carp ();BEGIN {eval "use version ()";if (my$err=$@){eval "use ExtUtils::MakeMaker::version" or die$err}}*_is_qv=version->can('is_qv')? sub {$_[0]->is_qv}: sub {exists $_[0]->{qv}};my$V0=version->new(0);my@valid_options=qw(bad_version_hook);sub new {my ($class,$options)=@_;$options ||= {};Carp::croak "Argument to $class\->new() must be a hash reference" unless ref$options eq 'HASH';my%self=map {;$_=>$options->{$_}}@valid_options;return bless \%self=>$class}sub _find_magic_vstring {my$value=shift;my$tvalue='';require B;my$sv=B::svref_2object(\$value);my$magic=ref($sv)eq 'B::PVMG' ? $sv->MAGIC : undef;while ($magic){if ($magic->TYPE eq 'V'){$tvalue=$magic->PTR;$tvalue =~ s/^v?(.+)$/v$1/;last}else {$magic=$magic->MOREMAGIC}}return$tvalue}sub _isa_version {UNIVERSAL::isa($_[0],'UNIVERSAL')&& $_[0]->isa('version')}sub _version_object {my ($self,$module,$version)=@_;my ($vobj,$err);if (not defined$version or (!ref($version)&& $version eq '0')){return$V0}elsif (ref($version)eq 'version' || _isa_version($version)){$vobj=$version}else {if ($INC{'version/vpp.pm'}|| $INC{'ExtUtils/MakeMaker/version/vpp.pm'}){my$magic=_find_magic_vstring($version);$version=$magic if length$magic}eval {local$SIG{__WARN__}=sub {die "Invalid version: $_[0]"};$vobj=version->new($version)};if (my$err=$@){my$hook=$self->{bad_version_hook};$vobj=eval {$hook->($version,$module)}if ref$hook eq 'CODE';unless (eval {$vobj->isa("version")}){$err =~ s{ at .* line \d+.*$}{};die "Can't convert '$version': $err"}}}if ($vobj =~ m{\A\.}){$vobj=version->new("0$vobj")}if (_is_qv($vobj)){$vobj=version->new($vobj->normal)}return$vobj}BEGIN {for my$type (qw(maximum exclusion exact_version)){my$method="with_$type";my$to_add=$type eq 'exact_version' ? $type : "add_$type";my$code=sub {my ($self,$name,$version)=@_;$version=$self->_version_object($name,$version);$self->__modify_entry_for($name,$method,$version);return$self};no strict 'refs';*$to_add=$code}}sub add_minimum {my ($self,$name,$version)=@_;if (not defined$version or "$version" eq '0'){return$self if$self->__entry_for($name);Carp::confess("can't add new requirements to finalized requirements")if$self->is_finalized;$self->{requirements}{$name }=CPAN::Meta::Requirements::_Range::Range->with_minimum($V0)}else {$version=$self->_version_object($name,$version);$self->__modify_entry_for($name,'with_minimum',$version)}return$self}sub add_requirements {my ($self,$req)=@_;for my$module ($req->required_modules){my$modifiers=$req->__entry_for($module)->as_modifiers;for my$modifier (@$modifiers){my ($method,@args)=@$modifier;$self->$method($module=>@args)}}return$self}sub accepts_module {my ($self,$module,$version)=@_;$version=$self->_version_object($module,$version);return 1 unless my$range=$self->__entry_for($module);return$range->_accepts($version)}sub clear_requirement {my ($self,$module)=@_;return$self unless$self->__entry_for($module);Carp::confess("can't clear requirements on finalized requirements")if$self->is_finalized;delete$self->{requirements}{$module };return$self}sub requirements_for_module {my ($self,$module)=@_;my$entry=$self->__entry_for($module);return unless$entry;return$entry->as_string}sub required_modules {keys %{$_[0]{requirements}}}sub clone {my ($self)=@_;my$new=(ref$self)->new;return$new->add_requirements($self)}sub __entry_for {$_[0]{requirements}{$_[1]}}sub __modify_entry_for {my ($self,$name,$method,$version)=@_;my$fin=$self->is_finalized;my$old=$self->__entry_for($name);Carp::confess("can't add new requirements to finalized requirements")if$fin and not $old;my$new=($old || 'CPAN::Meta::Requirements::_Range::Range')->$method($version);Carp::confess("can't modify finalized requirements")if$fin and $old->as_string ne $new->as_string;$self->{requirements}{$name }=$new}sub is_simple {my ($self)=@_;for my$module ($self->required_modules){return if$self->__entry_for($module)->as_string =~ /\s/}return 1}sub is_finalized {$_[0]{finalized}}sub finalize {$_[0]{finalized}=1}sub as_string_hash {my ($self)=@_;my%hash=map {;$_=>$self->{requirements}{$_}->as_string}$self->required_modules;return \%hash}my%methods_for_op=('=='=>[qw(exact_version) ],'!='=>[qw(add_exclusion) ],'>='=>[qw(add_minimum) ],'<='=>[qw(add_maximum) ],'>'=>[qw(add_minimum add_exclusion) ],'<'=>[qw(add_maximum add_exclusion) ],);sub add_string_requirement {my ($self,$module,$req)=@_;unless (defined$req && length$req){$req=0;$self->_blank_carp($module)}my$magic=_find_magic_vstring($req);if (length$magic){$self->add_minimum($module=>$magic);return}my@parts=split qr{\s*,\s*},$req;for my$part (@parts){my ($op,$ver)=$part =~ m{\A\s*(==|>=|>|<=|<|!=)\s*(.*)\z};if (!defined$op){$self->add_minimum($module=>$part)}else {Carp::confess("illegal requirement string: $req")unless my$methods=$methods_for_op{$op };$self->$_($module=>$ver)for @$methods}}}sub _blank_carp {my ($self,$module)=@_;Carp::carp("Undefined requirement for $module treated as '0'")}sub from_string_hash {my ($class,$hash,$options)=@_;my$self=$class->new($options);for my$module (keys %$hash){my$req=$hash->{$module};unless (defined$req && length$req){$req=0;$class->_blank_carp($module)}$self->add_string_requirement($module,$req)}return$self}{package CPAN::Meta::Requirements::_Range::Exact;sub _new {bless {version=>$_[1]}=>$_[0]}sub _accepts {return $_[0]{version}==$_[1]}sub as_string {return "== $_[0]{version}"}sub as_modifiers {return [[exact_version=>$_[0]{version}]]}sub _clone {(ref $_[0])->_new(version->new($_[0]{version}))}sub with_exact_version {my ($self,$version)=@_;return$self->_clone if$self->_accepts($version);Carp::confess("illegal requirements: unequal exact version specified")}sub with_minimum {my ($self,$minimum)=@_;return$self->_clone if$self->{version}>= $minimum;Carp::confess("illegal requirements: minimum above exact specification")}sub with_maximum {my ($self,$maximum)=@_;return$self->_clone if$self->{version}<= $maximum;Carp::confess("illegal requirements: maximum below exact specification")}sub with_exclusion {my ($self,$exclusion)=@_;return$self->_clone unless$exclusion==$self->{version};Carp::confess("illegal requirements: excluded exact specification")}}{package CPAN::Meta::Requirements::_Range::Range;sub _self {ref($_[0])? $_[0]: (bless {}=>$_[0])}sub _clone {return (bless {}=>$_[0])unless ref $_[0];my ($s)=@_;my%guts=((exists$s->{minimum}? (minimum=>version->new($s->{minimum})): ()),(exists$s->{maximum}? (maximum=>version->new($s->{maximum})): ()),(exists$s->{exclusions}? (exclusions=>[map {version->new($_)}@{$s->{exclusions}}]): ()),);bless \%guts=>ref($s)}sub as_modifiers {my ($self)=@_;my@mods;push@mods,[add_minimum=>$self->{minimum}]if exists$self->{minimum};push@mods,[add_maximum=>$self->{maximum}]if exists$self->{maximum};push@mods,map {;[add_exclusion=>$_ ]}@{$self->{exclusions}|| []};return \@mods}sub as_string {my ($self)=@_;return 0 if!keys %$self;return "$self->{minimum}" if (keys %$self)==1 and exists$self->{minimum};my@exclusions=@{$self->{exclusions}|| []};my@parts;for my$pair ([qw(>= > minimum) ],[qw(<= < maximum) ],){my ($op,$e_op,$k)=@$pair;if (exists$self->{$k}){my@new_exclusions=grep {$_!=$self->{$k }}@exclusions;if (@new_exclusions==@exclusions){push@parts,"$op $self->{ $k }"}else {push@parts,"$e_op $self->{ $k }";@exclusions=@new_exclusions}}}push@parts,map {;"!= $_"}@exclusions;return join q{, },@parts}sub with_exact_version {my ($self,$version)=@_;$self=$self->_clone;Carp::confess("illegal requirements: exact specification outside of range")unless$self->_accepts($version);return CPAN::Meta::Requirements::_Range::Exact->_new($version)}sub _simplify {my ($self)=@_;if (defined$self->{minimum}and defined$self->{maximum}){if ($self->{minimum}==$self->{maximum}){Carp::confess("illegal requirements: excluded all values")if grep {$_==$self->{minimum}}@{$self->{exclusions}|| []};return CPAN::Meta::Requirements::_Range::Exact->_new($self->{minimum})}Carp::confess("illegal requirements: minimum exceeds maximum")if$self->{minimum}> $self->{maximum}}if ($self->{exclusions}){my%seen;@{$self->{exclusions}}=grep {(!defined$self->{minimum}or $_ >= $self->{minimum})and (!defined$self->{maximum}or $_ <= $self->{maximum})and !$seen{$_}++}@{$self->{exclusions}}}return$self}sub with_minimum {my ($self,$minimum)=@_;$self=$self->_clone;if (defined (my$old_min=$self->{minimum})){$self->{minimum}=(sort {$b cmp $a}($minimum,$old_min))[0]}else {$self->{minimum}=$minimum}return$self->_simplify}sub with_maximum {my ($self,$maximum)=@_;$self=$self->_clone;if (defined (my$old_max=$self->{maximum})){$self->{maximum}=(sort {$a cmp $b}($maximum,$old_max))[0]}else {$self->{maximum}=$maximum}return$self->_simplify}sub with_exclusion {my ($self,$exclusion)=@_;$self=$self->_clone;push @{$self->{exclusions}||= []},$exclusion;return$self->_simplify}sub _accepts {my ($self,$version)=@_;return if defined$self->{minimum}and $version < $self->{minimum};return if defined$self->{maximum}and $version > $self->{maximum};return if defined$self->{exclusions}and grep {$version==$_}@{$self->{exclusions}};return 1}}1; CPAN_META_REQUIREMENTS $fatpacked{"CPAN/Meta/Spec.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_SPEC'; use 5.006;use strict;use warnings;package CPAN::Meta::Spec;our$VERSION='2.150005';1; 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';my%known_specs=('1.4'=>'http://module-build.sourceforge.net/META-spec-v1.4.html','1.3'=>'http://module-build.sourceforge.net/META-spec-v1.3.html','1.2'=>'http://module-build.sourceforge.net/META-spec-v1.2.html','1.1'=>'http://module-build.sourceforge.net/META-spec-v1.1.html','1.0'=>'http://module-build.sourceforge.net/META-spec-v1.0.html');my%known_urls=map {$known_specs{$_}=>$_}keys%known_specs;my$module_map1={'map'=>{':key'=>{name=>\&module,value=>\&exversion }}};my$module_map2={'map'=>{':key'=>{name=>\&module,value=>\&version }}};my$no_index_2={'map'=>{file=>{list=>{value=>\&string }},directory=>{list=>{value=>\&string }},'package'=>{list=>{value=>\&string }},namespace=>{list=>{value=>\&string }},':key'=>{name=>\&custom_2,value=>\&anything },}};my$no_index_1_3={'map'=>{file=>{list=>{value=>\&string }},directory=>{list=>{value=>\&string }},'package'=>{list=>{value=>\&string }},namespace=>{list=>{value=>\&string }},':key'=>{name=>\&string,value=>\&anything },}};my$no_index_1_2={'map'=>{file=>{list=>{value=>\&string }},dir=>{list=>{value=>\&string }},'package'=>{list=>{value=>\&string }},namespace=>{list=>{value=>\&string }},':key'=>{name=>\&string,value=>\&anything },}};my$no_index_1_1={'map'=>{':key'=>{name=>\&string,list=>{value=>\&string }},}};my$prereq_map={map=>{':key'=>{name=>\&phase,'map'=>{':key'=>{name=>\&relation,%$module_map1,},},}},};my%definitions=('2'=>{'abstract'=>{mandatory=>1,value=>\&string },'author'=>{mandatory=>1,list=>{value=>\&string }},'dynamic_config'=>{mandatory=>1,value=>\&boolean },'generated_by'=>{mandatory=>1,value=>\&string },'license'=>{mandatory=>1,list=>{value=>\&license }},'meta-spec'=>{mandatory=>1,'map'=>{version=>{mandatory=>1,value=>\&version},url=>{value=>\&url },':key'=>{name=>\&custom_2,value=>\&anything },}},'name'=>{mandatory=>1,value=>\&string },'release_status'=>{mandatory=>1,value=>\&release_status },'version'=>{mandatory=>1,value=>\&version },'description'=>{value=>\&string },'keywords'=>{list=>{value=>\&string }},'no_index'=>$no_index_2,'optional_features'=>{'map'=>{':key'=>{name=>\&string,'map'=>{description=>{value=>\&string },prereqs=>$prereq_map,':key'=>{name=>\&custom_2,value=>\&anything },}}}},'prereqs'=>$prereq_map,'provides'=>{'map'=>{':key'=>{name=>\&module,'map'=>{file=>{mandatory=>1,value=>\&file },version=>{value=>\&version },':key'=>{name=>\&custom_2,value=>\&anything },}}}},'resources'=>{'map'=>{license=>{list=>{value=>\&url }},homepage=>{value=>\&url },bugtracker=>{'map'=>{web=>{value=>\&url },mailto=>{value=>\&string},':key'=>{name=>\&custom_2,value=>\&anything },}},repository=>{'map'=>{web=>{value=>\&url },url=>{value=>\&url },type=>{value=>\&string },':key'=>{name=>\&custom_2,value=>\&anything },}},':key'=>{value=>\&string,name=>\&custom_2 },}},':key'=>{name=>\&custom_2,value=>\&anything },},'1.4'=>{'meta-spec'=>{mandatory=>1,'map'=>{version=>{mandatory=>1,value=>\&version},url=>{mandatory=>1,value=>\&urlspec },':key'=>{name=>\&string,value=>\&anything },},},'name'=>{mandatory=>1,value=>\&string },'version'=>{mandatory=>1,value=>\&version },'abstract'=>{mandatory=>1,value=>\&string },'author'=>{mandatory=>1,list=>{value=>\&string }},'license'=>{mandatory=>1,value=>\&license },'generated_by'=>{mandatory=>1,value=>\&string },'distribution_type'=>{value=>\&string },'dynamic_config'=>{value=>\&boolean },'requires'=>$module_map1,'recommends'=>$module_map1,'build_requires'=>$module_map1,'configure_requires'=>$module_map1,'conflicts'=>$module_map2,'optional_features'=>{'map'=>{':key'=>{name=>\&string,'map'=>{description=>{value=>\&string },requires=>$module_map1,recommends=>$module_map1,build_requires=>$module_map1,conflicts=>$module_map2,':key'=>{name=>\&string,value=>\&anything },}}}},'provides'=>{'map'=>{':key'=>{name=>\&module,'map'=>{file=>{mandatory=>1,value=>\&file },version=>{value=>\&version },':key'=>{name=>\&string,value=>\&anything },}}}},'no_index'=>$no_index_1_3,'private'=>$no_index_1_3,'keywords'=>{list=>{value=>\&string }},'resources'=>{'map'=>{license=>{value=>\&url },homepage=>{value=>\&url },bugtracker=>{value=>\&url },repository=>{value=>\&url },':key'=>{value=>\&string,name=>\&custom_1 },}},':key'=>{name=>\&string,value=>\&anything },},'1.3'=>{'meta-spec'=>{mandatory=>1,'map'=>{version=>{mandatory=>1,value=>\&version},url=>{mandatory=>1,value=>\&urlspec },':key'=>{name=>\&string,value=>\&anything },},},'name'=>{mandatory=>1,value=>\&string },'version'=>{mandatory=>1,value=>\&version },'abstract'=>{mandatory=>1,value=>\&string },'author'=>{mandatory=>1,list=>{value=>\&string }},'license'=>{mandatory=>1,value=>\&license },'generated_by'=>{mandatory=>1,value=>\&string },'distribution_type'=>{value=>\&string },'dynamic_config'=>{value=>\&boolean },'requires'=>$module_map1,'recommends'=>$module_map1,'build_requires'=>$module_map1,'conflicts'=>$module_map2,'optional_features'=>{'map'=>{':key'=>{name=>\&string,'map'=>{description=>{value=>\&string },requires=>$module_map1,recommends=>$module_map1,build_requires=>$module_map1,conflicts=>$module_map2,':key'=>{name=>\&string,value=>\&anything },}}}},'provides'=>{'map'=>{':key'=>{name=>\&module,'map'=>{file=>{mandatory=>1,value=>\&file },version=>{value=>\&version },':key'=>{name=>\&string,value=>\&anything },}}}},'no_index'=>$no_index_1_3,'private'=>$no_index_1_3,'keywords'=>{list=>{value=>\&string }},'resources'=>{'map'=>{license=>{value=>\&url },homepage=>{value=>\&url },bugtracker=>{value=>\&url },repository=>{value=>\&url },':key'=>{value=>\&string,name=>\&custom_1 },}},':key'=>{name=>\&string,value=>\&anything },},'1.2'=>{'meta-spec'=>{mandatory=>1,'map'=>{version=>{mandatory=>1,value=>\&version},url=>{mandatory=>1,value=>\&urlspec },':key'=>{name=>\&string,value=>\&anything },},},'name'=>{mandatory=>1,value=>\&string },'version'=>{mandatory=>1,value=>\&version },'license'=>{mandatory=>1,value=>\&license },'generated_by'=>{mandatory=>1,value=>\&string },'author'=>{mandatory=>1,list=>{value=>\&string }},'abstract'=>{mandatory=>1,value=>\&string },'distribution_type'=>{value=>\&string },'dynamic_config'=>{value=>\&boolean },'keywords'=>{list=>{value=>\&string }},'private'=>$no_index_1_2,'$no_index'=>$no_index_1_2,'requires'=>$module_map1,'recommends'=>$module_map1,'build_requires'=>$module_map1,'conflicts'=>$module_map2,'optional_features'=>{'map'=>{':key'=>{name=>\&string,'map'=>{description=>{value=>\&string },requires=>$module_map1,recommends=>$module_map1,build_requires=>$module_map1,conflicts=>$module_map2,':key'=>{name=>\&string,value=>\&anything },}}}},'provides'=>{'map'=>{':key'=>{name=>\&module,'map'=>{file=>{mandatory=>1,value=>\&file },version=>{value=>\&version },':key'=>{name=>\&string,value=>\&anything },}}}},'resources'=>{'map'=>{license=>{value=>\&url },homepage=>{value=>\&url },bugtracker=>{value=>\&url },repository=>{value=>\&url },':key'=>{value=>\&string,name=>\&custom_1 },}},':key'=>{name=>\&string,value=>\&anything },},'1.1'=>{'name'=>{value=>\&string },'version'=>{mandatory=>1,value=>\&version },'license'=>{value=>\&license },'generated_by'=>{value=>\&string },'license_uri'=>{value=>\&url },'distribution_type'=>{value=>\&string },'dynamic_config'=>{value=>\&boolean },'private'=>$no_index_1_1,'requires'=>$module_map1,'recommends'=>$module_map1,'build_requires'=>$module_map1,'conflicts'=>$module_map2,':key'=>{name=>\&string,value=>\&anything },},'1.0'=>{'name'=>{value=>\&string },'version'=>{mandatory=>1,value=>\&version },'license'=>{value=>\&license },'generated_by'=>{value=>\&string },'license_uri'=>{value=>\&url },'distribution_type'=>{value=>\&string },'dynamic_config'=>{value=>\&boolean },'requires'=>$module_map1,'recommends'=>$module_map1,'build_requires'=>$module_map1,'conflicts'=>$module_map2,':key'=>{name=>\&string,value=>\&anything },},);sub new {my ($class,$data)=@_;my$self={'data'=>$data,'spec'=>eval {$data->{'meta-spec'}{'version'}}|| "1.0",'errors'=>undef,};return bless$self,$class}sub is_valid {my$self=shift;my$data=$self->{data};my$spec_version=$self->{spec};$self->check_map($definitions{$spec_version},$data);return!$self->errors}sub errors {my$self=shift;return ()unless(defined$self->{errors});return @{$self->{errors}}}my$spec_error="Missing validation action in specification. " ."Must be one of 'map', 'list', or 'value'";sub check_map {my ($self,$spec,$data)=@_;if(ref($spec)ne 'HASH'){$self->_error("Unknown META specification, cannot validate.");return}if(ref($data)ne 'HASH'){$self->_error("Expected a map structure from string or file.");return}for my$key (keys %$spec){next unless($spec->{$key}->{mandatory});next if(defined$data->{$key});push @{$self->{stack}},$key;$self->_error("Missing mandatory field, '$key'");pop @{$self->{stack}}}for my$key (keys %$data){push @{$self->{stack}},$key;if($spec->{$key}){if($spec->{$key}{value}){$spec->{$key}{value}->($self,$key,$data->{$key})}elsif($spec->{$key}{'map'}){$self->check_map($spec->{$key}{'map'},$data->{$key})}elsif($spec->{$key}{'list'}){$self->check_list($spec->{$key}{'list'},$data->{$key})}else {$self->_error("$spec_error for '$key'")}}elsif ($spec->{':key'}){$spec->{':key'}{name}->($self,$key,$key);if($spec->{':key'}{value}){$spec->{':key'}{value}->($self,$key,$data->{$key})}elsif($spec->{':key'}{'map'}){$self->check_map($spec->{':key'}{'map'},$data->{$key})}elsif($spec->{':key'}{'list'}){$self->check_list($spec->{':key'}{'list'},$data->{$key})}else {$self->_error("$spec_error for ':key'")}}else {$self->_error("Unknown key, '$key', found in map structure")}pop @{$self->{stack}}}}sub check_list {my ($self,$spec,$data)=@_;if(ref($data)ne 'ARRAY'){$self->_error("Expected a list structure");return}if(defined$spec->{mandatory}){if(!defined$data->[0]){$self->_error("Missing entries from mandatory list")}}for my$value (@$data){push @{$self->{stack}},$value || "<undef>";if(defined$spec->{value}){$spec->{value}->($self,'list',$value)}elsif(defined$spec->{'map'}){$self->check_map($spec->{'map'},$value)}elsif(defined$spec->{'list'}){$self->check_list($spec->{'list'},$value)}elsif ($spec->{':key'}){$self->check_map($spec,$value)}else {$self->_error("$spec_error associated with '$self->{stack}[-2]'")}pop @{$self->{stack}}}}sub header {my ($self,$key,$value)=@_;if(defined$value){return 1 if($value && $value =~ /^--- #YAML:1.0/)}$self->_error("file does not have a valid YAML header.");return 0}sub release_status {my ($self,$key,$value)=@_;if(defined$value){my$version=$self->{data}{version}|| '';if ($version =~ /_/){return 1 if ($value =~ /\A(?:testing|unstable)\z/);$self->_error("'$value' for '$key' is invalid for version '$version'")}else {return 1 if ($value =~ /\A(?:stable|testing|unstable)\z/);$self->_error("'$value' for '$key' is invalid")}}else {$self->_error("'$key' is not defined")}return 0}sub _uri_split {return $_[0]=~ m,(?:([^:/?#]+):)?(?://([^/?#]*))?([^?#]*)(?:\?([^#]*))?(?:#(.*))?,}sub url {my ($self,$key,$value)=@_;if(defined$value){my ($scheme,$auth,$path,$query,$frag)=_uri_split($value);unless (defined$scheme && length$scheme){$self->_error("'$value' for '$key' does not have a URL scheme");return 0}unless (defined$auth && length$auth){$self->_error("'$value' for '$key' does not have a URL authority");return 0}return 1}$value ||= '';$self->_error("'$value' for '$key' is not a valid URL.");return 0}sub urlspec {my ($self,$key,$value)=@_;if(defined$value){return 1 if($value && $known_specs{$self->{spec}}eq $value);if($value && $known_urls{$value}){$self->_error('META specification URL does not match version');return 0}}$self->_error('Unknown META specification');return 0}sub anything {return 1}sub string {my ($self,$key,$value)=@_;if(defined$value){return 1 if($value || $value =~ /^0$/)}$self->_error("value is an undefined string");return 0}sub string_or_undef {my ($self,$key,$value)=@_;return 1 unless(defined$value);return 1 if($value || $value =~ /^0$/);$self->_error("No string defined for '$key'");return 0}sub file {my ($self,$key,$value)=@_;return 1 if(defined$value);$self->_error("No file defined for '$key'");return 0}sub exversion {my ($self,$key,$value)=@_;if(defined$value && ($value || $value =~ /0/)){my$pass=1;for(split(",",$value)){$self->version($key,$_)or ($pass=0)}return$pass}$value='<undef>' unless(defined$value);$self->_error("'$value' for '$key' is not a valid version.");return 0}sub version {my ($self,$key,$value)=@_;if(defined$value){return 0 unless($value || $value =~ /0/);return 1 if($value =~ /^\s*((<|<=|>=|>|!=|==)\s*)?v?\d+((\.\d+((_|\.)\d+)?)?)/)}else {$value='<undef>'}$self->_error("'$value' for '$key' is not a valid version.");return 0}sub boolean {my ($self,$key,$value)=@_;if(defined$value){return 1 if($value =~ /^(0|1|true|false)$/)}else {$value='<undef>'}$self->_error("'$value' for '$key' is not a boolean value.");return 0}my%v1_licenses=('perl'=>'http://dev.perl.org/licenses/','gpl'=>'http://www.opensource.org/licenses/gpl-license.php','apache'=>'http://apache.org/licenses/LICENSE-2.0','artistic'=>'http://opensource.org/licenses/artistic-license.php','artistic_2'=>'http://opensource.org/licenses/artistic-license-2.0.php','lgpl'=>'http://www.opensource.org/licenses/lgpl-license.php','bsd'=>'http://www.opensource.org/licenses/bsd-license.php','gpl'=>'http://www.opensource.org/licenses/gpl-license.php','mit'=>'http://opensource.org/licenses/mit-license.php','mozilla'=>'http://opensource.org/licenses/mozilla1.1.php','open_source'=>undef,'unrestricted'=>undef,'restrictive'=>undef,'unknown'=>undef,);my%v2_licenses=map {$_=>1}qw(agpl_3 apache_1_1 apache_2_0 artistic_1 artistic_2 bsd freebsd gfdl_1_2 gfdl_1_3 gpl_1 gpl_2 gpl_3 lgpl_2_1 lgpl_3_0 mit mozilla_1_0 mozilla_1_1 openssl perl_5 qpl_1_0 ssleay sun zlib open_source restricted unrestricted unknown);sub license {my ($self,$key,$value)=@_;my$licenses=$self->{spec}< 2 ? \%v1_licenses : \%v2_licenses;if(defined$value){return 1 if($value && exists$licenses->{$value})}else {$value='<undef>'}$self->_error("License '$value' is invalid");return 0}sub custom_1 {my ($self,$key)=@_;if(defined$key){return 1 if($key && $key =~ /^[_a-z]+$/i && $key =~ /[A-Z]/)}else {$key='<undef>'}$self->_error("Custom resource '$key' must be in CamelCase.");return 0}sub custom_2 {my ($self,$key)=@_;if(defined$key){return 1 if($key && $key =~ /^x_/i)}else {$key='<undef>'}$self->_error("Custom key '$key' must begin with 'x_' or 'X_'.");return 0}sub identifier {my ($self,$key)=@_;if(defined$key){return 1 if($key && $key =~ /^([a-z][_a-z]+)$/i)}else {$key='<undef>'}$self->_error("Key '$key' is not a legal identifier.");return 0}sub module {my ($self,$key)=@_;if(defined$key){return 1 if($key && $key =~ /^[A-Za-z0-9_]+(::[A-Za-z0-9_]+)*$/)}else {$key='<undef>'}$self->_error("Key '$key' is not a legal module name.");return 0}my@valid_phases=qw/configure build test runtime develop/;sub phase {my ($self,$key)=@_;if(defined$key){return 1 if(length$key && grep {$key eq $_}@valid_phases);return 1 if$key =~ /x_/i}else {$key='<undef>'}$self->_error("Key '$key' is not a legal phase.");return 0}my@valid_relations=qw/requires recommends suggests conflicts/;sub relation {my ($self,$key)=@_;if(defined$key){return 1 if(length$key && grep {$key eq $_}@valid_relations);return 1 if$key =~ /x_/i}else {$key='<undef>'}$self->_error("Key '$key' is not a legal prereq relationship.");return 0}sub _error {my$self=shift;my$mess=shift;$mess .= ' ('.join(' -> ',@{$self->{stack}}).')' if($self->{stack});$mess .= " [Validation: $self->{spec}]";push @{$self->{errors}},$mess}1; CPAN_META_VALIDATOR $fatpacked{"CPAN/Meta/YAML.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_YAML'; use 5.008001;use strict;use warnings;package CPAN::Meta::YAML;$CPAN::Meta::YAML::VERSION='0.016';;use Exporter;our@ISA=qw{Exporter};our@EXPORT=qw{Load Dump};our@EXPORT_OK=qw{LoadFile DumpFile freeze thaw};sub Dump {return CPAN::Meta::YAML->new(@_)->_dump_string}sub Load {my$self=CPAN::Meta::YAML->_load_string(@_);if (wantarray){return @$self}else {return$self->[-1]}}BEGIN {*freeze=\&Dump;*thaw=\&Load}sub DumpFile {my$file=shift;return CPAN::Meta::YAML->new(@_)->_dump_file($file)}sub LoadFile {my$file=shift;my$self=CPAN::Meta::YAML->_load_file($file);if (wantarray){return @$self}else {return$self->[-1]}}sub new {my$class=shift;bless [@_ ],$class}sub read_string {my$self=shift;$self->_load_string(@_)}sub write_string {my$self=shift;$self->_dump_string(@_)}sub read {my$self=shift;$self->_load_file(@_)}sub write {my$self=shift;$self->_dump_file(@_)}my@UNPRINTABLE=qw(0 x01 x02 x03 x04 x05 x06 a b t n v f r x0E x0F x10 x11 x12 x13 x14 x15 x16 x17 x18 x19 x1A e x1C x1D x1E x1F);my%UNESCAPES=(0=>"\x00",z=>"\x00",N=>"\x85",a=>"\x07",b=>"\x08",t=>"\x09",n=>"\x0a",v=>"\x0b",f=>"\x0c",r=>"\x0d",e=>"\x1b",'\\'=>'\\',);my%QUOTE=map {$_=>1}qw{null true false};my$re_capture_double_quoted=qr/\"([^\\"]*(?:\\.[^\\"]*)*)\"/;my$re_capture_single_quoted=qr/\'([^\']*(?:\'\'[^\']*)*)\'/;my$re_capture_unquoted_key=qr/([^:]+(?::+\S(?:[^:]*|.*?(?=:)))*)(?=\s*\:(?:\s+|$))/;my$re_trailing_comment=qr/(?:\s+\#.*)?/;my$re_key_value_separator=qr/\s*:(?:\s+(?:\#.*)?|$)/;sub _load_file {my$class=ref $_[0]? ref shift : shift;my$file=shift or $class->_error('You did not specify a file name');$class->_error("File '$file' does not exist")unless -e $file;$class->_error("'$file' is a directory, not a file")unless -f _;$class->_error("Insufficient permissions to read '$file'")unless -r _;open(my$fh,"<:unix:encoding(UTF-8)",$file);unless ($fh){$class->_error("Failed to open file '$file': $!")}if (_can_flock()){flock($fh,Fcntl::LOCK_SH())or warn "Couldn't lock '$file' for reading: $!"}my$contents=eval {use warnings FATAL=>'utf8';local $/;<$fh>};if (my$err=$@){$class->_error("Error reading from file '$file': $err")}unless (close$fh){$class->_error("Failed to close file '$file': $!")}$class->_load_string($contents)}sub _load_string {my$class=ref $_[0]? ref shift : shift;my$self=bless [],$class;my$string=$_[0];eval {unless (defined$string){die \"Did not provide a string to load"}if (utf8::is_utf8($string)&&!utf8::valid($string)){die \<<'...'}utf8::upgrade($string);$string =~ s/^\x{FEFF}//;return$self unless length$string;my@lines=grep {!/^\s*(?:\#.*)?\z/}split /(?:\015{1,2}\012|\015|\012)/,$string;@lines and $lines[0]=~ /^\%YAML[: ][\d\.]+.*\z/ and shift@lines;my$in_document=0;while (@lines){if ($lines[0]=~ /^---\s*(?:(.+)\s*)?\z/){shift@lines;if (defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/){push @$self,$self->_load_scalar("$1",[undef ],\@lines);next}$in_document=1}if (!@lines or $lines[0]=~ /^(?:---|\.\.\.)/){push @$self,undef;while (@lines and $lines[0]!~ /^---/){shift@lines}$in_document=0}elsif (!$in_document && @$self){die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'"}elsif ($lines[0]=~ /^\s*\-(?:\s|$|-+$)/){my$document=[];push @$self,$document;$self->_load_array($document,[0 ],\@lines)}elsif ($lines[0]=~ /^(\s*)\S/){my$document={};push @$self,$document;$self->_load_hash($document,[length($1)],\@lines)}else {die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'"}}};my$err=$@;if (ref$err eq 'SCALAR'){$self->_error(${$err})}elsif ($err){$self->_error($err)}return$self}sub _unquote_single {my ($self,$string)=@_;return '' unless length$string;$string =~ s/\'\'/\'/g;return$string}sub _unquote_double {my ($self,$string)=@_;return '' unless length$string;$string =~ s/\\"/"/g;$string =~ s{\\([Nnever\\fartz0b]|x([0-9a-fA-F]{2}))} 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)"? ... {(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}}gex;return$string}sub _load_scalar {my ($self,$string,$indent,$lines)=@_;$string =~ s/\s*\z//;return undef if$string eq '~';if ($string =~ /^$re_capture_single_quoted$re_trailing_comment\z/){return$self->_unquote_single($1)}if ($string =~ /^$re_capture_double_quoted$re_trailing_comment\z/){return$self->_unquote_double($1)}if ($string =~ /^[\'\"!&]/){die \"CPAN::Meta::YAML does not support a feature in line '$string'"}return {}if$string =~ /^{}(?:\s+\#.*)?\z/;return []if$string =~ /^\[\](?:\s+\#.*)?\z/;if ($string !~ /^[>|]/){die \"CPAN::Meta::YAML found illegal characters in plain scalar: '$string'" if$string =~ /^(?:-(?:\s|$)|[\@\%\`])/ or $string =~ /:(?:\s|$)/;$string =~ s/\s+#.*\z//;return$string}die \"CPAN::Meta::YAML failed to find multi-line scalar content" unless @$lines;$lines->[0]=~ /^(\s*)/;$indent->[-1]=length("$1");if (defined$indent->[-2]and $indent->[-1]<= $indent->[-2]){die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'"}my@multiline=();while (@$lines){$lines->[0]=~ /^(\s*)/;last unless length($1)>= $indent->[-1];push@multiline,substr(shift(@$lines),length($1))}my$j=(substr($string,0,1)eq '>')? ' ' : "\n";my$t=(substr($string,1,1)eq '-')? '' : "\n";return join($j,@multiline).$t}sub _load_array {my ($self,$array,$indent,$lines)=@_;while (@$lines){if ($lines->[0]=~ /^(?:---|\.\.\.)/){while (@$lines and $lines->[0]!~ /^---/){shift @$lines}return 1}$lines->[0]=~ /^(\s*)/;if (length($1)< $indent->[-1]){return 1}elsif (length($1)> $indent->[-1]){die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'"}if ($lines->[0]=~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/){my$indent2=length("$1");$lines->[0]=~ s/-/ /;push @$array,{};$self->_load_hash($array->[-1],[@$indent,$indent2 ],$lines)}elsif ($lines->[0]=~ /^\s*\-\s*\z/){shift @$lines;unless (@$lines){push @$array,undef;return 1}if ($lines->[0]=~ /^(\s*)\-/){my$indent2=length("$1");if ($indent->[-1]==$indent2){push @$array,undef}else {push @$array,[];$self->_load_array($array->[-1],[@$indent,$indent2 ],$lines)}}elsif ($lines->[0]=~ /^(\s*)\S/){push @$array,{};$self->_load_hash($array->[-1],[@$indent,length("$1")],$lines)}else {die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'"}}elsif ($lines->[0]=~ /^\s*\-(\s*)(.+?)\s*\z/){shift @$lines;push @$array,$self->_load_scalar("$2",[@$indent,undef ],$lines)}elsif (defined$indent->[-2]and $indent->[-1]==$indent->[-2]){return 1}else {die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'"}}return 1}sub _load_hash {my ($self,$hash,$indent,$lines)=@_;while (@$lines){if ($lines->[0]=~ /^(?:---|\.\.\.)/){while (@$lines and $lines->[0]!~ /^---/){shift @$lines}return 1}$lines->[0]=~ /^(\s*)/;if (length($1)< $indent->[-1]){return 1}elsif (length($1)> $indent->[-1]){die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'"}my$key;if ($lines->[0]=~ s/^\s*$re_capture_single_quoted$re_key_value_separator//){$key=$self->_unquote_single($1)}elsif ($lines->[0]=~ s/^\s*$re_capture_double_quoted$re_key_value_separator//){$key=$self->_unquote_double($1)}elsif ($lines->[0]=~ s/^\s*$re_capture_unquoted_key$re_key_value_separator//){$key=$1;$key =~ s/\s+$//}elsif ($lines->[0]=~ /^\s*\?/){die \"CPAN::Meta::YAML does not support a feature in line '$lines->[0]'"}else {die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'"}if (exists$hash->{$key}){warn "CPAN::Meta::YAML found a duplicate key '$key' in line '$lines->[0]'"}if (length$lines->[0]){$hash->{$key}=$self->_load_scalar(shift(@$lines),[@$indent,undef ],$lines)}else {shift @$lines;unless (@$lines){$hash->{$key}=undef;return 1}if ($lines->[0]=~ /^(\s*)-/){$hash->{$key}=[];$self->_load_array($hash->{$key},[@$indent,length($1)],$lines)}elsif ($lines->[0]=~ /^(\s*)./){my$indent2=length("$1");if ($indent->[-1]>= $indent2){$hash->{$key}=undef}else {$hash->{$key}={};$self->_load_hash($hash->{$key},[@$indent,length($1)],$lines)}}}}return 1}sub _dump_file {my$self=shift;require Fcntl;my$file=shift or $self->_error('You did not specify a file name');my$fh;if (_can_flock()){my$flags=Fcntl::O_WRONLY()|Fcntl::O_CREAT();sysopen($fh,$file,$flags);unless ($fh){$self->_error("Failed to open file '$file' for writing: $!")}binmode($fh,":raw:encoding(UTF-8)");flock($fh,Fcntl::LOCK_EX())or warn "Couldn't lock '$file' for reading: $!";truncate$fh,0;seek$fh,0,0}else {open$fh,">:unix:encoding(UTF-8)",$file}print {$fh}$self->_dump_string;unless (close$fh){$self->_error("Failed to close file '$file': $!")}return 1}sub _dump_string {my$self=shift;return '' unless ref$self && @$self;my$indent=0;my@lines=();eval {for my$cursor (@$self){push@lines,'---';if (!defined$cursor){}elsif (!ref$cursor){$lines[-1].= ' ' .$self->_dump_scalar($cursor)}elsif (ref$cursor eq 'ARRAY'){unless (@$cursor){$lines[-1].= ' []';next}push@lines,$self->_dump_array($cursor,$indent,{})}elsif (ref$cursor eq 'HASH'){unless (%$cursor){$lines[-1].= ' {}';next}push@lines,$self->_dump_hash($cursor,$indent,{})}else {die \("Cannot serialize " .ref($cursor))}}};if (ref $@ eq 'SCALAR'){$self->_error(${$@})}elsif ($@){$self->_error($@)}join '',map {"$_\n"}@lines}sub _has_internal_string_value {my$value=shift;my$b_obj=B::svref_2object(\$value);return$b_obj->FLAGS & B::SVf_POK()}sub _dump_scalar {my$string=$_[1];my$is_key=$_[2];my$has_string_flag=_has_internal_string_value($string);return '~' unless defined$string;return "''" unless length$string;if (Scalar::Util::looks_like_number($string)){if ($is_key || $has_string_flag){return qq['$string']}else {return$string}}if ($string =~ /[\x00-\x09\x0b-\x0d\x0e-\x1f\x7f-\x9f\'\n]/){$string =~ s/\\/\\\\/g;$string =~ s/"/\\"/g;$string =~ s/\n/\\n/g;$string =~ s/[\x85]/\\N/g;$string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g;$string =~ s/([\x7f-\x9f])/'\x' . sprintf("%X",ord($1))/ge;return qq|"$string"|}if ($string =~ /(?:^[~!@#%&*|>?:,'"`{}\[\]]|^-+$|\s|:\z)/ or $QUOTE{$string}){return "'$string'"}return$string}sub _dump_array {my ($self,$array,$indent,$seen)=@_;if ($seen->{refaddr($array)}++){die \"CPAN::Meta::YAML does not support circular references"}my@lines=();for my$el (@$array){my$line=(' ' x $indent).'-';my$type=ref$el;if (!$type){$line .= ' ' .$self->_dump_scalar($el);push@lines,$line}elsif ($type eq 'ARRAY'){if (@$el){push@lines,$line;push@lines,$self->_dump_array($el,$indent + 1,$seen)}else {$line .= ' []';push@lines,$line}}elsif ($type eq 'HASH'){if (keys %$el){push@lines,$line;push@lines,$self->_dump_hash($el,$indent + 1,$seen)}else {$line .= ' {}';push@lines,$line}}else {die \"CPAN::Meta::YAML does not support $type references"}}@lines}sub _dump_hash {my ($self,$hash,$indent,$seen)=@_;if ($seen->{refaddr($hash)}++){die \"CPAN::Meta::YAML does not support circular references"}my@lines=();for my$name (sort keys %$hash){my$el=$hash->{$name};my$line=(' ' x $indent).$self->_dump_scalar($name,1).":";my$type=ref$el;if (!$type){$line .= ' ' .$self->_dump_scalar($el);push@lines,$line}elsif ($type eq 'ARRAY'){if (@$el){push@lines,$line;push@lines,$self->_dump_array($el,$indent + 1,$seen)}else {$line .= ' []';push@lines,$line}}elsif ($type eq 'HASH'){if (keys %$el){push@lines,$line;push@lines,$self->_dump_hash($el,$indent + 1,$seen)}else {$line .= ' {}';push@lines,$line}}else {die \"CPAN::Meta::YAML does not support $type references"}}@lines}our$errstr='';sub _error {require Carp;$errstr=$_[1];$errstr =~ s/ at \S+ line \d+.*//;Carp::croak($errstr)}my$errstr_warned;sub errstr {require Carp;Carp::carp("CPAN::Meta::YAML->errstr and \$CPAN::Meta::YAML::errstr is deprecated")unless$errstr_warned++;$errstr}use B;my$HAS_FLOCK;sub _can_flock {if (defined$HAS_FLOCK){return$HAS_FLOCK}else {require Config;my$c=\%Config::Config;$HAS_FLOCK=grep {$c->{$_}}qw/d_flock d_fcntl_can_lock d_lockf/;require Fcntl if$HAS_FLOCK;return$HAS_FLOCK}}use Scalar::Util ();BEGIN {local $@;if (eval {Scalar::Util->VERSION(1.18)}){*refaddr=*Scalar::Util::refaddr}else {eval <<'END_PERL'}}delete$CPAN::Meta::YAML::{refaddr};1; # 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 CPAN_META_YAML $fatpacked{"Exporter.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXPORTER'; package Exporter;require 5.006;our$Debug=0;our$ExportLevel=0;our$Verbose ||= 0;our$VERSION='5.70';our (%Cache);sub as_heavy {require Exporter::Heavy;my$c=(caller(1))[3];$c =~ s/.*:://;\&{"Exporter::Heavy::heavy_$c"}}sub export {goto &{as_heavy()}}sub import {my$pkg=shift;my$callpkg=caller($ExportLevel);if ($pkg eq "Exporter" and @_ and $_[0]eq "import"){*{$callpkg."::import"}=\&import;return}my$exports=\@{"$pkg\::EXPORT"};my$fail=${$pkg .'::'}{EXPORT_FAIL}&& \@{"$pkg\::EXPORT_FAIL"};return export$pkg,$callpkg,@_ if$Verbose or $Debug or $fail && @$fail > 1;my$export_cache=($Cache{$pkg}||= {});my$args=@_ or @_=@$exports;if ($args and not %$export_cache){s/^&//,$export_cache->{$_}=1 foreach (@$exports,@{"$pkg\::EXPORT_OK"})}my$heavy;if ($args or $fail){($heavy=(/\W/ or $args and not exists$export_cache->{$_}or $fail and @$fail and $_ eq $fail->[0]))and last foreach (@_)}else {($heavy=/\W/)and last foreach (@_)}return export$pkg,$callpkg,($args ? @_ : ())if$heavy;local$SIG{__WARN__}=sub {require Carp;&Carp::carp}if not $SIG{__WARN__};*{"$callpkg\::$_"}=\&{"$pkg\::$_"}foreach @_}sub export_fail {my$self=shift;@_}sub export_to_level {goto &{as_heavy()}}sub export_tags {goto &{as_heavy()}}sub export_ok_tags {goto &{as_heavy()}}sub require_version {goto &{as_heavy()}}1; EXPORTER $fatpacked{"Exporter/Heavy.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'EXPORTER_HEAVY'; package Exporter::Heavy;use strict;no strict 'refs';require Exporter;our$VERSION=$Exporter::VERSION;sub _rebuild_cache {my ($pkg,$exports,$cache)=@_;s/^&// foreach @$exports;@{$cache}{@$exports}=(1)x @$exports;my$ok=\@{"${pkg}::EXPORT_OK"};if (@$ok){s/^&// foreach @$ok;@{$cache}{@$ok}=(1)x @$ok}}sub heavy_export {my$oldwarn=$SIG{__WARN__};local$SIG{__WARN__}=sub {local$SIG{__WARN__}=$oldwarn;my$text=shift;if ($text =~ s/ at \S*Exporter\S*.pm line \d+.*\n//){require Carp;local$Carp::CarpLevel=1;Carp::carp($text)}else {warn$text}};local$SIG{__DIE__}=sub {require Carp;local$Carp::CarpLevel=1;Carp::croak("$_[0]Illegal null symbol in \@${1}::EXPORT")if $_[0]=~ /^Unable to create sub named "(.*?)::"/};my($pkg,$callpkg,@imports)=@_;my($type,$sym,$cache_is_current,$oops);my($exports,$export_cache)=(\@{"${pkg}::EXPORT"},$Exporter::Cache{$pkg}||= {});if (@imports){if (!%$export_cache){_rebuild_cache ($pkg,$exports,$export_cache);$cache_is_current=1}if (grep m{^[/!:]},@imports){my$tagsref=\%{"${pkg}::EXPORT_TAGS"};my$tagdata;my%imports;my($remove,$spec,@names,@allexports);unshift@imports,':DEFAULT' if$imports[0]=~ m/^!/;for$spec (@imports){$remove=$spec =~ s/^!//;if ($spec =~ s/^://){if ($spec eq 'DEFAULT'){@names=@$exports}elsif ($tagdata=$tagsref->{$spec}){@names=@$tagdata}else {warn qq["$spec" is not defined in %${pkg}::EXPORT_TAGS];++$oops;next}}elsif ($spec =~ m:^/(.*)/$:){my$patn=$1;@allexports=keys %$export_cache unless@allexports;@names=grep(/$patn/,@allexports)}else {@names=($spec)}warn "Import ".($remove ? "del":"add").": @names " if$Exporter::Verbose;if ($remove){for$sym (@names){delete$imports{$sym}}}else {@imports{@names}=(1)x @names}}@imports=keys%imports}my@carp;for$sym (@imports){if (!$export_cache->{$sym}){if ($sym =~ m/^\d/){$pkg->VERSION($sym);if (@imports==1){@imports=@$exports;last}if (@imports==2 and!$imports[1]){@imports=();last}}elsif ($sym !~ s/^&// ||!$export_cache->{$sym}){unless ($cache_is_current){%$export_cache=();_rebuild_cache ($pkg,$exports,$export_cache);$cache_is_current=1}if (!$export_cache->{$sym}){push@carp,qq["$sym" is not exported by the $pkg module\n];$oops++}}}}if ($oops){require Carp;Carp::croak("@{carp}Can't continue after import errors")}}else {@imports=@$exports}my($fail,$fail_cache)=(\@{"${pkg}::EXPORT_FAIL"},$Exporter::FailCache{$pkg}||= {});if (@$fail){if (!%$fail_cache){my@expanded=map {/^\w/ ? ($_,'&'.$_): $_}@$fail;warn "${pkg}::EXPORT_FAIL cached: @expanded" if$Exporter::Verbose;@{$fail_cache}{@expanded}=(1)x @expanded}my@failed;for$sym (@imports){push(@failed,$sym)if$fail_cache->{$sym}}if (@failed){@failed=$pkg->export_fail(@failed);for$sym (@failed){require Carp;Carp::carp(qq["$sym" is not implemented by the $pkg module ],"on this architecture")}if (@failed){require Carp;Carp::croak("Can't continue after import errors")}}}warn "Importing into $callpkg from $pkg: ",join(", ",sort@imports)if$Exporter::Verbose;for$sym (@imports){(*{"${callpkg}::$sym"}=\&{"${pkg}::$sym"},next)unless$sym =~ s/^(\W)//;$type=$1;no warnings 'once';*{"${callpkg}::$sym"}=$type eq '&' ? \&{"${pkg}::$sym"}: $type eq '$' ? \${"${pkg}::$sym"}: $type eq '@' ? \@{"${pkg}::$sym"}: $type eq '%' ? \%{"${pkg}::$sym"}: $type eq '*' ? *{"${pkg}::$sym"}: do {require Carp;Carp::croak("Can't export symbol: $type$sym")}}}sub heavy_export_to_level {my$pkg=shift;my$level=shift;(undef)=shift;my$callpkg=caller($level);$pkg->export($callpkg,@_)}sub _push_tags {my($pkg,$var,$syms)=@_;my@nontag=();my$export_tags=\%{"${pkg}::EXPORT_TAGS"};push(@{"${pkg}::$var"},map {$export_tags->{$_}? @{$export_tags->{$_}}: scalar(push(@nontag,$_),$_)}(@$syms)? @$syms : keys %$export_tags);if (@nontag and $^W){require Carp;Carp::carp(join(", ",@nontag)." are not tags of $pkg")}}sub heavy_require_version {my($self,$wanted)=@_;my$pkg=ref$self || $self;return ${pkg}->VERSION($wanted)}sub heavy_export_tags {_push_tags((caller)[0],"EXPORT",\@_)}sub heavy_export_ok_tags {_push_tags((caller)[0],"EXPORT_OK",\@_)}1; EXPORTER_HEAVY $fatpacked{"File/pushd.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'FILE_PUSHD'; use strict;use warnings;package File::pushd;our$VERSION='1.009';our@EXPORT=qw(pushd tempd);our@ISA=qw(Exporter);use Exporter;use Carp;use Cwd qw(getcwd abs_path);use File::Path qw(rmtree);use File::Temp qw();use File::Spec;use overload q{""}=>sub {File::Spec->canonpath($_[0]->{_pushd})},fallback=>1;sub pushd {my ($target_dir,$options)=@_;$options->{untaint_pattern}||= qr{^([-+@\w./]+)$};$target_dir="." unless defined$target_dir;croak "Can't locate directory $target_dir" unless -d $target_dir;my$tainted_orig=getcwd;my$orig;if ($tainted_orig =~ $options->{untaint_pattern}){$orig=$1}else {$orig=$tainted_orig}my$tainted_dest;eval {$tainted_dest=$target_dir ? abs_path($target_dir): $orig};croak "Can't locate absolute path for $target_dir: $@" if $@;my$dest;if ($tainted_dest =~ $options->{untaint_pattern}){$dest=$1}else {$dest=$tainted_dest}if ($dest ne $orig){chdir$dest or croak "Can't chdir to $dest\: $!"}my$self=bless {_pushd=>$dest,_original=>$orig },__PACKAGE__;return$self}sub tempd {my ($options)=@_;my$dir;eval {$dir=pushd(File::Temp::tempdir(CLEANUP=>0),$options)};croak $@ if $@;$dir->{_tempd}=1;return$dir}sub preserve {my$self=shift;return 1 if!$self->{"_tempd"};if (@_==0){return$self->{_preserve}=1}else {return$self->{_preserve}=$_[0]? 1 : 0}}sub DESTROY {my ($self)=@_;my$orig=$self->{_original};chdir$orig if$orig;if ($self->{_tempd}&&!$self->{_preserve}){my$err=do {local $@;eval {rmtree($self->{_pushd})};$@};carp$err if$err}}1; FILE_PUSHD $fatpacked{"HTTP/Tiny.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'HTTP_TINY'; package HTTP::Tiny;use strict;use warnings;our$VERSION='0.056';use Carp ();my@attributes;BEGIN {@attributes=qw(cookie_jar default_headers http_proxy https_proxy keep_alive local_address max_redirect max_size proxy no_proxy timeout SSL_options verify_SSL);my%persist_ok=map {;$_=>1}qw(cookie_jar default_headers max_redirect max_size);no strict 'refs';no warnings 'uninitialized';for my$accessor (@attributes){*{$accessor}=sub {@_ > 1 ? do {delete $_[0]->{handle}if!$persist_ok{$accessor}&& $_[1]ne $_[0]->{$accessor};$_[0]->{$accessor}=$_[1]}: $_[0]->{$accessor}}}}sub agent {my($self,$agent)=@_;if(@_ > 1){$self->{agent}=(defined$agent && $agent =~ / $/)? $agent .$self->_agent : $agent}return$self->{agent}}sub new {my($class,%args)=@_;my$self={max_redirect=>5,timeout=>60,keep_alive=>1,verify_SSL=>$args{verify_SSL}|| $args{verify_ssl}|| 0,no_proxy=>$ENV{no_proxy},};bless$self,$class;$class->_validate_cookie_jar($args{cookie_jar})if$args{cookie_jar};for my$key (@attributes){$self->{$key}=$args{$key}if exists$args{$key}}$self->agent(exists$args{agent}? $args{agent}: $class->_agent);$self->_set_proxies;return$self}sub _set_proxies {my ($self)=@_;if (!exists$self->{proxy}){$self->{proxy}=$ENV{all_proxy}|| $ENV{ALL_PROXY}}if (defined$self->{proxy}){$self->_split_proxy('generic proxy'=>$self->{proxy})}else {delete$self->{proxy}}if (!exists$self->{http_proxy}){local$ENV{HTTP_PROXY}if$ENV{REQUEST_METHOD};$self->{http_proxy}=$ENV{http_proxy}|| $ENV{HTTP_PROXY}|| $self->{proxy}}if (defined$self->{http_proxy}){$self->_split_proxy(http_proxy=>$self->{http_proxy});$self->{_has_proxy}{http}=1}else {delete$self->{http_proxy}}if (!exists$self->{https_proxy}){$self->{https_proxy}=$ENV{https_proxy}|| $ENV{HTTPS_PROXY}|| $self->{proxy}}if ($self->{https_proxy}){$self->_split_proxy(https_proxy=>$self->{https_proxy});$self->{_has_proxy}{https}=1}else {delete$self->{https_proxy}}unless (ref$self->{no_proxy}eq 'ARRAY'){$self->{no_proxy}=(defined$self->{no_proxy})? [split /\s*,\s*/,$self->{no_proxy}]: []}return}for my$sub_name (qw/get head put post delete/){my$req_method=uc$sub_name;no strict 'refs';eval <<"HERE"}sub post_form {my ($self,$url,$data,$args)=@_;(@_==3 || @_==4 && ref$args eq 'HASH')or Carp::croak(q/Usage: $http->post_form(URL, DATAREF, [HASHREF])/ ."\n");my$headers={};while (my ($key,$value)=each %{$args->{headers}|| {}}){$headers->{lc$key}=$value}delete$args->{headers};return$self->request('POST',$url,{%$args,content=>$self->www_form_urlencode($data),headers=>{%$headers,'content-type'=>'application/x-www-form-urlencoded' },})}sub mirror {my ($self,$url,$file,$args)=@_;@_==3 || (@_==4 && ref$args eq 'HASH')or Carp::croak(q/Usage: $http->mirror(URL, FILE, [HASHREF])/ ."\n");if (-e $file and my$mtime=(stat($file))[9]){$args->{headers}{'if-modified-since'}||= $self->_http_date($mtime)}my$tempfile=$file .int(rand(2**31));require Fcntl;sysopen my$fh,$tempfile,Fcntl::O_CREAT()|Fcntl::O_EXCL()|Fcntl::O_WRONLY()or Carp::croak(qq/Error: Could not create temporary file $tempfile for downloading: $!\n/);binmode$fh;$args->{data_callback}=sub {print {$fh}$_[0]};my$response=$self->request('GET',$url,$args);close$fh or Carp::croak(qq/Error: Caught error closing temporary file $tempfile: $!\n/);if ($response->{success}){rename$tempfile,$file or Carp::croak(qq/Error replacing $file with $tempfile: $!\n/);my$lm=$response->{headers}{'last-modified'};if ($lm and my$mtime=$self->_parse_http_date($lm)){utime$mtime,$mtime,$file}}$response->{success}||= $response->{status}eq '304';unlink$tempfile;return$response}my%idempotent=map {$_=>1}qw/GET HEAD PUT DELETE OPTIONS TRACE/;sub request {my ($self,$method,$url,$args)=@_;@_==3 || (@_==4 && ref$args eq 'HASH')or Carp::croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/ ."\n");$args ||= {};my$response;for (0 .. 1){$response=eval {$self->_request($method,$url,$args)};last unless $@ && $idempotent{$method}&& $@ =~ m{^(?:Socket closed|Unexpected end)}}if (my$e=$@){if (ref$e eq 'HASH' && exists$e->{status}){return$e}$e="$e";$response={url=>$url,success=>q{},status=>599,reason=>'Internal Exception',content=>$e,headers=>{'content-type'=>'text/plain','content-length'=>length$e,}}}return$response}sub www_form_urlencode {my ($self,$data)=@_;(@_==2 && ref$data)or Carp::croak(q/Usage: $http->www_form_urlencode(DATAREF)/ ."\n");(ref$data eq 'HASH' || ref$data eq 'ARRAY')or Carp::croak("form data must be a hash or array reference\n");my@params=ref$data eq 'HASH' ? %$data : @$data;@params % 2==0 or Carp::croak("form data reference must have an even number of terms\n");my@terms;while(@params){my ($key,$value)=splice(@params,0,2);if (ref$value eq 'ARRAY'){unshift@params,map {$key=>$_}@$value}else {push@terms,join("=",map {$self->_uri_escape($_)}$key,$value)}}return join("&",(ref$data eq 'ARRAY')? (@terms): (sort@terms))}sub can_ssl {my ($self)=@_;my($ok,$reason)=(1,'');unless (eval {require IO::Socket::SSL;IO::Socket::SSL->VERSION(1.42)}){$ok=0;$reason .= qq/IO::Socket::SSL 1.42 must be installed for https support\n/}unless (eval {require Net::SSLeay;Net::SSLeay->VERSION(1.49)}){$ok=0;$reason .= qq/Net::SSLeay 1.49 must be installed for https support\n/}if (ref($self)&& ($self->{verify_SSL}|| $self->{SSL_options}{SSL_verify_mode})){my$handle=HTTP::Tiny::Handle->new(SSL_options=>$self->{SSL_options},verify_SSL=>$self->{verify_SSL},);unless (eval {$handle->_find_CA_file;1}){$ok=0;$reason .= "$@"}}wantarray ? ($ok,$reason): $ok}my%DefaultPort=(http=>80,https=>443,);sub _agent {my$class=ref($_[0])|| $_[0];(my$default_agent=$class)=~ s{::}{-}g;return$default_agent ."/" .$class->VERSION}sub _request {my ($self,$method,$url,$args)=@_;my ($scheme,$host,$port,$path_query,$auth)=$self->_split_url($url);my$request={method=>$method,scheme=>$scheme,host=>$host,port=>$port,host_port=>($port==$DefaultPort{$scheme}? $host : "$host:$port"),uri=>$path_query,headers=>{},};my$handle=delete$self->{handle};if ($handle){unless ($handle->can_reuse($scheme,$host,$port)){$handle->close;undef$handle}}$handle ||= $self->_open_handle($request,$scheme,$host,$port);$self->_prepare_headers_and_cb($request,$args,$url,$auth);$handle->write_request($request);my$response;do {$response=$handle->read_response_header}until (substr($response->{status},0,1)ne '1');$self->_update_cookie_jar($url,$response)if$self->{cookie_jar};if (my@redir_args=$self->_maybe_redirect($request,$response,$args)){$handle->close;return$self->_request(@redir_args,$args)}my$known_message_length;if ($method eq 'HEAD' || $response->{status}=~ /^[23]04/){$known_message_length=1}else {my$data_cb=$self->_prepare_data_cb($response,$args);$known_message_length=$handle->read_body($data_cb,$response)}if ($self->{keep_alive}&& $known_message_length && $response->{protocol}eq 'HTTP/1.1' && ($response->{headers}{connection}|| '')ne 'close'){$self->{handle}=$handle}else {$handle->close}$response->{success}=substr($response->{status},0,1)eq '2';$response->{url}=$url;return$response}sub _open_handle {my ($self,$request,$scheme,$host,$port)=@_;my$handle=HTTP::Tiny::Handle->new(timeout=>$self->{timeout},SSL_options=>$self->{SSL_options},verify_SSL=>$self->{verify_SSL},local_address=>$self->{local_address},keep_alive=>$self->{keep_alive});if ($self->{_has_proxy}{$scheme}&&!grep {$host =~ /\Q$_\E$/}@{$self->{no_proxy}}){return$self->_proxy_connect($request,$handle)}else {return$handle->connect($scheme,$host,$port)}}sub _proxy_connect {my ($self,$request,$handle)=@_;my@proxy_vars;if ($request->{scheme}eq 'https'){Carp::croak(qq{No https_proxy defined})unless$self->{https_proxy};@proxy_vars=$self->_split_proxy(https_proxy=>$self->{https_proxy});if ($proxy_vars[0]eq 'https'){Carp::croak(qq{Can't proxy https over https: $request->{uri} via $self->{https_proxy}})}}else {Carp::croak(qq{No http_proxy defined})unless$self->{http_proxy};@proxy_vars=$self->_split_proxy(http_proxy=>$self->{http_proxy})}my ($p_scheme,$p_host,$p_port,$p_auth)=@proxy_vars;if (length$p_auth &&!defined$request->{headers}{'proxy-authorization'}){$self->_add_basic_auth_header($request,'proxy-authorization'=>$p_auth)}$handle->connect($p_scheme,$p_host,$p_port);if ($request->{scheme}eq 'https'){$self->_create_proxy_tunnel($request,$handle)}else {$request->{uri}="$request->{scheme}://$request->{host_port}$request->{uri}"}return$handle}sub _split_proxy {my ($self,$type,$proxy)=@_;my ($scheme,$host,$port,$path_query,$auth)=eval {$self->_split_url($proxy)};unless(defined($scheme)&& length($scheme)&& length($host)&& length($port)&& $path_query eq '/'){Carp::croak(qq{$type URL must be in format http[s]://[auth@]<host>:<port>/\n})}return ($scheme,$host,$port,$auth)}sub _create_proxy_tunnel {my ($self,$request,$handle)=@_;$handle->_assert_ssl;my$agent=exists($request->{headers}{'user-agent'})? $request->{headers}{'user-agent'}: $self->{agent};my$connect_request={method=>'CONNECT',uri=>"$request->{host}:$request->{port}",headers=>{host=>"$request->{host}:$request->{port}",'user-agent'=>$agent,}};if ($request->{headers}{'proxy-authorization'}){$connect_request->{headers}{'proxy-authorization'}=delete$request->{headers}{'proxy-authorization'}}$handle->write_request($connect_request);my$response;do {$response=$handle->read_response_header}until (substr($response->{status},0,1)ne '1');unless (substr($response->{status},0,1)eq '2'){die$response}$handle->start_ssl($request->{host});return}sub _prepare_headers_and_cb {my ($self,$request,$args,$url,$auth)=@_;for ($self->{default_headers},$args->{headers}){next unless defined;while (my ($k,$v)=each %$_){$request->{headers}{lc$k}=$v}}if (exists$request->{headers}{'host'}){die(qq/The 'Host' header must not be provided as header option\n/)}$request->{headers}{'host'}=$request->{host_port};$request->{headers}{'user-agent'}||= $self->{agent};$request->{headers}{'connection'}="close" unless$self->{keep_alive};if (defined$args->{content}){if (ref$args->{content}eq 'CODE'){$request->{headers}{'content-type'}||= "application/octet-stream";$request->{headers}{'transfer-encoding'}='chunked' unless$request->{headers}{'content-length'}|| $request->{headers}{'transfer-encoding'};$request->{cb}=$args->{content}}elsif (length$args->{content}){my$content=$args->{content};if ($] ge '5.008'){utf8::downgrade($content,1)or die(qq/Wide character in request message body\n/)}$request->{headers}{'content-type'}||= "application/octet-stream";$request->{headers}{'content-length'}=length$content unless$request->{headers}{'content-length'}|| $request->{headers}{'transfer-encoding'};$request->{cb}=sub {substr$content,0,length$content,''}}$request->{trailer_cb}=$args->{trailer_callback}if ref$args->{trailer_callback}eq 'CODE'}if ($self->{cookie_jar}){my$cookies=$self->cookie_jar->cookie_header($url);$request->{headers}{cookie}=$cookies if length$cookies}if (length$auth &&!defined$request->{headers}{authorization}){$self->_add_basic_auth_header($request,'authorization'=>$auth)}return}sub _add_basic_auth_header {my ($self,$request,$header,$auth)=@_;require MIME::Base64;$request->{headers}{$header}="Basic " .MIME::Base64::encode_base64($auth,"");return}sub _prepare_data_cb {my ($self,$response,$args)=@_;my$data_cb=$args->{data_callback};$response->{content}='';if (!$data_cb || $response->{status}!~ /^2/){if (defined$self->{max_size}){$data_cb=sub {$_[1]->{content}.= $_[0];die(qq/Size of response body exceeds the maximum allowed of $self->{max_size}\n/)if length $_[1]->{content}> $self->{max_size}}}else {$data_cb=sub {$_[1]->{content}.= $_[0]}}}return$data_cb}sub _update_cookie_jar {my ($self,$url,$response)=@_;my$cookies=$response->{headers}->{'set-cookie'};return unless defined$cookies;my@cookies=ref$cookies ? @$cookies : $cookies;$self->cookie_jar->add($url,$_)for@cookies;return}sub _validate_cookie_jar {my ($class,$jar)=@_;for my$method (qw/add cookie_header/){Carp::croak(qq/Cookie jar must provide the '$method' method\n/)unless ref($jar)&& ref($jar)->can($method)}return}sub _maybe_redirect {my ($self,$request,$response,$args)=@_;my$headers=$response->{headers};my ($status,$method)=($response->{status},$request->{method});if (($status eq '303' or ($status =~ /^30[1278]/ && $method =~ /^GET|HEAD$/))and $headers->{location}and ++$args->{redirects}<= $self->{max_redirect}){my$location=($headers->{location}=~ /^\//)? "$request->{scheme}://$request->{host_port}$headers->{location}" : $headers->{location};return (($status eq '303' ? 'GET' : $method),$location)}return}sub _split_url {my$url=pop;my ($scheme,$host,$path_query)=$url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)> or die(qq/Cannot parse URL: '$url'\n/);$scheme=lc$scheme;$path_query="/$path_query" unless$path_query =~ m<\A/>;my$auth='';if ((my$i=index$host,'@')!=-1){$auth=substr$host,0,$i,'';substr$host,0,1,'';$auth =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg}my$port=$host =~ s/:(\d*)\z// && length $1 ? $1 : $scheme eq 'http' ? 80 : $scheme eq 'https' ? 443 : undef;return ($scheme,(length$host ? lc$host : "localhost"),$port,$path_query,$auth)}my$DoW="Sun|Mon|Tue|Wed|Thu|Fri|Sat";my$MoY="Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec";sub _http_date {my ($sec,$min,$hour,$mday,$mon,$year,$wday)=gmtime($_[1]);return sprintf("%s, %02d %s %04d %02d:%02d:%02d GMT",substr($DoW,$wday*4,3),$mday,substr($MoY,$mon*4,3),$year+1900,$hour,$min,$sec)}sub _parse_http_date {my ($self,$str)=@_;require Time::Local;my@tl_parts;if ($str =~ /^[SMTWF][a-z]+, +(\d{1,2}) ($MoY) +(\d\d\d\d) +(\d\d):(\d\d):(\d\d) +GMT$/){@tl_parts=($6,$5,$4,$1,(index($MoY,$2)/4),$3)}elsif ($str =~ /^[SMTWF][a-z]+, +(\d\d)-($MoY)-(\d{2,4}) +(\d\d):(\d\d):(\d\d) +GMT$/){@tl_parts=($6,$5,$4,$1,(index($MoY,$2)/4),$3)}elsif ($str =~ /^[SMTWF][a-z]+ +($MoY) +(\d{1,2}) +(\d\d):(\d\d):(\d\d) +(?:[^0-9]+ +)?(\d\d\d\d)$/){@tl_parts=($5,$4,$3,$2,(index($MoY,$1)/4),$6)}return eval {my$t=@tl_parts ? Time::Local::timegm(@tl_parts): -1;$t < 0 ? undef : $t}}my%escapes=map {chr($_)=>sprintf("%%%02X",$_)}0..255;$escapes{' '}="+";my$unsafe_char=qr/[^A-Za-z0-9\-\._~]/;sub _uri_escape {my ($self,$str)=@_;if ($] ge '5.008'){utf8::encode($str)}else {$str=pack("U*",unpack("C*",$str))if (length$str==do {use bytes;length$str});$str=pack("C*",unpack("C*",$str))}$str =~ s/($unsafe_char)/$escapes{$1}/ge;return$str}package HTTP::Tiny::Handle;use strict;use warnings;use Errno qw[EINTR EPIPE];use IO::Socket qw[SOCK_STREAM];my$SOCKET_CLASS=$ENV{PERL_HTTP_TINY_IPV4_ONLY}? 'IO::Socket::INET' : eval {require IO::Socket::IP;IO::Socket::IP->VERSION(0.25)}? 'IO::Socket::IP' : 'IO::Socket::INET';sub BUFSIZE () {32768}my$Printable=sub {local $_=shift;s/\r/\\r/g;s/\n/\\n/g;s/\t/\\t/g;s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;$_};my$Token=qr/[\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]/;sub new {my ($class,%args)=@_;return bless {rbuf=>'',timeout=>60,max_line_size=>16384,max_header_lines=>64,verify_SSL=>0,SSL_options=>{},%args },$class}sub connect {@_==4 || die(q/Usage: $handle->connect(scheme, host, port)/ ."\n");my ($self,$scheme,$host,$port)=@_;if ($scheme eq 'https'){$self->_assert_ssl}elsif ($scheme ne 'http'){die(qq/Unsupported URL scheme '$scheme'\n/)}$self->{fh}=$SOCKET_CLASS->new(PeerHost=>$host,PeerPort=>$port,$self->{local_address}? (LocalAddr=>$self->{local_address}): (),Proto=>'tcp',Type=>SOCK_STREAM,Timeout=>$self->{timeout},KeepAlive=>!!$self->{keep_alive})or die(qq/Could not connect to '$host:$port': $@\n/);binmode($self->{fh})or die(qq/Could not binmode() socket: '$!'\n/);$self->start_ssl($host)if$scheme eq 'https';$self->{scheme}=$scheme;$self->{host}=$host;$self->{port}=$port;$self->{pid}=$$;$self->{tid}=_get_tid();return$self}sub start_ssl {my ($self,$host)=@_;if (ref($self->{fh})eq 'IO::Socket::SSL'){unless ($self->{fh}->stop_SSL){my$ssl_err=IO::Socket::SSL->errstr;die(qq/Error halting prior SSL connection: $ssl_err/)}}my$ssl_args=$self->_ssl_args($host);IO::Socket::SSL->start_SSL($self->{fh},%$ssl_args,SSL_create_ctx_callback=>sub {my$ctx=shift;Net::SSLeay::CTX_set_mode($ctx,Net::SSLeay::MODE_AUTO_RETRY())},);unless (ref($self->{fh})eq 'IO::Socket::SSL'){my$ssl_err=IO::Socket::SSL->errstr;die(qq/SSL connection failed for $host: $ssl_err\n/)}}sub close {@_==1 || die(q/Usage: $handle->close()/ ."\n");my ($self)=@_;CORE::close($self->{fh})or die(qq/Could not close socket: '$!'\n/)}sub write {@_==2 || die(q/Usage: $handle->write(buf)/ ."\n");my ($self,$buf)=@_;if ($] ge '5.008'){utf8::downgrade($buf,1)or die(qq/Wide character in write()\n/)}my$len=length$buf;my$off=0;local$SIG{PIPE}='IGNORE';while (){$self->can_write or die(qq/Timed out while waiting for socket to become ready for writing\n/);my$r=syswrite($self->{fh},$buf,$len,$off);if (defined$r){$len -= $r;$off += $r;last unless$len > 0}elsif ($!==EPIPE){die(qq/Socket closed by remote server: $!\n/)}elsif ($!!=EINTR){if ($self->{fh}->can('errstr')){my$err=$self->{fh}->errstr();die (qq/Could not write to SSL socket: '$err'\n /)}else {die(qq/Could not write to socket: '$!'\n/)}}}return$off}sub read {@_==2 || @_==3 || die(q/Usage: $handle->read(len [, allow_partial])/ ."\n");my ($self,$len,$allow_partial)=@_;my$buf='';my$got=length$self->{rbuf};if ($got){my$take=($got < $len)? $got : $len;$buf=substr($self->{rbuf},0,$take,'');$len -= $take}while ($len > 0){$self->can_read or die(q/Timed out while waiting for socket to become ready for reading/ ."\n");my$r=sysread($self->{fh},$buf,$len,length$buf);if (defined$r){last unless$r;$len -= $r}elsif ($!!=EINTR){if ($self->{fh}->can('errstr')){my$err=$self->{fh}->errstr();die (qq/Could not read from SSL socket: '$err'\n /)}else {die(qq/Could not read from socket: '$!'\n/)}}}if ($len &&!$allow_partial){die(qq/Unexpected end of stream\n/)}return$buf}sub readline {@_==1 || die(q/Usage: $handle->readline()/ ."\n");my ($self)=@_;while (){if ($self->{rbuf}=~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x){return $1}if (length$self->{rbuf}>= $self->{max_line_size}){die(qq/Line size exceeds the maximum allowed size of $self->{max_line_size}\n/)}$self->can_read or die(qq/Timed out while waiting for socket to become ready for reading\n/);my$r=sysread($self->{fh},$self->{rbuf},BUFSIZE,length$self->{rbuf});if (defined$r){last unless$r}elsif ($!!=EINTR){if ($self->{fh}->can('errstr')){my$err=$self->{fh}->errstr();die (qq/Could not read from SSL socket: '$err'\n /)}else {die(qq/Could not read from socket: '$!'\n/)}}}die(qq/Unexpected end of stream while looking for line\n/)}sub read_header_lines {@_==1 || @_==2 || die(q/Usage: $handle->read_header_lines([headers])/ ."\n");my ($self,$headers)=@_;$headers ||= {};my$lines=0;my$val;while (){my$line=$self->readline;if (++$lines >= $self->{max_header_lines}){die(qq/Header lines exceeds maximum number allowed of $self->{max_header_lines}\n/)}elsif ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x){my ($field_name)=lc $1;if (exists$headers->{$field_name}){for ($headers->{$field_name}){$_=[$_]unless ref $_ eq "ARRAY";push @$_,$2;$val=\$_->[-1]}}else {$val=\($headers->{$field_name}=$2)}}elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x){$val or die(qq/Unexpected header continuation line\n/);next unless length $1;$$val .= ' ' if length $$val;$$val .= $1}elsif ($line =~ /\A \x0D?\x0A \z/x){last}else {die(q/Malformed header line: / .$Printable->($line)."\n")}}return$headers}sub write_request {@_==2 || die(q/Usage: $handle->write_request(request)/ ."\n");my($self,$request)=@_;$self->write_request_header(@{$request}{qw/method uri headers/});$self->write_body($request)if$request->{cb};return}my%HeaderCase=('content-md5'=>'Content-MD5','etag'=>'ETag','te'=>'TE','www-authenticate'=>'WWW-Authenticate','x-xss-protection'=>'X-XSS-Protection',);sub write_header_lines {(@_==2 || @_==3 && ref $_[1]eq 'HASH')|| die(q/Usage: $handle->write_header_lines(headers[,prefix])/ ."\n");my($self,$headers,$prefix_data)=@_;my$buf=(defined$prefix_data ? $prefix_data : '');while (my ($k,$v)=each %$headers){my$field_name=lc$k;if (exists$HeaderCase{$field_name}){$field_name=$HeaderCase{$field_name}}else {$field_name =~ /\A $Token+ \z/xo or die(q/Invalid HTTP header field name: / .$Printable->($field_name)."\n");$field_name =~ s/\b(\w)/\u$1/g;$HeaderCase{lc$field_name}=$field_name}for (ref$v eq 'ARRAY' ? @$v : $v){$_='' unless defined $_;$buf .= "$field_name: $_\x0D\x0A"}}$buf .= "\x0D\x0A";return$self->write($buf)}sub read_body {@_==3 || die(q/Usage: $handle->read_body(callback, response)/ ."\n");my ($self,$cb,$response)=@_;my$te=$response->{headers}{'transfer-encoding'}|| '';my$chunked=grep {/chunked/i}(ref$te eq 'ARRAY' ? @$te : $te);return$chunked ? $self->read_chunked_body($cb,$response): $self->read_content_body($cb,$response)}sub write_body {@_==2 || die(q/Usage: $handle->write_body(request)/ ."\n");my ($self,$request)=@_;if ($request->{headers}{'content-length'}){return$self->write_content_body($request)}else {return$self->write_chunked_body($request)}}sub read_content_body {@_==3 || @_==4 || die(q/Usage: $handle->read_content_body(callback, response, [read_length])/ ."\n");my ($self,$cb,$response,$content_length)=@_;$content_length ||= $response->{headers}{'content-length'};if (defined$content_length){my$len=$content_length;while ($len > 0){my$read=($len > BUFSIZE)? BUFSIZE : $len;$cb->($self->read($read,0),$response);$len -= $read}return length($self->{rbuf})==0}my$chunk;$cb->($chunk,$response)while length($chunk=$self->read(BUFSIZE,1));return}sub write_content_body {@_==2 || die(q/Usage: $handle->write_content_body(request)/ ."\n");my ($self,$request)=@_;my ($len,$content_length)=(0,$request->{headers}{'content-length'});while (){my$data=$request->{cb}->();defined$data && length$data or last;if ($] ge '5.008'){utf8::downgrade($data,1)or die(qq/Wide character in write_content()\n/)}$len += $self->write($data)}$len==$content_length or die(qq/Content-Length mismatch (got: $len expected: $content_length)\n/);return$len}sub read_chunked_body {@_==3 || die(q/Usage: $handle->read_chunked_body(callback, $response)/ ."\n");my ($self,$cb,$response)=@_;while (){my$head=$self->readline;$head =~ /\A ([A-Fa-f0-9]+)/x or die(q/Malformed chunk head: / .$Printable->($head)."\n");my$len=hex($1)or last;$self->read_content_body($cb,$response,$len);$self->read(2)eq "\x0D\x0A" or die(qq/Malformed chunk: missing CRLF after chunk data\n/)}$self->read_header_lines($response->{headers});return 1}sub write_chunked_body {@_==2 || die(q/Usage: $handle->write_chunked_body(request)/ ."\n");my ($self,$request)=@_;my$len=0;while (){my$data=$request->{cb}->();defined$data && length$data or last;if ($] ge '5.008'){utf8::downgrade($data,1)or die(qq/Wide character in write_chunked_body()\n/)}$len += length$data;my$chunk=sprintf '%X',length$data;$chunk .= "\x0D\x0A";$chunk .= $data;$chunk .= "\x0D\x0A";$self->write($chunk)}$self->write("0\x0D\x0A");$self->write_header_lines($request->{trailer_cb}->())if ref$request->{trailer_cb}eq 'CODE';return$len}sub read_response_header {@_==1 || die(q/Usage: $handle->read_response_header()/ ."\n");my ($self)=@_;my$line=$self->readline;$line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x or die(q/Malformed Status-Line: / .$Printable->($line)."\n");my ($protocol,$version,$status,$reason)=($1,$2,$3,$4);die (qq/Unsupported HTTP protocol: $protocol\n/)unless$version =~ /0*1\.0*[01]/;return {status=>$status,reason=>$reason,headers=>$self->read_header_lines,protocol=>$protocol,}}sub write_request_header {@_==4 || die(q/Usage: $handle->write_request_header(method, request_uri, headers)/ ."\n");my ($self,$method,$request_uri,$headers)=@_;return$self->write_header_lines($headers,"$method $request_uri HTTP/1.1\x0D\x0A")}sub _do_timeout {my ($self,$type,$timeout)=@_;$timeout=$self->{timeout}unless defined$timeout && $timeout >= 0;my$fd=fileno$self->{fh};defined$fd && $fd >= 0 or die(qq/select(2): 'Bad file descriptor'\n/);my$initial=time;my$pending=$timeout;my$nfound;vec(my$fdset='',$fd,1)=1;while (){$nfound=($type eq 'read')? select($fdset,undef,undef,$pending): select(undef,$fdset,undef,$pending);if ($nfound==-1){$!==EINTR or die(qq/select(2): '$!'\n/);redo if!$timeout || ($pending=$timeout - (time - $initial))> 0;$nfound=0}last}$!=0;return$nfound}sub can_read {@_==1 || @_==2 || die(q/Usage: $handle->can_read([timeout])/ ."\n");my$self=shift;if (ref($self->{fh})eq 'IO::Socket::SSL'){return 1 if$self->{fh}->pending}return$self->_do_timeout('read',@_)}sub can_write {@_==1 || @_==2 || die(q/Usage: $handle->can_write([timeout])/ ."\n");my$self=shift;return$self->_do_timeout('write',@_)}sub _assert_ssl {my($ok,$reason)=HTTP::Tiny->can_ssl();die$reason unless$ok}sub can_reuse {my ($self,$scheme,$host,$port)=@_;return 0 if $self->{pid}!=$$ || $self->{tid}!=_get_tid()|| length($self->{rbuf})|| $scheme ne $self->{scheme}|| $host ne $self->{host}|| $port ne $self->{port}|| eval {$self->can_read(0)}|| $@ ;return 1}sub _find_CA_file {my$self=shift();if ($self->{SSL_options}->{SSL_ca_file}){unless (-r $self->{SSL_options}->{SSL_ca_file}){die qq/SSL_ca_file '$self->{SSL_options}->{SSL_ca_file}' not found or not readable\n/}return$self->{SSL_options}->{SSL_ca_file}}return Mozilla::CA::SSL_ca_file()if eval {require Mozilla::CA;1};for my$ca_bundle ("/etc/ssl/certs/ca-certificates.crt","/etc/pki/tls/certs/ca-bundle.crt","/etc/ssl/ca-bundle.pem","/etc/openssl/certs/ca-certificates.crt","/etc/ssl/cert.pem","/usr/local/share/certs/ca-root-nss.crt","/etc/pki/tls/cacert.pem","/etc/certs/ca-certificates.crt",){return$ca_bundle if -e $ca_bundle}die qq/Couldn't find a CA bundle with which to verify the SSL certificate.\n/ .qq/Try installing Mozilla::CA from CPAN\n/}sub _get_tid {no warnings 'reserved';return threads->can("tid")? threads->tid : 0}sub _ssl_args {my ($self,$host)=@_;my%ssl_args;if (Net::SSLeay::OPENSSL_VERSION_NUMBER()>= 0x01000000){$ssl_args{SSL_hostname}=$host,}if ($self->{verify_SSL}){$ssl_args{SSL_verifycn_scheme}='http';$ssl_args{SSL_verifycn_name}=$host;$ssl_args{SSL_verify_mode}=0x01;$ssl_args{SSL_ca_file}=$self->_find_CA_file}else {$ssl_args{SSL_verifycn_scheme}='none';$ssl_args{SSL_verify_mode}=0x00}for my$k (keys %{$self->{SSL_options}}){$ssl_args{$k}=$self->{SSL_options}{$k}if$k =~ m/^SSL_/}return \%ssl_args}1; 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 HTTP_TINY $fatpacked{"JSON/PP.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP'; package JSON::PP;use 5.005;use strict;use base qw(Exporter);use overload ();use Carp ();use B ();$JSON::PP::VERSION='2.27300';@JSON::PP::EXPORT=qw(encode_json decode_json from_json to_json);use constant P_ASCII=>0;use constant P_LATIN1=>1;use constant P_UTF8=>2;use constant P_INDENT=>3;use constant P_CANONICAL=>4;use constant P_SPACE_BEFORE=>5;use constant P_SPACE_AFTER=>6;use constant P_ALLOW_NONREF=>7;use constant P_SHRINK=>8;use constant P_ALLOW_BLESSED=>9;use constant P_CONVERT_BLESSED=>10;use constant P_RELAXED=>11;use constant P_LOOSE=>12;use constant P_ALLOW_BIGNUM=>13;use constant P_ALLOW_BAREKEY=>14;use constant P_ALLOW_SINGLEQUOTE=>15;use constant P_ESCAPE_SLASH=>16;use constant P_AS_NONBLESSED=>17;use constant P_ALLOW_UNKNOWN=>18;use constant OLD_PERL=>$] < 5.008 ? 1 : 0;BEGIN {my@xs_compati_bit_properties=qw(latin1 ascii utf8 indent canonical space_before space_after allow_nonref shrink allow_blessed convert_blessed relaxed allow_unknown);my@pp_bit_properties=qw(allow_singlequote allow_bignum loose allow_barekey escape_slash as_nonblessed);if ($] < 5.008){my$helper=$] >= 5.006 ? 'JSON::PP::Compat5006' : 'JSON::PP::Compat5005';eval qq| require $helper |;if ($@){Carp::croak $@}}for my$name (@xs_compati_bit_properties,@pp_bit_properties){my$flag_name='P_' .uc($name);eval qq/ 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 : ''; } /}}my%encode_allow_method =map {($_=>1)}qw/utf8 pretty allow_nonref latin1 self_encode escape_slash allow_blessed convert_blessed indent indent_length allow_bignum as_nonblessed/;my%decode_allow_method =map {($_=>1)}qw/utf8 allow_nonref loose allow_singlequote allow_bignum allow_barekey max_size relaxed/;my$JSON;sub encode_json ($) {($JSON ||= __PACKAGE__->new->utf8)->encode(@_)}sub decode_json {($JSON ||= __PACKAGE__->new->utf8)->decode(@_)}sub to_json($) {Carp::croak ("JSON::PP::to_json has been renamed to encode_json.")}sub from_json($) {Carp::croak ("JSON::PP::from_json has been renamed to decode_json.")}sub new {my$class=shift;my$self={max_depth=>512,max_size=>0,indent=>0,FLAGS=>0,fallback=>sub {encode_error('Invalid value. JSON can only reference.')},indent_length=>3,};bless$self,$class}sub encode {return $_[0]->PP_encode_json($_[1])}sub decode {return $_[0]->PP_decode_json($_[1],0x00000000)}sub decode_prefix {return $_[0]->PP_decode_json($_[1],0x00000001)}sub pretty {my ($self,$v)=@_;my$enable=defined$v ? $v : 1;if ($enable){$self->indent(1)->indent_length(3)->space_before(1)->space_after(1)}else {$self->indent(0)->space_before(0)->space_after(0)}$self}sub max_depth {my$max=defined $_[1]? $_[1]: 0x80000000;$_[0]->{max_depth}=$max;$_[0]}sub get_max_depth {$_[0]->{max_depth}}sub max_size {my$max=defined $_[1]? $_[1]: 0;$_[0]->{max_size}=$max;$_[0]}sub get_max_size {$_[0]->{max_size}}sub filter_json_object {$_[0]->{cb_object}=defined $_[1]? $_[1]: 0;$_[0]->{F_HOOK}=($_[0]->{cb_object}or $_[0]->{cb_sk_object})? 1 : 0;$_[0]}sub filter_json_single_key_object {if (@_ > 1){$_[0]->{cb_sk_object}->{$_[1]}=$_[2]}$_[0]->{F_HOOK}=($_[0]->{cb_object}or $_[0]->{cb_sk_object})? 1 : 0;$_[0]}sub indent_length {if (!defined $_[1]or $_[1]> 15 or $_[1]< 0){Carp::carp "The acceptable range of indent_length() is 0 to 15."}else {$_[0]->{indent_length}=$_[1]}$_[0]}sub get_indent_length {$_[0]->{indent_length}}sub sort_by {$_[0]->{sort_by}=defined $_[1]? $_[1]: 1;$_[0]}sub allow_bigint {Carp::carp("allow_bigint() is obsoleted. use allow_bignum() insted.")}{my$max_depth;my$indent;my$ascii;my$latin1;my$utf8;my$space_before;my$space_after;my$canonical;my$allow_blessed;my$convert_blessed;my$indent_length;my$escape_slash;my$bignum;my$as_nonblessed;my$depth;my$indent_count;my$keysort;sub PP_encode_json {my$self=shift;my$obj=shift;$indent_count=0;$depth=0;my$idx=$self->{PROPS};($ascii,$latin1,$utf8,$indent,$canonical,$space_before,$space_after,$allow_blessed,$convert_blessed,$escape_slash,$bignum,$as_nonblessed)=@{$idx}[P_ASCII .. P_SPACE_AFTER,P_ALLOW_BLESSED,P_CONVERT_BLESSED,P_ESCAPE_SLASH,P_ALLOW_BIGNUM,P_AS_NONBLESSED];($max_depth,$indent_length)=@{$self}{qw/max_depth indent_length/};$keysort=$canonical ? sub {$a cmp $b}: undef;if ($self->{sort_by}){$keysort=ref($self->{sort_by})eq 'CODE' ? $self->{sort_by}: $self->{sort_by}=~ /\D+/ ? $self->{sort_by}: sub {$a cmp $b}}encode_error("hash- or arrayref expected (not a simple scalar, use allow_nonref to allow this)")if(!ref$obj and!$idx->[P_ALLOW_NONREF ]);my$str=$self->object_to_json($obj);$str .= "\n" if ($indent);unless ($ascii or $latin1 or $utf8){utf8::upgrade($str)}if ($idx->[P_SHRINK ]){utf8::downgrade($str,1)}return$str}sub object_to_json {my ($self,$obj)=@_;my$type=ref($obj);if($type eq 'HASH'){return$self->hash_to_json($obj)}elsif($type eq 'ARRAY'){return$self->array_to_json($obj)}elsif ($type){if (blessed($obj)){return$self->value_to_json($obj)if ($obj->isa('JSON::PP::Boolean'));if ($convert_blessed and $obj->can('TO_JSON')){my$result=$obj->TO_JSON();if (defined$result and ref($result)){if (refaddr($obj)eq refaddr($result)){encode_error(sprintf("%s::TO_JSON method returned same object as was passed instead of a new one",ref$obj))}}return$self->object_to_json($result)}return "$obj" if ($bignum and _is_bignum($obj));return$self->blessed_to_json($obj)if ($allow_blessed and $as_nonblessed);encode_error(sprintf("encountered object '%s', but neither allow_blessed " ."nor convert_blessed settings are enabled",$obj))unless ($allow_blessed);return 'null'}else {return$self->value_to_json($obj)}}else{return$self->value_to_json($obj)}}sub hash_to_json {my ($self,$obj)=@_;my@res;encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")if (++$depth > $max_depth);my ($pre,$post)=$indent ? $self->_up_indent(): ('','');my$del=($space_before ? ' ' : '').':' .($space_after ? ' ' : '');for my$k (_sort($obj)){if (OLD_PERL){utf8::decode($k)}push@res,string_to_json($self,$k).$del .($self->object_to_json($obj->{$k})|| $self->value_to_json($obj->{$k}))}--$depth;$self->_down_indent()if ($indent);return '{' .(@res ? $pre : '').(@res ? join(",$pre",@res).$post : '').'}'}sub array_to_json {my ($self,$obj)=@_;my@res;encode_error("json text or perl structure exceeds maximum nesting level (max_depth set too low?)")if (++$depth > $max_depth);my ($pre,$post)=$indent ? $self->_up_indent(): ('','');for my$v (@$obj){push@res,$self->object_to_json($v)|| $self->value_to_json($v)}--$depth;$self->_down_indent()if ($indent);return '[' .(@res ? $pre : '').(@res ? join(",$pre",@res).$post : '').']'}sub value_to_json {my ($self,$value)=@_;return 'null' if(!defined$value);my$b_obj=B::svref_2object(\$value);my$flags=$b_obj->FLAGS;return$value if$flags & (B::SVp_IOK | B::SVp_NOK)and!($flags & B::SVp_POK);my$type=ref($value);if(!$type){return string_to_json($self,$value)}elsif(blessed($value)and $value->isa('JSON::PP::Boolean')){return $$value==1 ? 'true' : 'false'}elsif ($type){if ((overload::StrVal($value)=~ /=(\w+)/)[0]){return$self->value_to_json("$value")}if ($type eq 'SCALAR' and defined $$value){return $$value eq '1' ? 'true' : $$value eq '0' ? 'false' : $self->{PROPS}->[P_ALLOW_UNKNOWN ]? 'null' : encode_error("cannot encode reference to scalar")}if ($self->{PROPS}->[P_ALLOW_UNKNOWN ]){return 'null'}else {if ($type eq 'SCALAR' or $type eq 'REF'){encode_error("cannot encode reference to scalar")}else {encode_error("encountered $value, but JSON can only represent references to arrays or hashes")}}}else {return$self->{fallback}->($value)if ($self->{fallback}and ref($self->{fallback})eq 'CODE');return 'null'}}my%esc=("\n"=>'\n',"\r"=>'\r',"\t"=>'\t',"\f"=>'\f',"\b"=>'\b',"\""=>'\"',"\\"=>'\\\\',"\'"=>'\\\'',);sub string_to_json {my ($self,$arg)=@_;$arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g;$arg =~ s/\//\\\//g if ($escape_slash);$arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg;if ($ascii){$arg=JSON_PP_encode_ascii($arg)}if ($latin1){$arg=JSON_PP_encode_latin1($arg)}if ($utf8){utf8::encode($arg)}return '"' .$arg .'"'}sub blessed_to_json {my$reftype=reftype($_[1])|| '';if ($reftype eq 'HASH'){return $_[0]->hash_to_json($_[1])}elsif ($reftype eq 'ARRAY'){return $_[0]->array_to_json($_[1])}else {return 'null'}}sub encode_error {my$error=shift;Carp::croak "$error"}sub _sort {defined$keysort ? (sort$keysort (keys %{$_[0]})): keys %{$_[0]}}sub _up_indent {my$self=shift;my$space=' ' x $indent_length;my ($pre,$post)=('','');$post="\n" .$space x $indent_count;$indent_count++;$pre="\n" .$space x $indent_count;return ($pre,$post)}sub _down_indent {$indent_count--}sub PP_encode_box {{depth=>$depth,indent_count=>$indent_count,}}}sub _encode_ascii {join('',map {$_ <= 127 ? chr($_): $_ <= 65535 ? sprintf('\u%04x',$_): sprintf('\u%x\u%x',_encode_surrogates($_))}unpack('U*',$_[0]))}sub _encode_latin1 {join('',map {$_ <= 255 ? chr($_): $_ <= 65535 ? sprintf('\u%04x',$_): sprintf('\u%x\u%x',_encode_surrogates($_))}unpack('U*',$_[0]))}sub _encode_surrogates {my$uni=$_[0]- 0x10000;return ($uni / 0x400 + 0xD800,$uni % 0x400 + 0xDC00)}sub _is_bignum {$_[0]->isa('Math::BigInt')or $_[0]->isa('Math::BigFloat')}my$max_intsize;BEGIN {my$checkint=1111;for my$d (5..64){$checkint .= 1;my$int=eval qq| $checkint |;if ($int =~ /[eE]/){$max_intsize=$d - 1;last}}}{my%escapes=(b=>"\x8",t=>"\x9",n=>"\xA",f=>"\xC",r=>"\xD",'\\'=>'\\','"'=>'"','/'=>'/',);my$text;my$at;my$ch;my$len;my$depth;my$encoding;my$is_valid_utf8;my$utf8_len;my$utf8;my$max_depth;my$max_size;my$relaxed;my$cb_object;my$cb_sk_object;my$F_HOOK;my$allow_bigint;my$singlequote;my$loose;my$allow_barekey;sub PP_decode_json {my ($self,$opt);($self,$text,$opt)=@_;($at,$ch,$depth)=(0,'',0);if (!defined$text or ref$text){decode_error("malformed JSON string, neither array, object, number, string or atom")}my$idx=$self->{PROPS};($utf8,$relaxed,$loose,$allow_bigint,$allow_barekey,$singlequote)=@{$idx}[P_UTF8,P_RELAXED,P_LOOSE .. P_ALLOW_SINGLEQUOTE];if ($utf8){utf8::downgrade($text,1)or Carp::croak("Wide character in subroutine entry")}else {utf8::upgrade($text);utf8::encode($text)}$len=length$text;($max_depth,$max_size,$cb_object,$cb_sk_object,$F_HOOK)=@{$self}{qw/max_depth max_size cb_object cb_sk_object F_HOOK/};if ($max_size > 1){use bytes;my$bytes=length$text;decode_error(sprintf("attempted decode of JSON text of %s bytes size, but max_size is set to %s" ,$bytes,$max_size),1)if ($bytes > $max_size)}my@octets=unpack('C4',$text);$encoding=($octets[0]and $octets[1])? 'UTF-8' : (!$octets[0]and $octets[1])? 'UTF-16BE' : (!$octets[0]and!$octets[1])? 'UTF-32BE' : ($octets[2])? 'UTF-16LE' : (!$octets[2])? 'UTF-32LE' : 'unknown';white();my$valid_start=defined$ch;my$result=value();return undef if (!$result && ($opt & 0x10000000));decode_error("malformed JSON string, neither array, object, number, string or atom")unless$valid_start;if (!$idx->[P_ALLOW_NONREF ]and!ref$result){decode_error('JSON text must be an object or array (but found number, string, true, false or null,' .' use allow_nonref to allow this)',1)}Carp::croak('something wrong.')if$len < $at;my$consumed=defined$ch ? $at - 1 : $at;white();if ($ch){return ($result,$consumed)if ($opt & 0x00000001);decode_error("garbage after JSON object")}($opt & 0x00000001)? ($result,$consumed): $result}sub next_chr {return$ch=undef if($at >= $len);$ch=substr($text,$at++,1)}sub value {white();return if(!defined$ch);return object()if($ch eq '{');return array()if($ch eq '[');return string()if($ch eq '"' or ($singlequote and $ch eq "'"));return number()if($ch =~ /[0-9]/ or $ch eq '-');return word()}sub string {my ($i,$s,$t,$u);my$utf16;my$is_utf8;($is_valid_utf8,$utf8_len)=('',0);$s='';if($ch eq '"' or ($singlequote and $ch eq "'")){my$boundChar=$ch;OUTER: while(defined(next_chr())){if($ch eq $boundChar){next_chr();if ($utf16){decode_error("missing low surrogate character in surrogate pair")}utf8::decode($s)if($is_utf8);return$s}elsif($ch eq '\\'){next_chr();if(exists$escapes{$ch}){$s .= $escapes{$ch}}elsif($ch eq 'u'){my$u='';for(1..4){$ch=next_chr();last OUTER if($ch !~ /[0-9a-fA-F]/);$u .= $ch}if ($u =~ /^[dD][89abAB][0-9a-fA-F]{2}/){$utf16=$u}elsif ($u =~ /^[dD][c-fC-F][0-9a-fA-F]{2}/){unless (defined$utf16){decode_error("missing high surrogate character in surrogate pair")}$is_utf8=1;$s .= JSON_PP_decode_surrogates($utf16,$u)|| next;$utf16=undef}else {if (defined$utf16){decode_error("surrogate pair expected")}if ((my$hex=hex($u))> 127){$is_utf8=1;$s .= JSON_PP_decode_unicode($u)|| next}else {$s .= chr$hex}}}else{unless ($loose){$at -= 2;decode_error('illegal backslash escape sequence in string')}$s .= $ch}}else{if (ord$ch > 127){unless($ch=is_valid_utf8($ch)){$at -= 1;decode_error("malformed UTF-8 character in JSON string")}else {$at += $utf8_len - 1}$is_utf8=1}if (!$loose){if ($ch =~ /[\x00-\x1f\x22\x5c]/){$at--;decode_error('invalid character encountered while parsing JSON string')}}$s .= $ch}}}decode_error("unexpected end of string while parsing JSON string")}sub white {while(defined$ch){if($ch le ' '){next_chr()}elsif($ch eq '/'){next_chr();if(defined$ch and $ch eq '/'){1 while(defined(next_chr())and $ch ne "\n" and $ch ne "\r")}elsif(defined$ch and $ch eq '*'){next_chr();while(1){if(defined$ch){if($ch eq '*'){if(defined(next_chr())and $ch eq '/'){next_chr();last}}else{next_chr()}}else{decode_error("Unterminated comment")}}next}else{$at--;decode_error("malformed JSON string, neither array, object, number, string or atom")}}else{if ($relaxed and $ch eq '#'){pos($text)=$at;$text =~ /\G([^\n]*(?:\r\n|\r|\n|$))/g;$at=pos($text);next_chr;next}last}}}sub array {my$a=$_[0]|| [];decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')if (++$depth > $max_depth);next_chr();white();if(defined$ch and $ch eq ']'){--$depth;next_chr();return$a}else {while(defined($ch)){push @$a,value();white();if (!defined$ch){last}if($ch eq ']'){--$depth;next_chr();return$a}if($ch ne ','){last}next_chr();white();if ($relaxed and $ch eq ']'){--$depth;next_chr();return$a}}}decode_error(", or ] expected while parsing array")}sub object {my$o=$_[0]|| {};my$k;decode_error('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')if (++$depth > $max_depth);next_chr();white();if(defined$ch and $ch eq '}'){--$depth;next_chr();if ($F_HOOK){return _json_object_hook($o)}return$o}else {while (defined$ch){$k=($allow_barekey and $ch ne '"' and $ch ne "'")? bareKey(): string();white();if(!defined$ch or $ch ne ':'){$at--;decode_error("':' expected")}next_chr();$o->{$k}=value();white();last if (!defined$ch);if($ch eq '}'){--$depth;next_chr();if ($F_HOOK){return _json_object_hook($o)}return$o}if($ch ne ','){last}next_chr();white();if ($relaxed and $ch eq '}'){--$depth;next_chr();if ($F_HOOK){return _json_object_hook($o)}return$o}}}$at--;decode_error(", or } expected while parsing object/hash")}sub bareKey {my$key;while($ch =~ /[^\x00-\x23\x25-\x2F\x3A-\x40\x5B-\x5E\x60\x7B-\x7F]/){$key .= $ch;next_chr()}return$key}sub word {my$word=substr($text,$at-1,4);if($word eq 'true'){$at += 3;next_chr;return$JSON::PP::true}elsif($word eq 'null'){$at += 3;next_chr;return undef}elsif($word eq 'fals'){$at += 3;if(substr($text,$at,1)eq 'e'){$at++;next_chr;return$JSON::PP::false}}$at--;decode_error("'null' expected")if ($word =~ /^n/);decode_error("'true' expected")if ($word =~ /^t/);decode_error("'false' expected")if ($word =~ /^f/);decode_error("malformed JSON string, neither array, object, number, string or atom")}sub number {my$n='';my$v;if($ch eq '0'){my$peek=substr($text,$at,1);my$hex=$peek =~ /[xX]/;if($hex){decode_error("malformed number (leading zero must not be followed by another digit)");($n)=(substr($text,$at+1)=~ /^([0-9a-fA-F]+)/)}else{($n)=(substr($text,$at)=~ /^([0-7]+)/);if (defined$n and length$n > 1){decode_error("malformed number (leading zero must not be followed by another digit)")}}if(defined$n and length($n)){if (!$hex and length($n)==1){decode_error("malformed number (leading zero must not be followed by another digit)")}$at += length($n)+ $hex;next_chr;return$hex ? hex($n): oct($n)}}if($ch eq '-'){$n='-';next_chr;if (!defined$ch or $ch !~ /\d/){decode_error("malformed number (no digits after initial minus)")}}while(defined$ch and $ch =~ /\d/){$n .= $ch;next_chr}if(defined$ch and $ch eq '.'){$n .= '.';next_chr;if (!defined$ch or $ch !~ /\d/){decode_error("malformed number (no digits after decimal point)")}else {$n .= $ch}while(defined(next_chr)and $ch =~ /\d/){$n .= $ch}}if(defined$ch and ($ch eq 'e' or $ch eq 'E')){$n .= $ch;next_chr;if(defined($ch)and ($ch eq '+' or $ch eq '-')){$n .= $ch;next_chr;if (!defined$ch or $ch =~ /\D/){decode_error("malformed number (no digits after exp sign)")}$n .= $ch}elsif(defined($ch)and $ch =~ /\d/){$n .= $ch}else {decode_error("malformed number (no digits after exp sign)")}while(defined(next_chr)and $ch =~ /\d/){$n .= $ch}}$v .= $n;if ($v !~ /[.eE]/ and length$v > $max_intsize){if ($allow_bigint){require Math::BigInt;return Math::BigInt->new($v)}else {return "$v"}}elsif ($allow_bigint){require Math::BigFloat;return Math::BigFloat->new($v)}return 0+$v}sub is_valid_utf8 {$utf8_len=$_[0]=~ /[\x00-\x7F]/ ? 1 : $_[0]=~ /[\xC2-\xDF]/ ? 2 : $_[0]=~ /[\xE0-\xEF]/ ? 3 : $_[0]=~ /[\xF0-\xF4]/ ? 4 : 0 ;return unless$utf8_len;my$is_valid_utf8=substr($text,$at - 1,$utf8_len);return ($is_valid_utf8 =~ /^(?: [\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*' : 'C*' ;for my$c (unpack($type,$str)){$mess .= $c==0x07 ? '\a' : $c==0x09 ? '\t' : $c==0x0a ? '\n' : $c==0x0d ? '\r' : $c==0x0c ? '\f' : $c < 0x20 ? sprintf('\x{%x}',$c): $c==0x5c ? '\\\\' : $c < 0x80 ? chr($c): sprintf('\x{%x}',$c);if (length$mess >= 20){$mess .= '...';last}}unless (length$mess){$mess='(end of string)'}Carp::croak ($no_rep ? "$error" : "$error, at character offset $at (before \"$mess\")")}sub _json_object_hook {my$o=$_[0];my@ks=keys %{$o};if ($cb_sk_object and @ks==1 and exists$cb_sk_object->{$ks[0]}and ref$cb_sk_object->{$ks[0]}){my@val=$cb_sk_object->{$ks[0]}->($o->{$ks[0]});if (@val==1){return$val[0]}}my@val=$cb_object->($o)if ($cb_object);if (@val==0 or @val > 1){return$o}else {return$val[0]}}sub PP_decode_box {{text=>$text,at=>$at,ch=>$ch,len=>$len,depth=>$depth,encoding=>$encoding,is_valid_utf8=>$is_valid_utf8,}}}sub _decode_surrogates {my$uni=0x10000 + (hex($_[0])- 0xD800)* 0x400 + (hex($_[1])- 0xDC00);my$un=pack('U*',$uni);utf8::encode($un);return$un}sub _decode_unicode {my$un=pack('U',hex shift);utf8::encode($un);return$un}BEGIN {unless (defined&utf8::is_utf8){require Encode;*utf8::is_utf8=*Encode::is_utf8}if ($] >= 5.008){*JSON::PP::JSON_PP_encode_ascii=\&_encode_ascii;*JSON::PP::JSON_PP_encode_latin1=\&_encode_latin1;*JSON::PP::JSON_PP_decode_surrogates=\&_decode_surrogates;*JSON::PP::JSON_PP_decode_unicode=\&_decode_unicode}if ($] >= 5.008 and $] < 5.008003){package JSON::PP;require subs;subs->import('join');eval q| 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)}BEGIN {eval 'require Scalar::Util';unless($@){*JSON::PP::blessed=\&Scalar::Util::blessed;*JSON::PP::reftype=\&Scalar::Util::reftype;*JSON::PP::refaddr=\&Scalar::Util::refaddr}else{eval 'sub UNIVERSAL::a_sub_not_likely_to_be_here { ref($_[0]) }';*JSON::PP::blessed=sub {local($@,$SIG{__DIE__},$SIG{__WARN__});ref($_[0])? eval {$_[0]->a_sub_not_likely_to_be_here}: undef};my%tmap=qw(B::NULL SCALAR B::HV HASH B::AV ARRAY B::CV CODE B::IO IO B::GV GLOB B::REGEXP REGEXP);*JSON::PP::reftype=sub {my$r=shift;return undef unless length(ref($r));my$t=ref(B::svref_2object($r));return exists$tmap{$t}? $tmap{$t}: length(ref($$r))? 'REF' : 'SCALAR'};*JSON::PP::refaddr=sub {return undef unless length(ref($_[0]));my$addr;if(defined(my$pkg=blessed($_[0]))){$addr .= bless $_[0],'Scalar::Util::Fake';bless $_[0],$pkg}else {$addr .= $_[0]}$addr =~ /0x(\w+)/;local $^W;hex($1)}}}$JSON::PP::true=do {bless \(my$dummy=1),"JSON::PP::Boolean"};$JSON::PP::false=do {bless \(my$dummy=0),"JSON::PP::Boolean"};sub is_bool {defined $_[0]and UNIVERSAL::isa($_[0],"JSON::PP::Boolean")}sub true {$JSON::PP::true}sub false {$JSON::PP::false}sub null {undef}package JSON::PP::Boolean;use overload ("0+"=>sub {${$_[0]}},"++"=>sub {$_[0]=${$_[0]}+ 1},"--"=>sub {$_[0]=${$_[0]}- 1},fallback=>1,);package JSON::PP::IncrParser;use strict;use constant INCR_M_WS=>0;use constant INCR_M_STR=>1;use constant INCR_M_BS=>2;use constant INCR_M_JSON=>3;use constant INCR_M_C0=>4;use constant INCR_M_C1=>5;$JSON::PP::IncrParser::VERSION='1.01';my$unpack_format=$] < 5.006 ? 'C*' : 'U*';sub new {my ($class)=@_;bless {incr_nest=>0,incr_text=>undef,incr_parsing=>0,incr_p=>0,},$class}sub incr_parse {my ($self,$coder,$text)=@_;$self->{incr_text}='' unless (defined$self->{incr_text});if (defined$text){if (utf8::is_utf8($text)and!utf8::is_utf8($self->{incr_text})){utf8::upgrade($self->{incr_text});utf8::decode($self->{incr_text})}$self->{incr_text}.= $text}my$max_size=$coder->get_max_size;if (defined wantarray){$self->{incr_mode}=INCR_M_WS unless defined$self->{incr_mode};if (wantarray){my@ret;$self->{incr_parsing}=1;do {push@ret,$self->_incr_parse($coder,$self->{incr_text});unless (!$self->{incr_nest}and $self->{incr_mode}==INCR_M_JSON){$self->{incr_mode}=INCR_M_WS if$self->{incr_mode}!=INCR_M_STR}}until (length$self->{incr_text}>= $self->{incr_p});$self->{incr_parsing}=0;return@ret}else {$self->{incr_parsing}=1;my$obj=$self->_incr_parse($coder,$self->{incr_text});$self->{incr_parsing}=0 if defined$obj;return$obj ? $obj : undef}}}sub _incr_parse {my ($self,$coder,$text,$skip)=@_;my$p=$self->{incr_p};my$restore=$p;my@obj;my$len=length$text;if ($self->{incr_mode}==INCR_M_WS){while ($len > $p){my$s=substr($text,$p,1);$p++ and next if (0x20 >= unpack($unpack_format,$s));$self->{incr_mode}=INCR_M_JSON;last}}while ($len > $p){my$s=substr($text,$p++,1);if ($s eq '"'){if (substr($text,$p - 2,1)eq '\\'){next}if ($self->{incr_mode}!=INCR_M_STR){$self->{incr_mode}=INCR_M_STR}else {$self->{incr_mode}=INCR_M_JSON;unless ($self->{incr_nest}){last}}}if ($self->{incr_mode}==INCR_M_JSON){if ($s eq '[' or $s eq '{'){if (++$self->{incr_nest}> $coder->get_max_depth){Carp::croak('json text or perl structure exceeds maximum nesting level (max_depth set too low?)')}}elsif ($s eq ']' or $s eq '}'){last if (--$self->{incr_nest}<= 0)}elsif ($s eq '#'){while ($len > $p){last if substr($text,$p++,1)eq "\n"}}}}$self->{incr_p}=$p;return if ($self->{incr_mode}==INCR_M_STR and not $self->{incr_nest});return if ($self->{incr_mode}==INCR_M_JSON and $self->{incr_nest}> 0);return '' unless (length substr($self->{incr_text},0,$p));local$Carp::CarpLevel=2;$self->{incr_p}=$restore;$self->{incr_c}=$p;my ($obj,$tail)=$coder->PP_decode_json(substr($self->{incr_text},0,$p),0x10000001);$self->{incr_text}=substr($self->{incr_text},$p);$self->{incr_p}=0;return$obj || ''}sub incr_text {if ($_[0]->{incr_parsing}){Carp::croak("incr_text can not be called when the incremental parser already started parsing")}$_[0]->{incr_text}}sub incr_skip {my$self=shift;$self->{incr_text}=substr($self->{incr_text},$self->{incr_c});$self->{incr_p}=0}sub incr_reset {my$self=shift;$self->{incr_text}=undef;$self->{incr_p}=0;$self->{incr_mode}=0;$self->{incr_nest}=0;$self->{incr_parsing}=0}1; JSON_PP $fatpacked{"JSON/PP/Boolean.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'JSON_PP_BOOLEAN'; use JSON::PP ();use strict;1; JSON_PP_BOOLEAN $fatpacked{"Module/CPANfile.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE'; package Module::CPANfile;use strict;use warnings;use Cwd;use Carp ();use Module::CPANfile::Environment;use Module::CPANfile::Requirement;our$VERSION='1.1000';sub new {my($class,$file)=@_;bless {},$class}sub load {my($proto,$file)=@_;my$self=ref$proto ? $proto : $proto->new;$self->parse($file || Cwd::abs_path('cpanfile'));$self}sub save {my($self,$path)=@_;open my$out,">",$path or die "$path: $!";print {$out}$self->to_string}sub parse {my($self,$file)=@_;my$code=do {open my$fh,"<",$file or die "$file: $!";join '',<$fh>};my$env=Module::CPANfile::Environment->new($file);$env->parse($code)or die $@;$self->{_mirrors}=$env->mirrors;$self->{_prereqs}=$env->prereqs}sub from_prereqs {my($proto,$prereqs)=@_;my$self=$proto->new;$self->{_prereqs}=Module::CPANfile::Prereqs->from_cpan_meta($prereqs);$self}sub mirrors {my$self=shift;$self->{_mirrors}|| []}sub features {my$self=shift;map$self->feature($_),$self->{_prereqs}->identifiers}sub feature {my($self,$identifier)=@_;$self->{_prereqs}->feature($identifier)}sub prereq {shift->prereqs}sub prereqs {my$self=shift;$self->{_prereqs}->as_cpan_meta}sub merged_requirements {my$self=shift;$self->{_prereqs}->merged_requirements}sub effective_prereqs {my($self,$features)=@_;$self->prereqs_with(@{$features || []})}sub prereqs_with {my($self,@feature_identifiers)=@_;my$prereqs=$self->prereqs;my@others=map {$self->feature($_)->prereqs}@feature_identifiers;$prereqs->with_merged_prereqs(\@others)}sub prereq_specs {my$self=shift;$self->prereqs->as_string_hash}sub prereq_for_module {my($self,$module)=@_;$self->{_prereqs}->find($module)}sub options_for_module {my($self,$module)=@_;my$prereq=$self->prereq_for_module($module)or return;$prereq->requirement->options}sub merge_meta {my($self,$file,$version)=@_;require CPAN::Meta;$version ||= $file =~ /\.yml$/ ? '1.4' : '2';my$prereq=$self->prereqs;my$meta=CPAN::Meta->load_file($file);my$prereqs_hash=$prereq->with_merged_prereqs($meta->effective_prereqs)->as_string_hash;my$struct={%{$meta->as_struct},prereqs=>$prereqs_hash };CPAN::Meta->new($struct)->save($file,{version=>$version })}sub _dump {my$str=shift;require Data::Dumper;chomp(my$value=Data::Dumper->new([$str])->Terse(1)->Dump);$value}sub to_string {my($self,$include_empty)=@_;my$mirrors=$self->mirrors;my$prereqs=$self->prereq_specs;my$code='';$code .= $self->_dump_mirrors($mirrors);$code .= $self->_dump_prereqs($prereqs,$include_empty);for my$feature ($self->features){$code .= sprintf "feature %s, %s => sub {\n",_dump($feature->{identifier}),_dump($feature->{description});$code .= $self->_dump_prereqs($feature->{spec},$include_empty,4);$code .= "}\n\n"}$code =~ s/\n+$/\n/s;$code}sub _dump_mirrors {my($self,$mirrors)=@_;my$code="";for my$url (@$mirrors){$code .= "mirror '$url';\n"}$code =~ s/\n+$/\n/s;$code}sub _dump_prereqs {my($self,$prereqs,$include_empty,$base_indent)=@_;my$code='';for my$phase (qw(runtime configure build test develop)){my$indent=$phase eq 'runtime' ? '' : ' ';$indent=(' ' x ($base_indent || 0)).$indent;my($phase_code,$requirements);$phase_code .= "on $phase => sub {\n" unless$phase eq 'runtime';for my$type (qw(requires recommends suggests conflicts)){for my$mod (sort keys %{$prereqs->{$phase}{$type}}){my$ver=$prereqs->{$phase}{$type}{$mod};$phase_code .= $ver eq '0' ? "${indent}$type '$mod';\n" : "${indent}$type '$mod', '$ver';\n";$requirements++}}$phase_code .= "\n" unless$requirements;$phase_code .= "};\n" unless$phase eq 'runtime';$code .= $phase_code ."\n" if$requirements or $include_empty}$code =~ s/\n+$/\n/s;$code}1; MODULE_CPANFILE $fatpacked{"Module/CPANfile/Environment.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_ENVIRONMENT'; package Module::CPANfile::Environment;use strict;use warnings;use Module::CPANfile::Prereqs;use Carp ();my@bindings=qw(on requires recommends suggests conflicts feature osname mirror configure_requires build_requires test_requires author_requires);my$file_id=1;sub new {my($class,$file)=@_;bless {file=>$file,phase=>'runtime',feature=>undef,features=>{},prereqs=>Module::CPANfile::Prereqs->new,mirrors=>[],},$class}sub bind {my$self=shift;my$pkg=caller;for my$binding (@bindings){no strict 'refs';*{"$pkg\::$binding"}=sub {$self->$binding(@_)}}}sub parse {my($self,$code)=@_;my$err;{local $@;$file_id++;$self->_evaluate(<<EVAL);$err=$@}if ($err){die "Parsing $self->{file} failed: $err"};return 1}sub _evaluate {my$_environment=$_[0];eval $_[1]}sub prereqs {$_[0]->{prereqs}}sub mirrors {$_[0]->{mirrors}}sub on {my($self,$phase,$code)=@_;local$self->{phase}=$phase;$code->()}sub feature {my($self,$identifier,$description,$code)=@_;if (@_==3 && ref($description)eq 'CODE'){$code=$description;$description=$identifier}unless (ref$description eq '' && ref$code eq 'CODE'){Carp::croak("Usage: feature 'identifier', 'Description' => sub { ... }")}local$self->{feature}=$identifier;$self->prereqs->add_feature($identifier,$description);$code->()}sub osname {die "TODO"}sub mirror {my($self,$url)=@_;push @{$self->{mirrors}},$url}sub requirement_for {my($self,$module,@args)=@_;my$requirement=0;$requirement=shift@args if@args % 2;return Module::CPANfile::Requirement->new(name=>$module,version=>$requirement,@args,)}sub requires {my$self=shift;$self->add_prereq(requires=>@_)}sub recommends {my$self=shift;$self->add_prereq(recommends=>@_)}sub suggests {my$self=shift;$self->add_prereq(suggests=>@_)}sub conflicts {my$self=shift;$self->add_prereq(conflicts=>@_)}sub add_prereq {my($self,$type,$module,@args)=@_;$self->prereqs->add_prereq(feature=>$self->{feature},phase=>$self->{phase},type=>$type,module=>$module,requirement=>$self->requirement_for($module,@args),)}sub configure_requires {my($self,@args)=@_;$self->on(configure=>sub {$self->requires(@args)})}sub build_requires {my($self,@args)=@_;$self->on(build=>sub {$self->requires(@args)})}sub test_requires {my($self,@args)=@_;$self->on(test=>sub {$self->requires(@args)})}sub author_requires {my($self,@args)=@_;$self->on(develop=>sub {$self->requires(@args)})}1; package Module::CPANfile::Sandbox$file_id; no warnings; BEGIN { \$_environment->bind } # line 1 "$self->{file}" $code; EVAL MODULE_CPANFILE_ENVIRONMENT $fatpacked{"Module/CPANfile/Prereq.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_PREREQ'; package Module::CPANfile::Prereq;use strict;sub new {my($class,%options)=@_;bless \%options,$class}sub feature {$_[0]->{feature}}sub phase {$_[0]->{phase}}sub type {$_[0]->{type}}sub module {$_[0]->{module}}sub requirement {$_[0]->{requirement}}sub match_feature {my($self,$identifier)=@_;no warnings 'uninitialized';$self->feature eq $identifier}1; MODULE_CPANFILE_PREREQ $fatpacked{"Module/CPANfile/Prereqs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_PREREQS'; package Module::CPANfile::Prereqs;use strict;use Carp ();use CPAN::Meta::Feature;use Module::CPANfile::Prereq;sub from_cpan_meta {my($class,$prereqs)=@_;my$self=$class->new;for my$phase (keys %$prereqs){for my$type (keys %{$prereqs->{$phase}}){while (my($module,$requirement)=each %{$prereqs->{$phase}{$type}}){$self->add_prereq(phase=>$phase,type=>$type,module=>$module,requirement=>Module::CPANfile::Requirement->new(name=>$module,version=>$requirement),)}}}$self}sub new {my$class=shift;bless {prereqs=>[],features=>{},},$class}sub add_feature {my($self,$identifier,$description)=@_;$self->{features}{$identifier}={description=>$description }}sub add_prereq {my($self,%args)=@_;$self->add(Module::CPANfile::Prereq->new(%args))}sub add {my($self,$prereq)=@_;push @{$self->{prereqs}},$prereq}sub as_cpan_meta {my$self=shift;$self->{cpanmeta}||= $self->build_cpan_meta}sub build_cpan_meta {my($self,$identifier)=@_;my$prereq_spec={};$self->prereq_each($identifier,sub {my$prereq=shift;$prereq_spec->{$prereq->phase}{$prereq->type}{$prereq->module}=$prereq->requirement->version});CPAN::Meta::Prereqs->new($prereq_spec)}sub prereq_each {my($self,$identifier,$code)=@_;for my$prereq (@{$self->{prereqs}}){next unless$prereq->match_feature($identifier);$code->($prereq)}}sub merged_requirements {my$self=shift;my$reqs=CPAN::Meta::Requirements->new;for my$prereq (@{$self->{prereqs}}){$reqs->add_string_requirement($prereq->module,$prereq->requirement->version)}$reqs}sub find {my($self,$module)=@_;for my$prereq (@{$self->{prereqs}}){return$prereq if$prereq->module eq $module}return}sub identifiers {my$self=shift;keys %{$self->{features}}}sub feature {my($self,$identifier)=@_;my$data=$self->{features}{$identifier}or Carp::croak("Unknown feature '$identifier'");my$prereqs=$self->build_cpan_meta($identifier);CPAN::Meta::Feature->new($identifier,{description=>$data->{description},prereqs=>$prereqs->as_string_hash,})}1; MODULE_CPANFILE_PREREQS $fatpacked{"Module/CPANfile/Requirement.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_REQUIREMENT'; package Module::CPANfile::Requirement;use strict;sub new {my ($class,%args)=@_;$args{version}||= 0;bless +{name=>delete$args{name},version=>delete$args{version},options=>\%args,},$class}sub name {$_[0]->{name}}sub version {$_[0]->{version}}sub options {$_[0]->{options}}sub has_options {keys %{$_[0]->{options}}> 0}1; MODULE_CPANFILE_REQUIREMENT $fatpacked{"Module/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_METADATA'; package Module::Metadata;sub __clean_eval {eval $_[0]}use strict;use warnings;our$VERSION='1.000027';use Carp qw/croak/;use File::Spec;BEGIN {eval {require Fcntl;Fcntl->import('SEEK_SET');1}or *SEEK_SET=sub {0}}use version 0.87;BEGIN {if ($INC{'Log/Contextual.pm'}){require "Log/Contextual/WarnLogger.pm";Log::Contextual->import('log_info','-default_logger'=>Log::Contextual::WarnLogger->new({env_prefix=>'MODULE_METADATA',}),)}else {*log_info=sub (&) {warn $_[0]->()}}}use File::Find qw(find);my$V_NUM_REGEXP=qr{v?[0-9._]+};my$PKG_FIRST_WORD_REGEXP=qr{ # the FIRST word in a package name [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 =~ /[=<>!,]/){}elsif (ref$version eq 'version'){$version=$version->is_qv ? $version->normal : $version->stringify}elsif ($version =~ /^[^v][^.]*\.[^.]+\./){$version="v$version"}else {}return$version};my$resolve_module_versions=sub {my$packages=shift;my($file,$version);my$err='';for my$p (@$packages){if (defined($p->{version})){if (defined($version)){if ($compare_versions->($version,'!=',$p->{version})){$err .= " $p->{file} ($p->{version})\n"}else {}}else {$file=$p->{file};$version=$p->{version}}}$file ||= $p->{file}if defined($p->{file})}if ($err){$err=" $file ($version)\n" .$err}my%result=(file=>$file,version=>$version,err=>$err);return \%result};sub provides {my$class=shift;croak "provides() requires key/value pairs \n" if @_ % 2;my%args=@_;croak "provides() takes only one of 'dir' or 'files'\n" if$args{dir}&& $args{files};croak "provides() requires a 'version' argument" unless defined$args{version};croak "provides() does not support version '$args{version}' metadata" unless grep {$args{version}eq $_}qw/1.4 2/;$args{prefix}='lib' unless defined$args{prefix};my$p;if ($args{dir}){$p=$class->package_versions_from_directory($args{dir})}else {croak "provides() requires 'files' to be an array reference\n" unless ref$args{files}eq 'ARRAY';$p=$class->package_versions_from_directory($args{files})}if (length$args{prefix}){$args{prefix}=~ s{/$}{};for my$v (values %$p){$v->{file}="$args{prefix}/$v->{file}"}}return$p}sub package_versions_from_directory {my ($class,$dir,$files)=@_;my@files;if ($files){@files=@$files}else {find({wanted=>sub {push@files,$_ if -f $_ && /\.pm$/},no_chdir=>1,},$dir)}my(%prime,%alt);for my$file (@files){my$mapped_filename=File::Spec::Unix->abs2rel($file,$dir);my@path=split(/\//,$mapped_filename);(my$prime_package=join('::',@path))=~ s/\.pm$//;my$pm_info=$class->new_from_file($file);for my$package ($pm_info->packages_inside){next if$package eq 'main';next if$package eq 'DB';next if grep /^_/,split(/::/,$package);my$version=$pm_info->version($package);$prime_package=$package if lc($prime_package)eq lc($package);if ($package eq $prime_package){if (exists($prime{$package})){croak "Unexpected conflict in '$package'; multiple versions found.\n"}else {$mapped_filename="$package.pm" if lc("$package.pm")eq lc($mapped_filename);$prime{$package}{file}=$mapped_filename;$prime{$package}{version}=$version if defined($version)}}else {push(@{$alt{$package}},{file=>$mapped_filename,version=>$version,})}}}for my$package (keys(%alt)){my$result=$resolve_module_versions->($alt{$package});if (exists($prime{$package})){if ($result->{err}){log_info {"Found conflicting versions for package '$package'\n" ." $prime{$package}{file} ($prime{$package}{version})\n" .$result->{err}}}elsif (defined($result->{version})){if (exists($prime{$package}{version})&& defined($prime{$package}{version})){if ($compare_versions->($prime{$package}{version},'!=',$result->{version})){log_info {"Found conflicting versions for package '$package'\n" ." $prime{$package}{file} ($prime{$package}{version})\n" ." $result->{file} ($result->{version})\n"}}}else {$prime{$package}{file}=$result->{file};$prime{$package}{version}=$result->{version}}}else {}}else {if ($result->{err}){log_info {"Found conflicting versions for package '$package'\n" .$result->{err}}}$prime{$package}{file}=$result->{file};$prime{$package}{version}=$result->{version}if defined($result->{version})}}for (grep defined $_->{version},values%prime){$_->{version}=$normalize_version->($_->{version})}return \%prime}}sub _init {my$class=shift;my$module=shift;my$filename=shift;my%props=@_;my$handle=delete$props{handle};my(%valid_props,@valid_props);@valid_props=qw(collect_pod inc);@valid_props{@valid_props}=delete(@props{@valid_props});warn "Unknown properties: @{[keys %props]}\n" if scalar(%props);my%data=(module=>$module,filename=>$filename,version=>undef,packages=>[],versions=>{},pod=>{},pod_headings=>[],collect_pod=>0,%valid_props,);my$self=bless(\%data,$class);if (not $handle){my$filename=$self->{filename};open$handle,'<',$filename or croak("Can't open '$filename': $!");$self->_handle_bom($handle,$filename)}$self->_parse_fh($handle);unless($self->{module}and length($self->{module})){my ($v,$d,$f)=File::Spec->splitpath($self->{filename});if($f =~ /\.pm$/){$f =~ s/\..+$//;my@candidates=grep /$f$/,@{$self->{packages}};$self->{module}=shift(@candidates)}else {if(grep /main/,@{$self->{packages}}){$self->{module}='main'}else {$self->{module}=$self->{packages}[0]|| ''}}}$self->{version}=$self->{versions}{$self->{module}}if defined($self->{module});return$self}sub _do_find_module {my$class=shift;my$module=shift || croak 'find_module_by_name() requires a package name';my$dirs=shift || \@INC;my$file=File::Spec->catfile(split(/::/,$module));for my$dir (@$dirs){my$testfile=File::Spec->catfile($dir,$file);return [File::Spec->rel2abs($testfile),$dir ]if -e $testfile and!-d _;$testfile .= '.pm';return [File::Spec->rel2abs($testfile),$dir ]if -e $testfile}return}sub find_module_by_name {my$found=shift()->_do_find_module(@_)or return;return$found->[0]}sub find_module_dir_by_name {my$found=shift()->_do_find_module(@_)or return;return$found->[1]}sub _parse_version_expression {my$self=shift;my$line=shift;my($sigil,$variable_name,$package);if ($line =~ /$VERS_REGEXP/o){($sigil,$variable_name,$package)=$2 ? ($1,$2,$3): ($4,$5,$6);if ($package){$package=($package eq '::')? 'main' : $package;$package =~ s/::$//}}return ($sigil,$variable_name,$package)}sub _handle_bom {my ($self,$fh,$filename)=@_;my$pos=tell$fh;return unless defined$pos;my$buf=' ' x 2;my$count=read$fh,$buf,length$buf;return unless defined$count and $count >= 2;my$encoding;if ($buf eq "\x{FE}\x{FF}"){$encoding='UTF-16BE'}elsif ($buf eq "\x{FF}\x{FE}"){$encoding='UTF-16LE'}elsif ($buf eq "\x{EF}\x{BB}"){$buf=' ';$count=read$fh,$buf,length$buf;if (defined$count and $count >= 1 and $buf eq "\x{BF}"){$encoding='UTF-8'}}if (defined$encoding){if ("$]" >= 5.008){binmode($fh,":encoding($encoding)")}}else {seek$fh,$pos,SEEK_SET or croak(sprintf "Can't reset position to the top of '$filename'")}return$encoding}sub _parse_fh {my ($self,$fh)=@_;my($in_pod,$seen_end,$need_vers)=(0,0,0);my(@packages,%vers,%pod,@pod);my$package='main';my$pod_sect='';my$pod_data='';my$in_end=0;while (defined(my$line=<$fh>)){my$line_num=$.;chomp($line);my$is_cut;if ($line =~ /^=([a-zA-Z].*)/){my$cmd=$1;$is_cut=$cmd =~ /^cut(?:[^a-zA-Z]|$)/;$in_pod=!$is_cut}if ($in_pod){if ($line =~ /^=head[1-4]\s+(.+)\s*$/){push(@pod,$1);if ($self->{collect_pod}&& length($pod_data)){$pod{$pod_sect}=$pod_data;$pod_data=''}$pod_sect=$1}elsif ($self->{collect_pod}){$pod_data .= "$line\n"}}elsif ($is_cut){if ($self->{collect_pod}&& length($pod_data)){$pod{$pod_sect}=$pod_data;$pod_data=''}$pod_sect=''}else {next if$in_end;next if$line =~ /^\s*#/;if ($line eq '__END__'){$in_end++;next}last if$line eq '__DATA__';my($version_sigil,$version_fullname,$version_package)=index($line,'VERSION')>= 1 ? $self->_parse_version_expression($line): ();if ($line =~ /$PKG_REGEXP/o){$package=$1;my$version=$2;push(@packages,$package)unless grep($package eq $_,@packages);$need_vers=defined$version ? 0 : 1;if (not exists$vers{$package}and defined$version){my$dwim_version=eval {_dwim_version($version)};croak "Version '$version' from $self->{filename} does not appear to be valid:\n$line\n\nThe fatal error was: $@\n" unless defined$dwim_version;$vers{$package}=$dwim_version}}elsif ($version_fullname && $version_package){push(@packages,$version_package)unless grep($version_package eq $_,@packages);$need_vers=0 if$version_package eq $package;unless (defined$vers{$version_package}&& length$vers{$version_package}){$vers{$version_package}=$self->_evaluate_version_line($version_sigil,$version_fullname,$line)}}elsif ($package eq 'main' && $version_fullname &&!exists($vers{main})){$need_vers=0;my$v=$self->_evaluate_version_line($version_sigil,$version_fullname,$line);$vers{$package}=$v;push(@packages,'main')}elsif ($package eq 'main' &&!exists($vers{main})&& $line =~ /\w/){$need_vers=1;$vers{main}='';push(@packages,'main')}elsif ($version_fullname && $need_vers){$need_vers=0;my$v=$self->_evaluate_version_line($version_sigil,$version_fullname,$line);unless (defined$vers{$package}&& length$vers{$package}){$vers{$package}=$v}}}}if ($self->{collect_pod}&& length($pod_data)){$pod{$pod_sect}=$pod_data}$self->{versions}=\%vers;$self->{packages}=\@packages;$self->{pod}=\%pod;$self->{pod_headings}=\@pod}{my$pn=0;sub _evaluate_version_line {my$self=shift;my($sigil,$variable_name,$line)=@_;$pn++;my$eval=qq{ my \$dummy = q# Hide from _packages_inside() #; package Module::Metadata::_version::p${pn}; use version; sub { local $sigil$variable_name; $line; \$$variable_name }; };$eval=$1 if$eval =~ m{^(.+)}s;local $^W;my$vsub=__clean_eval($eval);if ($@ =~ /Can't locate/ && -d 'lib'){local@INC=('lib',@INC);$vsub=__clean_eval($eval)}warn "Error evaling version line '$eval' in $self->{filename}: $@\n" if $@;(ref($vsub)eq 'CODE')or croak "failed to build version sub for $self->{filename}";my$result=eval {$vsub->()};croak "Could not get version from $self->{filename} by executing:\n$eval\n\nThe fatal error was: $@\n" if $@;my$version=eval {_dwim_version($result)};croak "Version '$result' from $self->{filename} does not appear to be valid:\n$eval\n\nThe fatal error was: $@\n" unless defined$version;return$version}}{my@version_prep=(sub {return shift},sub {my$v=shift;$v =~ s{([0-9])[a-z-].*$}{$1}i;return$v},sub {my$v=shift;my$num_dots=()=$v =~ m{(\.)}g;my$num_unders=()=$v =~ m{(_)}g;my$leading_v=substr($v,0,1)eq 'v';if (!$leading_v && $num_dots < 2 && $num_unders > 1){$v =~ s{_}{}g;$num_unders=()=$v =~ m{(_)}g}return$v},sub {my$v=shift;no warnings 'numeric';return 0 + $v},);sub _dwim_version {my ($result)=shift;return$result if ref($result)eq 'version';my ($version,$error);for my$f (@version_prep){$result=$f->($result);$version=eval {version->new($result)};$error ||= $@ if $@;last if defined$version}croak$error unless defined$version;return$version}}sub name {$_[0]->{module}}sub filename {$_[0]->{filename}}sub packages_inside {@{$_[0]->{packages}}}sub pod_inside {@{$_[0]->{pod_headings}}}sub contains_pod {0+@{$_[0]->{pod_headings}}}sub version {my$self=shift;my$mod=shift || $self->{module};my$vers;if (defined($mod)&& length($mod)&& exists($self->{versions}{$mod})){return$self->{versions}{$mod}}else {return undef}}sub pod {my$self=shift;my$sect=shift;if (defined($sect)&& length($sect)&& exists($self->{pod}{$sect})){return$self->{pod}{$sect}}else {return undef}}sub is_indexable {my ($self,$package)=@_;my@indexable_packages=grep {$_ ne 'main'}$self->packages_inside;return!!grep {$_ eq $package}@indexable_packages if$package;return!!@indexable_packages}1; MODULE_METADATA $fatpacked{"Parse/CPAN/Meta.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PARSE_CPAN_META'; use 5.008001;use strict;package Parse::CPAN::Meta;our$VERSION='1.4414';use Exporter;use Carp 'croak';our@ISA=qw/Exporter/;our@EXPORT_OK=qw/Load LoadFile/;sub load_file {my ($class,$filename)=@_;my$meta=_slurp($filename);if ($filename =~ /\.ya?ml$/){return$class->load_yaml_string($meta)}elsif ($filename =~ /\.json$/){return$class->load_json_string($meta)}else {$class->load_string($meta)}}sub load_string {my ($class,$string)=@_;if ($string =~ /^---/){return$class->load_yaml_string($string)}elsif ($string =~ /^\s*\{/){return$class->load_json_string($string)}else {return$class->load_yaml_string($string)}}sub load_yaml_string {my ($class,$string)=@_;my$backend=$class->yaml_backend();my$data=eval {no strict 'refs';&{"$backend\::Load"}($string)};croak $@ if $@;return$data || {}}sub load_json_string {my ($class,$string)=@_;my$data=eval {$class->json_backend()->new->decode($string)};croak $@ if $@;return$data || {}}sub yaml_backend {if (!defined$ENV{PERL_YAML_BACKEND}){_can_load('CPAN::Meta::YAML',0.011)or croak "CPAN::Meta::YAML 0.011 is not available\n";return "CPAN::Meta::YAML"}else {my$backend=$ENV{PERL_YAML_BACKEND};_can_load($backend)or croak "Could not load PERL_YAML_BACKEND '$backend'\n";$backend->can("Load")or croak "PERL_YAML_BACKEND '$backend' does not implement Load()\n";return$backend}}sub json_backend {if (!$ENV{PERL_JSON_BACKEND}or $ENV{PERL_JSON_BACKEND}eq 'JSON::PP'){_can_load('JSON::PP'=>2.27103)or croak "JSON::PP 2.27103 is not available\n";return 'JSON::PP'}else {_can_load('JSON'=>2.5)or croak "JSON 2.5 is required for " ."\$ENV{PERL_JSON_BACKEND} = '$ENV{PERL_JSON_BACKEND}'\n";return "JSON"}}sub _slurp {require Encode;open my$fh,"<:raw","$_[0]" or die "can't open $_[0] for reading: $!";my$content=do {local $/;<$fh>};$content=Encode::decode('UTF-8',$content,Encode::PERLQQ());return$content}sub _can_load {my ($module,$version)=@_;(my$file=$module)=~ s{::}{/}g;$file .= ".pm";return 1 if$INC{$file};return 0 if exists$INC{$file};eval {require$file;1}or return 0;if (defined$version){eval {$module->VERSION($version);1}or return 0}return 1}sub LoadFile ($) {return Load(_slurp(shift))}sub Load ($) {require CPAN::Meta::YAML;my$object=eval {CPAN::Meta::YAML::Load(shift)};croak $@ if $@;return$object}1; PARSE_CPAN_META $fatpacked{"Parse/PMFile.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PARSE_PMFILE'; package Parse::PMFile;sub __clean_eval {eval $_[0]}use strict;use warnings;use Safe;use JSON::PP ();use Dumpvalue;use version ();use File::Spec ();our$VERSION='0.36';our$VERBOSE=0;our$ALLOW_DEV_VERSION=0;our$FORK=0;our$UNSAFE=$] < 5.010000 ? 1 : 0;sub new {my ($class,$meta,$opts)=@_;bless {%{$opts || {}},META_CONTENT=>$meta},$class}sub parse {my ($self,$pmfile)=@_;$pmfile =~ s|\\|/|g;my($filemtime)=(stat$pmfile)[9];$self->{MTIME}=$filemtime;$self->{PMFILE}=$pmfile;unless ($self->_version_from_meta_ok){my$version;unless (eval {$version=$self->_parse_version;1}){$self->_verbose(1,"error with version in $pmfile: $@");return}$self->{VERSION}=$version;if ($self->{VERSION}=~ /^\{.*\}$/){}elsif ($self->{VERSION}=~ /[_\s]/ &&!$self->{ALLOW_DEV_VERSION}&&!$ALLOW_DEV_VERSION){return}}my($ppp)=$self->_packages_per_pmfile;my@keys_ppp=$self->_filter_ppps(sort keys %$ppp);$self->_verbose(1,"Will check keys_ppp[@keys_ppp]\n");my ($package,%errors);my%checked_in;DBPACK: foreach$package (@keys_ppp){if ($package !~ /^\w[\w\:\']*\w?\z/ || $package !~ /\w\z/ || $package =~ /:/ && $package !~ /::/ || $package =~ /\w:\w/ || $package =~ /:::/){$self->_verbose(1,"Package[$package] did not pass the ultimate sanity check");delete$ppp->{$package};next}if ($self->{USERID}&& $self->{PERMISSIONS}&&!$self->_perm_check($package)){delete$ppp->{$package};next}{my (undef,$module)=split m{/lib/},$self->{PMFILE},2;if ($module){$module =~ s{\.pm\z}{};$module =~ s{/}{::}g;if (lc$module eq lc$package && $module ne $package){$errors{$package}={indexing_warning=>"Capitalization of package ($package) does not match filename!",infile=>$self->{PMFILE},}}}}my$pp=$ppp->{$package};if ($pp->{version}&& $pp->{version}=~ /^\{.*\}$/){my$err=JSON::PP::decode_json($pp->{version});if ($err->{x_normalize}){$errors{$package}={normalize=>$err->{version},infile=>$pp->{infile},};$pp->{version}="undef"}elsif ($err->{openerr}){$pp->{version}="undef";$self->_verbose(1,qq{Parse::PMFile was not able to 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},}}}for ($package,$pp->{version},){if (!defined || /^\s*$/ || /\s/){delete$ppp->{$package};next}}$checked_in{$package}=$ppp->{$package}}return (wantarray && %errors)? (\%checked_in,\%errors): \%checked_in}sub _perm_check {my ($self,$package)=@_;my$userid=$self->{USERID};my$module=$self->{PERMISSIONS}->module_permissions($package);return 1 if!$module;return 1 if defined$module->m && $module->m eq $userid;return 1 if defined$module->f && $module->f eq $userid;return 1 if defined$module->c && grep {$_ eq $userid}@{$module->c};return}sub _parse_version {my$self=shift;use strict;my$pmfile=$self->{PMFILE};my$tmpfile=File::Spec->catfile(File::Spec->tmpdir,"ParsePMFile$$" .rand(1000));my$pmcp=$pmfile;for ($pmcp){s/([^\\](\\\\)*)@/$1\\@/g}my($v);{package main;my$pid;if ($self->{FORK}|| $FORK){$pid=fork();die "Can't fork: $!" unless defined$pid}if ($pid){waitpid($pid,0);if (open my$fh,'<',$tmpfile){$v=<$fh>}}else {my($comp)=Safe->new;my$eval=qq{ local(\$^W) = 0; Parse::PMFile::_parse_version_safely("$pmcp"); };$comp->permit("entereval");$comp->share("*Parse::PMFile::_parse_version_safely");$comp->share("*version::new");$comp->share("*version::numify");$comp->share_from('main',['*version::','*charstar::','*Exporter::','*DynaLoader::']);$comp->share_from('version',['&qv']);$comp->permit(":base_math");$comp->deny(qw/enteriter iter unstack goto/);version->import('qv')if$self->{UNSAFE}|| $UNSAFE;{no strict;$v=($self->{UNSAFE}|| $UNSAFE)? eval$eval : $comp->reval($eval)}if ($@){my$err=$@;if (ref$err){if ($err->{line}=~ /([\$*])([\w\:\']*)\bVERSION\b.*?\=(.*)/){local($^W)=0;my ($sigil,$vstr)=($1,$3);$self->_restore_overloaded_stuff(1)if$err->{line}=~ /use\s+version\b|version\->|qv\(/;$v=($self->{UNSAFE}|| $UNSAFE)? eval$vstr : $comp->reval($vstr);$v=$$v if$sigil eq '*' && ref$v}if ($@ or!$v){$self->_verbose(1,sprintf("reval failed: err[%s] for eval[%s]",JSON::PP::encode_json($err),$eval,));$v=JSON::PP::encode_json($err)}}else {$v=JSON::PP::encode_json({openerr=>$err })}}if (defined$v){$v=$v->numify if ref($v)=~ /^version(::vpp)?$/}else {$v=""}if ($self->{FORK}|| $FORK){open my$fh,'>:utf8',$tmpfile;print$fh $v;exit 0}else {utf8::encode($v);$v=undef if defined$v &&!length$v;$comp->erase;$self->_restore_overloaded_stuff}}}unlink$tmpfile if ($self->{FORK}|| $FORK)&& -e $tmpfile;return$self->_normalize_version($v)}sub _restore_overloaded_stuff {my ($self,$used_version_in_safe)=@_;return if$self->{UNSAFE}|| $UNSAFE;no strict 'refs';no warnings 'redefine';my$restored;if ($INC{'version/vxs.pm'}){*{'version::(""'}=\&version::vxs::stringify;*{'version::(0+'}=\&version::vxs::numify;*{'version::(cmp'}=\&version::vxs::VCMP;*{'version::(<=>'}=\&version::vxs::VCMP;*{'version::(bool'}=\&version::vxs::boolean;$restored=1}if ($INC{'version/vpp.pm'}){{package charstar;overload->import}if (!$used_version_in_safe){package version::vpp;overload->import}unless ($restored){*{'version::(""'}=\&version::vpp::stringify;*{'version::(0+'}=\&version::vpp::numify;*{'version::(cmp'}=\&version::vpp::vcmp;*{'version::(<=>'}=\&version::vpp::vcmp;*{'version::(bool'}=\&version::vpp::vbool}*{'version::vpp::(""'}=\&version::vpp::stringify;*{'version::vpp::(0+'}=\&version::vpp::numify;*{'version::vpp::(cmp'}=\&version::vpp::vcmp;*{'version::vpp::(<=>'}=\&version::vpp::vcmp;*{'version::vpp::(bool'}=\&version::vpp::vbool;*{'charstar::(""'}=\&charstar::thischar;*{'charstar::(0+'}=\&charstar::thischar;*{'charstar::(++'}=\&charstar::increment;*{'charstar::(--'}=\&charstar::decrement;*{'charstar::(+'}=\&charstar::plus;*{'charstar::(-'}=\&charstar::minus;*{'charstar::(*'}=\&charstar::multiply;*{'charstar::(cmp'}=\&charstar::cmp;*{'charstar::(<=>'}=\&charstar::spaceship;*{'charstar::(bool'}=\&charstar::thischar;*{'charstar::(='}=\&charstar::clone;$restored=1}if (!$restored){*{'version::(""'}=\&version::stringify;*{'version::(0+'}=\&version::numify;*{'version::(cmp'}=\&version::vcmp;*{'version::(<=>'}=\&version::vcmp;*{'version::(bool'}=\&version::boolean}}sub _packages_per_pmfile {my$self=shift;my$ppp={};my$pmfile=$self->{PMFILE};my$filemtime=$self->{MTIME};my$version=$self->{VERSION};open my$fh,"<","$pmfile" or return$ppp;local $/="\n";my$inpod=0;PLINE: while (<$fh>){chomp;my($pline)=$_;$inpod=$pline =~ /^=(?!cut)/ ? 1 : $pline =~ /^=cut/ ? 0 : $inpod;next if$inpod;next if substr($pline,0,4)eq "=cut";$pline =~ s/\#.*//;next if$pline =~ /^\s*$/;if ($pline =~ /^__(?:END|DATA)__\b/ and $pmfile !~ /\.PL$/){last PLINE}my$pkg;my$strict_version;if ($pline =~ m{ # (.*) # 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"){next PLINE}}if ($pkg){$pkg =~ s/\'/::/;next PLINE unless$pkg =~ /^[A-Za-z]/;next PLINE unless$pkg =~ /\w$/;next PLINE if$pkg eq "main";next PLINE if length($pkg)> 128;$ppp->{$pkg}{parsed}++;$ppp->{$pkg}{infile}=$pmfile;if ($self->_simile($pmfile,$pkg)){$ppp->{$pkg}{simile}=$pmfile;if ($self->_version_from_meta_ok){my$provides=$self->{META_CONTENT}{provides};if (exists$provides->{$pkg}){if (defined$provides->{$pkg}{version}){my$v=$provides->{$pkg}{version};if ($v =~ /[_\s]/ &&!$self->{ALLOW_DEV_VERSION}&&!$ALLOW_DEV_VERSION){next PLINE}unless (eval {$version=$self->_normalize_version($v);1}){$self->_verbose(1,"error with version in $pmfile: $@");next}$ppp->{$pkg}{version}=$version}else {$ppp->{$pkg}{version}="undef"}}}else {if (defined$strict_version){$ppp->{$pkg}{version}=$strict_version }else {$ppp->{$pkg}{version}=defined$version ? $version : ""}no warnings;if ($version eq 'undef'){$ppp->{$pkg}{version}=$version unless defined$ppp->{$pkg}{version}}else {$ppp->{$pkg}{version}=$version if$version > $ppp->{$pkg}{version}|| $version gt $ppp->{$pkg}{version}}}}else {$ppp->{$pkg}{version}=$version unless defined$ppp->{$pkg}{version}&& length($ppp->{$pkg}{version})}$ppp->{$pkg}{filemtime}=$filemtime}else {}}close$fh;$ppp}{no strict;sub _parse_version_safely {my($parsefile)=@_;my$result;local*FH;local $/="\n";open(FH,$parsefile)or die "Could not open '$parsefile': $!";my$inpod=0;while (<FH>){$inpod=/^=(?!cut)/ ? 1 : /^=cut/ ? 0 : $inpod;next if$inpod || /^\s*#/;last if /^__(?:END|DATA)__\b/;chop;if (my ($ver)=/package \s+ \S+ \s+ (\S+) \s* [;{]/x){return$ver if version::is_lax($ver)}next unless /(?<!\\)([\$*])(([\w\:\']*)\bVERSION)\b.*(?<![!><=])\=(?![=>])/;my$current_parsed_line=$_;my$eval=qq{ package # ExtUtils::MakeMaker::_version; local $1$2; \$$2=undef; do { $_ }; \$$2 };local $^W=0;local$SIG{__WARN__}=sub {};$result=__clean_eval($eval);if ($@ or!defined$result){die +{eval=>$eval,line=>$current_parsed_line,file=>$parsefile,err=>$@,}}last}close FH;$result="undef" unless defined$result;if ((ref$result)=~ /^version(?:::vpp)?\b/){$result=$result->numify}return$result}}sub _filter_ppps {my($self,@ppps)=@_;my@res;MANI: for my$ppp (@ppps){if ($self->{META_CONTENT}){my$no_index=$self->{META_CONTENT}{no_index}|| $self->{META_CONTENT}{private};if (ref($no_index)eq 'HASH'){my%map=(package=>qr{\z},namespace=>qr{::},);for my$k (qw(package namespace)){next unless my$v=$no_index->{$k};my$rest=$map{$k};if (ref$v eq "ARRAY"){for my$ve (@$v){$ve =~ s|::$||;if ($ppp =~ /^$ve$rest/){$self->_verbose(1,"Skipping ppp[$ppp] due to ve[$ve]");next MANI}else {$self->_verbose(1,"NOT skipping ppp[$ppp] due to ve[$ve]")}}}else {$v =~ s|::$||;if ($ppp =~ /^$v$rest/){$self->_verbose(1,"Skipping ppp[$ppp] due to v[$v]");next MANI}else {$self->_verbose(1,"NOT skipping ppp[$ppp] due to v[$v]")}}}}else {$self->_verbose(1,"No keyword 'no_index' or 'private' in META_CONTENT")}}else {}push@res,$ppp}$self->_verbose(1,"Result of filter_ppps: res[@res]");@res}sub _simile {my($self,$file,$package)=@_;$file =~ s|.*/||;$file =~ s|\.pm(?:\.PL)?||;my$ret=$package =~ m/\b\Q$file\E$/;$ret ||= 0;unless ($ret){$ret=1 if lc$file eq 'version'}$self->_verbose(1,"Result of simile(): file[$file] package[$package] ret[$ret]\n");$ret}sub _normalize_version {my($self,$v)=@_;$v="undef" unless defined$v;my$dv=Dumpvalue->new;my$sdv=$dv->stringify($v,1);$self->_verbose(1,"Result of normalize_version: sdv[$sdv]\n");return$v if$v eq "undef";return$v if$v =~ /^\{.*\}$/;$v =~ s/^\s+//;$v =~ s/\s+\z//;if ($v =~ /_/){return$v }if (!version::is_lax($v)){return JSON::PP::encode_json({x_normalize=>'version::is_lax failed',version=>$v })}my$vv=eval {no warnings;version->new($v)->numify};if ($@){return JSON::PP::encode_json({x_normalize=>$@,version=>$v })}if ($vv eq $v){}else {my$forced=$self->_force_numeric($v);if ($forced eq $vv){}elsif ($forced =~ /^v(.+)/){$vv=version->new($1)->numify}else {if ($forced==$vv){$vv=$forced}}}return$vv}sub _force_numeric {my($self,$v)=@_;$v=$self->_readable($v);if ($v =~ /^(\+?)(\d*)(\.(\d*))?/ && (defined $2 && length $2 || defined $4 && length $4)){my$two=defined $2 ? $2 : "";my$three=defined $3 ? $3 : "";$v="$two$three"}$v}sub _version_from_meta_ok {my($self)=@_;return$self->{VERSION_FROM_META_OK}if exists$self->{VERSION_FROM_META_OK};my$c=$self->{META_CONTENT};return($self->{VERSION_FROM_META_OK}=0)unless$c->{provides};my ($mb_v)=(defined$c->{generated_by}? $c->{generated_by}: '')=~ /Module::Build version ([\d\.]+)/;return($self->{VERSION_FROM_META_OK}=1)unless$mb_v;return($self->{VERSION_FROM_META_OK}=1)if$mb_v eq '0.250.0';if ($mb_v >= 0.19 && $mb_v < 0.26 &&!keys %{$c->{provides}}){return($self->{VERSION_FROM_META_OK}=0)}return($self->{VERSION_FROM_META_OK}=1)}sub _verbose {my($self,$level,@what)=@_;warn@what if$level <= ((ref$self && $self->{VERBOSE})|| $VERBOSE)}sub _vcmp {my($self,$l,$r)=@_;local($^W)=0;$self->_verbose(9,"l[$l] r[$r]");return 0 if$l eq $r;for ($l,$r){s/_//g}$self->_verbose(9,"l[$l] r[$r]");for ($l,$r){next unless tr/.// > 1 || /^v/;s/^v?/v/;1 while s/\.0+(\d)/.$1/}$self->_verbose(9,"l[$l] r[$r]");if ($l=~/^v/ <=> $r=~/^v/){for ($l,$r){next if /^v/;$_=$self->_float2vv($_)}}$self->_verbose(9,"l[$l] r[$r]");my$lvstring="v0";my$rvstring="v0";if ($] >= 5.006 && $l =~ /^v/ && $r =~ /^v/){$lvstring=$self->_vstring($l);$rvstring=$self->_vstring($r);$self->_verbose(9,sprintf "lv[%vd] rv[%vd]",$lvstring,$rvstring)}return (($l ne "undef")<=> ($r ne "undef")|| $lvstring cmp $rvstring || $l <=> $r || $l cmp $r)}sub _vgt {my($self,$l,$r)=@_;$self->_vcmp($l,$r)> 0}sub _vlt {my($self,$l,$r)=@_;$self->_vcmp($l,$r)< 0}sub _vge {my($self,$l,$r)=@_;$self->_vcmp($l,$r)>= 0}sub _vle {my($self,$l,$r)=@_;$self->_vcmp($l,$r)<= 0}sub _vstring {my($self,$n)=@_;$n =~ s/^v// or die "Parse::PMFile::_vstring() called with invalid arg [$n]";pack "U*",split /\./,$n}sub _float2vv {my($self,$n)=@_;my($rev)=int($n);$rev ||= 0;my($mantissa)=$n =~ /\.(\d{1,12})/;$mantissa ||= 0;$mantissa .= "0" while length($mantissa)%3;my$ret="v" .$rev;while ($mantissa){$mantissa =~ s/(\d{1,3})// or die "Panic: length>0 but not a digit? mantissa[$mantissa]";$ret .= ".".int($1)}$ret =~ s/(\.0)+/.0/;$ret}sub _readable {my($self,$n)=@_;$n =~ /^([\w\-\+\.]+)/;return $1 if defined $1 && length($1)>0;if ($] < 5.006){$self->_verbose(9,"Suspicious version string seen [$n]\n");return$n}my$better=sprintf "v%vd",$n;$self->_verbose(9,"n[$n] better[$better]");return$better}1; PARSE_PMFILE $fatpacked{"String/ShellQuote.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'STRING_SHELLQUOTE'; package String::ShellQuote;use strict;use vars qw($VERSION @ISA @EXPORT);require Exporter;$VERSION='1.04';@ISA=qw(Exporter);@EXPORT=qw(shell_quote shell_quote_best_effort shell_comment_quote);sub croak {require Carp;goto&Carp::croak}sub _shell_quote_backend {my@in=@_;my@err=();if (0){require RS::Handy;print RS::Handy::data_dump(\@in)}return \@err,'' unless@in;my$ret='';my$saw_non_equal=0;for (@in){if (!defined $_ or $_ eq ''){$_="''";next}if (s/\x00//g){push@err,"No way to quote string containing null (\\000) bytes"}my$escape=0;if (/=/){if (!$saw_non_equal){$escape=1}}else {$saw_non_equal=1}if (m|[^\w!%+,\-./:=@^]|){$escape=1}if ($escape || (!$saw_non_equal && /=/)){s/'/'\\''/g;s|((?:'\\''){2,})|q{'"} . (q{'} x (length($1) / 4)) . q{"'}|ge;$_="'$_'";s/^''//;s/''$//}}continue {$ret .= "$_ "}chop$ret;return \@err,$ret}sub shell_quote {my ($rerr,$s)=_shell_quote_backend @_;if (@$rerr){my%seen;@$rerr=grep {!$seen{$_}++}@$rerr;my$s=join '',map {"shell_quote(): $_\n"}@$rerr;chomp$s;croak$s}return$s}sub shell_quote_best_effort {my ($rerr,$s)=_shell_quote_backend @_;return$s}sub shell_comment_quote {return '' unless @_;unless (@_==1){croak "Too many arguments to shell_comment_quote " ."(got " .@_ ." expected 1)"}local $_=shift;s/\n/\n#/g;return $_}1; STRING_SHELLQUOTE $fatpacked{"lib/core/only.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LIB_CORE_ONLY'; package lib::core::only;use strict;use warnings FATAL=>'all';use Config;sub import {@INC=@Config{qw(privlibexp archlibexp)};return}1; LIB_CORE_ONLY $fatpacked{"local/lib.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'LOCAL_LIB'; package local::lib;use 5.006;use strict;use warnings;use Config;our$VERSION='2.000015';$VERSION=eval$VERSION;BEGIN {*_WIN32=($^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'symbian')? sub(){1}: sub(){0};*_USE_FSPEC=($^O eq 'MacOS' || $^O eq 'VMS' || $INC{'File/Spec.pm'})? sub(){1}: sub(){0}}our$_DIR_JOIN=_WIN32 ? '\\' : '/';our$_DIR_SPLIT=(_WIN32 || $^O eq 'cygwin')? qr{[\\/]} : qr{/};our$_ROOT=_WIN32 ? do {my$UNC=qr{[\\/]{2}[^\\/]+[\\/][^\\/]+};qr{^(?:$UNC|[A-Za-z]:|)$_DIR_SPLIT}}: qr{^/};our$_PERL;sub _cwd {my$drive=shift;if (!$_PERL){($_PERL)=$^X =~ /(.+)/;if (_is_abs($_PERL)){}elsif (-x $Config{perlpath}){$_PERL=$Config{perlpath}}else {($_PERL)=map {/(.*)/}grep {-x $_}map {join($_DIR_JOIN,$_,$_PERL)}split /\Q$Config{path_sep}\E/,$ENV{PATH}}}local@ENV{qw(PATH IFS CDPATH ENV BASH_ENV)};my$cmd=$drive ? "eval { Cwd::getdcwd(q($drive)) }" : 'getcwd';my$cwd=`"$_PERL" -MCwd -le "print $cmd"`;chomp$cwd;if (!length$cwd && $drive){$cwd=$drive}$cwd =~ s/$_DIR_SPLIT?$/$_DIR_JOIN/;$cwd}sub _catdir {if (_USE_FSPEC){require File::Spec;File::Spec->catdir(@_)}else {my$dir=join($_DIR_JOIN,@_);$dir =~ s{($_DIR_SPLIT)(?:\.?$_DIR_SPLIT)+}{$1}g;$dir}}sub _is_abs {if (_USE_FSPEC){require File::Spec;File::Spec->file_name_is_absolute($_[0])}else {$_[0]=~ $_ROOT}}sub _rel2abs {my ($dir,$base)=@_;return$dir if _is_abs($dir);$base=_WIN32 && $dir =~ s/^([A-Za-z]:)// ? _cwd("$1"): $base ? $base : _cwd;return _catdir($base,$dir)}sub import {my ($class,@args)=@_;push@args,@ARGV if $0 eq '-';my@steps;my%opts;my$shelltype;while (@args){my$arg=shift@args;if ($arg =~ /\xE2\x88\x92/ or $arg =~ /−/){die <<'DEATH'}elsif ($arg eq '--self-contained'){die <<'DEATH'}elsif($arg =~ /^--deactivate(?:=(.*))?$/){my$path=defined $1 ? $1 : shift@args;push@steps,['deactivate',$path]}elsif ($arg eq '--deactivate-all'){push@steps,['deactivate_all']}elsif ($arg =~ /^--shelltype(?:=(.*))?$/){$shelltype=defined $1 ? $1 : shift@args}elsif ($arg eq '--no-create'){$opts{no_create}=1}elsif ($arg =~ /^--/){die "Unknown import argument: $arg"}else {push@steps,['activate',$arg]}}if (!@steps){push@steps,['activate',undef]}my$self=$class->new(%opts);for (@steps){my ($method,@args)=@$_;$self=$self->$method(@args)}if ($0 eq '-'){print$self->environment_vars_string($shelltype);exit 0}else {$self->setup_local_lib}}sub new {my$class=shift;bless {@_},$class}sub clone {my$self=shift;bless {%$self,@_},ref$self}sub inc {$_[0]->{inc}||= \@INC}sub libs {$_[0]->{libs}||= [\'PERL5LIB' ]}sub bins {$_[0]->{bins}||= [\'PATH' ]}sub roots {$_[0]->{roots}||= [\'PERL_LOCAL_LIB_ROOT' ]}sub extra {$_[0]->{extra}||= {}}sub no_create {$_[0]->{no_create}}my$_archname=$Config{archname};my$_version=$Config{version};my@_inc_version_list=reverse split / /,$Config{inc_version_list};my$_path_sep=$Config{path_sep};sub _as_list {my$list=shift;grep length,map {!(ref $_ && ref $_ eq 'SCALAR')? $_ : (defined$ENV{$$_}? split(/\Q$_path_sep/,$ENV{$$_}): ())}ref$list ? @$list : $list}sub _remove_from {my ($list,@remove)=@_;return @$list if!@remove;my%remove=map {$_=>1}@remove;grep!$remove{$_},_as_list($list)}my@_lib_subdirs=([$_version,$_archname],[$_version],[$_archname],(@_inc_version_list ? \@_inc_version_list : ()),[],);sub install_base_bin_path {my ($class,$path)=@_;return _catdir($path,'bin')}sub install_base_perl_path {my ($class,$path)=@_;return _catdir($path,'lib','perl5')}sub install_base_arch_path {my ($class,$path)=@_;_catdir($class->install_base_perl_path($path),$_archname)}sub lib_paths_for {my ($class,$path)=@_;my$base=$class->install_base_perl_path($path);return map {_catdir($base,@$_)}@_lib_subdirs}sub _mm_escape_path {my$path=shift;$path =~ s/\\/\\\\/g;if ($path =~ s/ /\\ /g){$path=qq{"$path"}}return$path}sub _mb_escape_path {my$path=shift;$path =~ s/\\/\\\\/g;return qq{"$path"}}sub installer_options_for {my ($class,$path)=@_;return (PERL_MM_OPT=>defined$path ? "INSTALL_BASE="._mm_escape_path($path): undef,PERL_MB_OPT=>defined$path ? "--install_base "._mb_escape_path($path): undef,)}sub active_paths {my ($self)=@_;$self=ref$self ? $self : $self->new;return grep {my$active_ll=$self->install_base_perl_path($_);grep {$_ eq $active_ll}@{$self->inc}}_as_list($self->roots)}sub deactivate {my ($self,$path)=@_;$self=$self->new unless ref$self;$path=$self->resolve_path($path);$path=$self->normalize_path($path);my@active_lls=$self->active_paths;if (!grep {$_ eq $path}@active_lls){warn "Tried to deactivate inactive local::lib '$path'\n";return$self}my%args=(bins=>[_remove_from($self->bins,$self->install_base_bin_path($path))],libs=>[_remove_from($self->libs,$self->install_base_perl_path($path))],inc=>[_remove_from($self->inc,$self->lib_paths_for($path))],roots=>[_remove_from($self->roots,$path)],);$args{extra}={$self->installer_options_for($args{roots}[0])};$self->clone(%args)}sub deactivate_all {my ($self)=@_;$self=$self->new unless ref$self;my@active_lls=$self->active_paths;my%args;if (@active_lls){%args=(bins=>[_remove_from($self->bins,map$self->install_base_bin_path($_),@active_lls)],libs=>[_remove_from($self->libs,map$self->install_base_perl_path($_),@active_lls)],inc=>[_remove_from($self->inc,map$self->lib_paths_for($_),@active_lls)],roots=>[_remove_from($self->roots,@active_lls)],)}$args{extra}={$self->installer_options_for(undef)};$self->clone(%args)}sub activate {my ($self,$path)=@_;$self=$self->new unless ref$self;$path=$self->resolve_path($path);$self->ensure_dir_structure_for($path)unless$self->no_create;$path=$self->normalize_path($path);my@active_lls=$self->active_paths;if (grep {$_ eq $path}@active_lls[1 .. $#active_lls]){$self=$self->deactivate($path)}my%args;if (!@active_lls || $active_lls[0]ne $path){%args=(bins=>[$self->install_base_bin_path($path),@{$self->bins}],libs=>[$self->install_base_perl_path($path),@{$self->libs}],inc=>[$self->lib_paths_for($path),@{$self->inc}],roots=>[$path,@{$self->roots}],)}$args{extra}={$self->installer_options_for($path)};$self->clone(%args)}sub normalize_path {my ($self,$path)=@_;$path=(Win32::GetShortPathName($path)|| $path)if $^O eq 'MSWin32';return$path}sub build_environment_vars_for {my$self=$_[0]->new->activate($_[1]);$self->build_environment_vars}sub build_activate_environment_vars_for {my$self=$_[0]->new->activate($_[1]);$self->build_environment_vars}sub build_deactivate_environment_vars_for {my$self=$_[0]->new->deactivate($_[1]);$self->build_environment_vars}sub build_deact_all_environment_vars_for {my$self=$_[0]->new->deactivate_all;$self->build_environment_vars}sub build_environment_vars {my$self=shift;(PATH=>join($_path_sep,_as_list($self->bins)),PERL5LIB=>join($_path_sep,_as_list($self->libs)),PERL_LOCAL_LIB_ROOT=>join($_path_sep,_as_list($self->roots)),%{$self->extra},)}sub setup_local_lib_for {my$self=$_[0]->new->activate($_[1]);$self->setup_local_lib}sub setup_local_lib {my$self=shift;require Carp::Heavy if$INC{'Carp.pm'};$self->setup_env_hash;@INC=@{$self->inc}}sub setup_env_hash_for {my$self=$_[0]->new->activate($_[1]);$self->setup_env_hash}sub setup_env_hash {my$self=shift;my%env=$self->build_environment_vars;for my$key (keys%env){if (defined$env{$key}){$ENV{$key}=$env{$key}}else {delete$ENV{$key}}}}sub print_environment_vars_for {print $_[0]->environment_vars_string_for(@_[1..$#_])}sub environment_vars_string_for {my$self=$_[0]->new->activate($_[1]);$self->environment_vars_string}sub environment_vars_string {my ($self,$shelltype)=@_;$shelltype ||= $self->guess_shelltype;my$extra=$self->extra;my@envs=(PATH=>$self->bins,PERL5LIB=>$self->libs,PERL_LOCAL_LIB_ROOT=>$self->roots,map {$_=>$extra->{$_}}sort keys %$extra,);$self->_build_env_string($shelltype,\@envs)}sub _build_env_string {my ($self,$shelltype,$envs)=@_;my@envs=@$envs;my$build_method="build_${shelltype}_env_declaration";my$out='';while (@envs){my ($name,$value)=(shift(@envs),shift(@envs));if (ref$value && @$value==1 && ref$value->[0]&& ref$value->[0]eq 'SCALAR' && ${$value->[0]}eq $name){next}$out .= $self->$build_method($name,$value)}my$wrap_method="wrap_${shelltype}_output";if ($self->can($wrap_method)){return$self->$wrap_method($out)}return$out}sub build_bourne_env_declaration {my ($class,$name,$args)=@_;my$value=$class->_interpolate($args,'${%s}',qr/["\\\$!`]/,'\\%s');if (!defined$value){return qq{unset $name;\n}}$value =~ s/(^|\G|$_path_sep)\$\{$name\}$_path_sep/$1\${$name}\${$name+$_path_sep}/g;$value =~ s/$_path_sep\$\{$name\}$/\${$name+$_path_sep}\${$name}/;qq{${name}="$value"; export ${name};\n}}sub build_csh_env_declaration {my ($class,$name,$args)=@_;my ($value,@vars)=$class->_interpolate($args,'${%s}','"','"\\%s"');if (!defined$value){return qq{unsetenv $name;\n}}my$out='';for my$var (@vars){$out .= qq{if ! \$?$name setenv $name '';\n}}my$value_without=$value;if ($value_without =~ s/(?:^|$_path_sep)\$\{$name\}(?:$_path_sep|$)//g){$out .= qq{if "\${$name}" != '' setenv $name "$value";\n};$out .= qq{if "\${$name}" == '' }}$out .= qq{setenv $name "$value_without";\n};return$out}sub build_cmd_env_declaration {my ($class,$name,$args)=@_;my$value=$class->_interpolate($args,'%%%s%%',qr(%),'%s');if (!$value){return qq{\@set $name=\n}}my$out='';my$value_without=$value;if ($value_without =~ s/(?:^|$_path_sep)%$name%(?:$_path_sep|$)//g){$out .= qq{\@if not "%$name%"=="" set "$name=$value"\n};$out .= qq{\@if "%$name%"=="" }}$out .= qq{\@set "$name=$value_without"\n};return$out}sub build_powershell_env_declaration {my ($class,$name,$args)=@_;my$value=$class->_interpolate($args,'$env:%s','"','`%s');if (!$value){return qq{Remove-Item -ErrorAction 0 Env:\\$name;\n}}my$maybe_path_sep=qq{\$(if("\$env:$name"-eq""){""}else{"$_path_sep"})};$value =~ s/(^|\G|$_path_sep)\$env:$name$_path_sep/$1\$env:$name"+$maybe_path_sep+"/g;$value =~ s/$_path_sep\$env:$name$/"+$maybe_path_sep+\$env:$name+"/;qq{\$env:$name = \$("$value");\n}}sub wrap_powershell_output {my ($class,$out)=@_;return$out || " \n"}sub build_fish_env_declaration {my ($class,$name,$args)=@_;my$value=$class->_interpolate($args,'$%s',qr/[\\"' ]/,'\\%s');if (!defined$value){return qq{set -e $name;\n}}$value =~ s/$_path_sep/ /g;qq{set -x $name $value;\n}}sub _interpolate {my ($class,$args,$var_pat,$escape,$escape_pat)=@_;return unless defined$args;my@args=ref$args ? @$args : $args;return unless@args;my@vars=map {$$_}grep {ref $_ eq 'SCALAR'}@args;my$string=join$_path_sep,map {ref $_ eq 'SCALAR' ? sprintf($var_pat,$$_): do {s/($escape)/sprintf($escape_pat, $1)/ge;$_}}@args;return wantarray ? ($string,\@vars): $string}sub pipeline;sub pipeline {my@methods=@_;my$last=pop(@methods);if (@methods){\sub {my ($obj,@args)=@_;$obj->${pipeline@methods}($obj->$last(@args))}}else {\sub {shift->$last(@_)}}}sub resolve_path {my ($class,$path)=@_;$path=$class->${pipeline qw(resolve_relative_path resolve_home_path resolve_empty_path)}($path);$path}sub resolve_empty_path {my ($class,$path)=@_;if (defined$path){$path}else {'~/perl5'}}sub resolve_home_path {my ($class,$path)=@_;$path =~ /^~([^\/]*)/ or return$path;my$user=$1;my$homedir=do {if (!length($user)&& defined$ENV{HOME}){$ENV{HOME}}else {require File::Glob;File::Glob::bsd_glob("~$user",File::Glob::GLOB_TILDE())}};unless (defined$homedir){require Carp;require Carp::Heavy;Carp::croak("Couldn't resolve homedir for " .(defined$user ? $user : 'current user'))}$path =~ s/^~[^\/]*/$homedir/;$path}sub resolve_relative_path {my ($class,$path)=@_;_rel2abs($path)}sub ensure_dir_structure_for {my ($class,$path)=@_;unless (-d $path){warn "Attempting to create directory ${path}\n"}require File::Basename;my@dirs;while(!-d $path){push@dirs,$path;$path=File::Basename::dirname($path)}mkdir $_ for reverse@dirs;return}sub guess_shelltype {my$shellbin =defined$ENV{SHELL}? ($ENV{SHELL}=~ /([\w.]+)$/)[-1]: ($^O eq 'MSWin32' && exists$ENV{'!EXITCODE'})? 'bash' : ($^O eq 'MSWin32' && $ENV{PROMPT}&& $ENV{COMSPEC})? ($ENV{COMSPEC}=~ /([\w.]+)$/)[-1]: ($^O eq 'MSWin32' &&!$ENV{PROMPT})? 'powershell.exe' : 'sh';for ($shellbin){return /csh$/ ? 'csh' : /fish/ ? 'fish' : /command(?:\.com)?$/i ? 'cmd' : /cmd(?:\.exe)?$/i ? 'cmd' : /4nt(?:\.exe)?$/i ? 'cmd' : /powershell(?:\.exe)?$/i ? 'powershell' : 'bourne'}}1; 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 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 LOCAL_LIB $fatpacked{"parent.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'PARENT'; package parent;use strict;use vars qw($VERSION);$VERSION='0.228';sub import {my$class=shift;my$inheritor=caller(0);if (@_ and $_[0]eq '-norequire'){shift @_}else {for (my@filename=@_){if ($_ eq $inheritor){warn "Class '$inheritor' tried to inherit from itself\n"};s{::|'}{/}g;require "$_.pm"}}{no strict 'refs';push @{"$inheritor\::ISA"},@_}};"All your base are belong to us" PARENT $fatpacked{"version.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'VERSION'; package version;use 5.006002;use strict;use warnings::register;if ($] >= 5.015){warnings::register_categories(qw/version/)}use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv);$VERSION=0.9912;$CLASS='version';{local$SIG{'__DIE__'};if (1){eval "use version::vpp $VERSION";die "$@" if ($@);push@ISA,"version::vpp";local $^W;*version::qv=\&version::vpp::qv;*version::declare=\&version::vpp::declare;*version::_VERSION=\&version::vpp::_VERSION;*version::vcmp=\&version::vpp::vcmp;*version::new=\&version::vpp::new;*version::numify=\&version::vpp::numify;*version::normal=\&version::vpp::normal;if ($] >= 5.009000){no strict 'refs';*version::stringify=\&version::vpp::stringify;*{'version::(""'}=\&version::vpp::stringify;*{'version::(<=>'}=\&version::vpp::vcmp;*version::parse=\&version::vpp::parse}}else {push@ISA,"version::vxs";local $^W;*version::declare=\&version::vxs::declare;*version::qv=\&version::vxs::qv;*version::_VERSION=\&version::vxs::_VERSION;*version::vcmp=\&version::vxs::VCMP;*version::new=\&version::vxs::new;*version::numify=\&version::vxs::numify;*version::normal=\&version::vxs::normal;if ($] >= 5.009000){no strict 'refs';*version::stringify=\&version::vxs::stringify;*{'version::(""'}=\&version::vxs::stringify;*{'version::(<=>'}=\&version::vxs::VCMP;*version::parse=\&version::vxs::parse}}}require version::regex;*version::is_lax=\&version::regex::is_lax;*version::is_strict=\&version::regex::is_strict;*LAX=\$version::regex::LAX;*STRICT=\$version::regex::STRICT;sub import {no strict 'refs';my ($class)=shift;unless ($class eq $CLASS){local $^W;*{$class.'::declare'}=\&{$CLASS.'::declare'};*{$class.'::qv'}=\&{$CLASS.'::qv'}}my%args;if (@_){map {$args{$_}=1}@_}else {%args=(qv=>1,'UNIVERSAL::VERSION'=>1,)}my$callpkg=caller();if (exists($args{declare})){*{$callpkg.'::declare'}=sub {return$class->declare(shift)}unless defined(&{$callpkg.'::declare'})}if (exists($args{qv})){*{$callpkg.'::qv'}=sub {return$class->qv(shift)}unless defined(&{$callpkg.'::qv'})}if (exists($args{'UNIVERSAL::VERSION'})){local $^W;*UNIVERSAL::VERSION =\&{$CLASS.'::_VERSION'}}if (exists($args{'VERSION'})){*{$callpkg.'::VERSION'}=\&{$CLASS.'::_VERSION'}}if (exists($args{'is_strict'})){*{$callpkg.'::is_strict'}=\&{$CLASS.'::is_strict'}unless defined(&{$callpkg.'::is_strict'})}if (exists($args{'is_lax'})){*{$callpkg.'::is_lax'}=\&{$CLASS.'::is_lax'}unless defined(&{$callpkg.'::is_lax'})}}1; VERSION $fatpacked{"version/regex.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'VERSION_REGEX'; package version::regex;use strict;use vars qw($VERSION $CLASS $STRICT $LAX);$VERSION=0.9912;my$FRACTION_PART=qr/\.[0-9]+/;my$STRICT_INTEGER_PART=qr/0|[1-9][0-9]*/;my$LAX_INTEGER_PART=qr/[0-9]+/;my$STRICT_DOTTED_DECIMAL_PART=qr/\.[0-9]{1,3}/;my$LAX_DOTTED_DECIMAL_PART=qr/\.[0-9]+/;my$LAX_ALPHA_PART=qr/_[0-9]+/;my$STRICT_DECIMAL_VERSION=qr/ $STRICT_INTEGER_PART $FRACTION_PART? /x;my$STRICT_DOTTED_DECIMAL_VERSION=qr/ v $STRICT_INTEGER_PART $STRICT_DOTTED_DECIMAL_PART{2,} /x;$STRICT=qr/ $STRICT_DECIMAL_VERSION | $STRICT_DOTTED_DECIMAL_VERSION /x;my$LAX_DECIMAL_VERSION=qr/ $LAX_INTEGER_PART (?: \. | $FRACTION_PART $LAX_ALPHA_PART? )? | $FRACTION_PART $LAX_ALPHA_PART? /x;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;$LAX=qr/ undef | $LAX_DECIMAL_VERSION | $LAX_DOTTED_DECIMAL_VERSION /x;sub is_strict {defined $_[0]&& $_[0]=~ qr/ \A $STRICT \z /x}sub is_lax {defined $_[0]&& $_[0]=~ qr/ \A $LAX \z /x}1; VERSION_REGEX $fatpacked{"version/vpp.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'VERSION_VPP'; package charstar;use overload ('""'=>\&thischar,'0+'=>\&thischar,'++'=>\&increment,'--'=>\&decrement,'+'=>\&plus,'-'=>\&minus,'*'=>\&multiply,'cmp'=>\&cmp,'<=>'=>\&spaceship,'bool'=>\&thischar,'='=>\&clone,);sub new {my ($self,$string)=@_;my$class=ref($self)|| $self;my$obj={string=>[split(//,$string)],current=>0,};return bless$obj,$class}sub thischar {my ($self)=@_;my$last=$#{$self->{string}};my$curr=$self->{current};if ($curr >= 0 && $curr <= $last){return$self->{string}->[$curr]}else {return ''}}sub increment {my ($self)=@_;$self->{current}++}sub decrement {my ($self)=@_;$self->{current}--}sub plus {my ($self,$offset)=@_;my$rself=$self->clone;$rself->{current}+= $offset;return$rself}sub minus {my ($self,$offset)=@_;my$rself=$self->clone;$rself->{current}-= $offset;return$rself}sub multiply {my ($left,$right,$swapped)=@_;my$char=$left->thischar();return$char * $right}sub spaceship {my ($left,$right,$swapped)=@_;unless (ref($right)){$right=$left->new($right)}return$left->{current}<=> $right->{current}}sub cmp {my ($left,$right,$swapped)=@_;unless (ref($right)){if (length($right)==1){return$left->thischar cmp $right}$right=$left->new($right)}return$left->currstr cmp $right->currstr}sub bool {my ($self)=@_;my$char=$self->thischar;return ($char ne '')}sub clone {my ($left,$right,$swapped)=@_;$right={string=>[@{$left->{string}}],current=>$left->{current},};return bless$right,ref($left)}sub currstr {my ($self,$s)=@_;my$curr=$self->{current};my$last=$#{$self->{string}};if (defined($s)&& $s->{current}< $last){$last=$s->{current}}my$string=join('',@{$self->{string}}[$curr..$last]);return$string}package version::vpp;use 5.006002;use strict;use warnings::register;use Config;use vars qw($VERSION $CLASS @ISA $LAX $STRICT $WARN_CATEGORY);$VERSION=0.9912;$CLASS='version::vpp';if ($] > 5.015){warnings::register_categories(qw/version/);$WARN_CATEGORY='version'}else {$WARN_CATEGORY='numeric'}require version::regex;*version::vpp::is_strict=\&version::regex::is_strict;*version::vpp::is_lax=\&version::regex::is_lax;*LAX=\$version::regex::LAX;*STRICT=\$version::regex::STRICT;use overload ('""'=>\&stringify,'0+'=>\&numify,'cmp'=>\&vcmp,'<=>'=>\&vcmp,'bool'=>\&vbool,'+'=>\&vnoop,'-'=>\&vnoop,'*'=>\&vnoop,'/'=>\&vnoop,'+='=>\&vnoop,'-='=>\&vnoop,'*='=>\&vnoop,'/='=>\&vnoop,'abs'=>\&vnoop,);sub import {no strict 'refs';my ($class)=shift;unless ($class eq $CLASS){local $^W;*{$class.'::declare'}=\&{$CLASS.'::declare'};*{$class.'::qv'}=\&{$CLASS.'::qv'}}my%args;if (@_){map {$args{$_}=1}@_}else {%args=(qv=>1,'UNIVERSAL::VERSION'=>1,)}my$callpkg=caller();if (exists($args{declare})){*{$callpkg.'::declare'}=sub {return$class->declare(shift)}unless defined(&{$callpkg.'::declare'})}if (exists($args{qv})){*{$callpkg.'::qv'}=sub {return$class->qv(shift)}unless defined(&{$callpkg.'::qv'})}if (exists($args{'UNIVERSAL::VERSION'})){no warnings qw/redefine/;*UNIVERSAL::VERSION =\&{$CLASS.'::_VERSION'}}if (exists($args{'VERSION'})){*{$callpkg.'::VERSION'}=\&{$CLASS.'::_VERSION'}}if (exists($args{'is_strict'})){*{$callpkg.'::is_strict'}=\&{$CLASS.'::is_strict'}unless defined(&{$callpkg.'::is_strict'})}if (exists($args{'is_lax'})){*{$callpkg.'::is_lax'}=\&{$CLASS.'::is_lax'}unless defined(&{$callpkg.'::is_lax'})}}my$VERSION_MAX=0x7FFFFFFF;use constant TRUE=>1;use constant FALSE=>0;sub isDIGIT {my ($char)=shift->thischar();return ($char =~ /\d/)}sub isALPHA {my ($char)=shift->thischar();return ($char =~ /[a-zA-Z]/)}sub isSPACE {my ($char)=shift->thischar();return ($char =~ /\s/)}sub BADVERSION {my ($s,$errstr,$error)=@_;if ($errstr){$$errstr=$error}return$s}sub prescan_version {my ($s,$strict,$errstr,$sqv,$ssaw_decimal,$swidth,$salpha)=@_;my$qv=defined$sqv ? $$sqv : FALSE;my$saw_decimal=defined$ssaw_decimal ? $$ssaw_decimal : 0;my$width=defined$swidth ? $$swidth : 3;my$alpha=defined$salpha ? $$salpha : FALSE;my$d=$s;if ($qv && isDIGIT($d)){goto dotted_decimal_version}if ($d eq 'v'){$d++;if (isDIGIT($d)){$qv=TRUE}else {return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)")}dotted_decimal_version: if ($strict && $d eq '0' && isDIGIT($d+1)){return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)")}while (isDIGIT($d)){$d++}if ($d eq '.'){$saw_decimal++;$d++}else {if ($strict){return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)")}else {goto version_prescan_finish}}{my$i=0;my$j=0;while (isDIGIT($d)){$i++;while (isDIGIT($d)){$d++;$j++;if ($strict && $j > 3){return BADVERSION($s,$errstr,"Invalid version format (maximum 3 digits between decimals)")}}if ($d eq '_'){if ($strict){return BADVERSION($s,$errstr,"Invalid version format (no underscores)")}if ($alpha){return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)")}$d++;$alpha=TRUE}elsif ($d eq '.'){if ($alpha){return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)")}$saw_decimal++;$d++}elsif (!isDIGIT($d)){last}$j=0}if ($strict && $i < 2){return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)")}}}else {my$j=0;if ($strict){if ($d eq '.'){return BADVERSION($s,$errstr,"Invalid version format (0 before decimal required)")}if ($d eq '0' && isDIGIT($d+1)){return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)")}}if ($d eq '-'){return BADVERSION($s,$errstr,"Invalid version format (negative version number)")}while (isDIGIT($d)){$d++}if ($d eq '.'){$saw_decimal++;$d++}elsif (!$d || $d eq ';' || isSPACE($d)|| $d eq '}'){if ($d==$s){return BADVERSION($s,$errstr,"Invalid version format (version required)")}goto version_prescan_finish}elsif ($d==$s){return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)")}elsif ($d eq '_'){if ($strict){return BADVERSION($s,$errstr,"Invalid version format (no underscores)")}elsif (isDIGIT($d+1)){return BADVERSION($s,$errstr,"Invalid version format (alpha without decimal)")}else {return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)")}}elsif ($d){return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)")}if ($d &&!isDIGIT($d)&& ($strict ||!($d eq ';' || isSPACE($d)|| $d eq '}'))){return BADVERSION($s,$errstr,"Invalid version format (fractional part required)")}while (isDIGIT($d)){$d++;$j++;if ($d eq '.' && isDIGIT($d-1)){if ($alpha){return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)")}if ($strict){return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions must begin with 'v')")}$d=$s;$qv=TRUE;goto dotted_decimal_version}if ($d eq '_'){if ($strict){return BADVERSION($s,$errstr,"Invalid version format (no underscores)")}if ($alpha){return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)")}if (!isDIGIT($d+1)){return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)")}$width=$j;$d++;$alpha=TRUE}}}version_prescan_finish: while (isSPACE($d)){$d++}if ($d &&!isDIGIT($d)&& (!($d eq ';' || $d eq '}'))){return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)")}if ($saw_decimal > 1 && ($d-1)eq '.'){return BADVERSION($s,$errstr,"Invalid version format (trailing decimal)")}if (defined$sqv){$$sqv=$qv}if (defined$swidth){$$swidth=$width}if (defined$ssaw_decimal){$$ssaw_decimal=$saw_decimal}if (defined$salpha){$$salpha=$alpha}return$d}sub scan_version {my ($s,$rv,$qv)=@_;my$start;my$pos;my$last;my$errstr;my$saw_decimal=0;my$width=3;my$alpha=FALSE;my$vinf=FALSE;my@av;$s=new charstar$s;while (isSPACE($s)){$s++}$last=prescan_version($s,FALSE,\$errstr,\$qv,\$saw_decimal,\$width,\$alpha);if ($errstr){if ($s ne 'undef'){require Carp;Carp::croak($errstr)}}$start=$s;if ($s eq 'v'){$s++}$pos=$s;if ($qv){$$rv->{qv}=$qv}if ($alpha){$$rv->{alpha}=$alpha}if (!$qv && $width < 3){$$rv->{width}=$width}while (isDIGIT($pos)){$pos++}if (!isALPHA($pos)){my$rev;for (;;){$rev=0;{my$end=$pos;my$mult=1;my$orev;if (!$qv && $s > $start && $saw_decimal==1){$mult *= 100;while ($s < $end){$orev=$rev;$rev += $s * $mult;$mult /= 10;if ((abs($orev)> abs($rev))|| (abs($rev)> $VERSION_MAX)){warn("Integer overflow in version %d",$VERSION_MAX);$s=$end - 1;$rev=$VERSION_MAX;$vinf=1}$s++;if ($s eq '_'){$s++}}}else {while (--$end >= $s){$orev=$rev;$rev += $end * $mult;$mult *= 10;if ((abs($orev)> abs($rev))|| (abs($rev)> $VERSION_MAX)){warn("Integer overflow in version");$end=$s - 1;$rev=$VERSION_MAX;$vinf=1}}}}push@av,$rev;if ($vinf){$s=$last;last}elsif ($pos eq '.'){$pos++;if ($qv){while ($pos eq '0'){$pos++}}$s=$pos}elsif ($pos eq '_' && isDIGIT($pos+1)){$s=++$pos}elsif ($pos eq ',' && isDIGIT($pos+1)){$s=++$pos}elsif (isDIGIT($pos)){$s=$pos}else {$s=$pos;last}if ($qv){while (isDIGIT($pos)){$pos++}}else {my$digits=0;while ((isDIGIT($pos)|| $pos eq '_')&& $digits < 3){if ($pos ne '_'){$digits++}$pos++}}}}if ($qv){my$len=$#av;$len=2 - $len;while ($len-- > 0){push@av,0}}if ($vinf){$$rv->{original}="v.Inf";$$rv->{vinf}=1}elsif ($s > $start){$$rv->{original}=$start->currstr($s);if ($qv && $saw_decimal==1 && $start ne 'v'){$$rv->{original}='v' .$$rv->{original}}}else {$$rv->{original}='0';push(@av,0)}$$rv->{version}=\@av;if ($s eq 'undef'){$s += 5}return$s}sub new {my$class=shift;unless (defined$class or $#_ > 1){require Carp;Carp::croak('Usage: version::new(class, version)')}my$self=bless ({},ref ($class)|| $class);my$qv=FALSE;if ($#_==1){$qv=TRUE}my$value=pop;if (ref($value)&& eval('$value->isa("version")')){$self->{version}=[@{$value->{version}}];$self->{qv}=1 if$value->{qv};$self->{alpha}=1 if$value->{alpha};$self->{original}=''.$value->{original};return$self}if (not defined$value or $value =~ /^undef$/){push @{$self->{version}},0;$self->{original}="0";return ($self)}if (ref($value)=~ m/ARRAY|HASH/){require Carp;Carp::croak("Invalid version format (non-numeric data)")}$value=_un_vstring($value);if ($Config{d_setlocale}){use POSIX qw/locale_h/;use if$Config{d_setlocale},'locale';my$currlocale=setlocale(LC_ALL);if (localeconv()->{decimal_point}eq ','){$value =~ tr/,/./}}if ($value =~ /\d+.?\d*e[-+]?\d+/){$value=sprintf("%.9f",$value);$value =~ s/(0+)$//}my$s=scan_version($value,\$self,$qv);if ($s){warn("Version string '%s' contains invalid data; " ."ignoring: '%s'",$value,$s)}return ($self)}*parse=\&new;sub numify {my ($self)=@_;unless (_verify($self)){require Carp;Carp::croak("Invalid version object")}my$width=$self->{width}|| 3;my$alpha=$self->{alpha}|| "";my$len=$#{$self->{version}};my$digit=$self->{version}[0];my$string=sprintf("%d.",$digit);if ($alpha and warnings::enabled()){warnings::warn($WARN_CATEGORY,'alpha->numify() is lossy')}for (my$i=1 ;$i < $len ;$i++ ){$digit=$self->{version}[$i];if ($width < 3){my$denom=10**(3-$width);my$quot=int($digit/$denom);my$rem=$digit - ($quot * $denom);$string .= sprintf("%0".$width."d_%d",$quot,$rem)}else {$string .= sprintf("%03d",$digit)}}if ($len > 0){$digit=$self->{version}[$len];if ($alpha && $width==3){$string .= "_"}$string .= sprintf("%0".$width."d",$digit)}else {$string .= sprintf("000")}return$string}sub normal {my ($self)=@_;unless (_verify($self)){require Carp;Carp::croak("Invalid version object")}my$alpha=$self->{alpha}|| "";my$qv=$self->{qv}|| "";my$len=$#{$self->{version}};my$digit=$self->{version}[0];my$string=sprintf("v%d",$digit);for (my$i=1 ;$i < $len ;$i++ ){$digit=$self->{version}[$i];$string .= sprintf(".%d",$digit)}if ($len > 0){$digit=$self->{version}[$len];if ($alpha){$string .= sprintf("_%0d",$digit)}else {$string .= sprintf(".%0d",$digit)}}if ($len <= 2){for ($len=2 - $len;$len!=0;$len-- ){$string .= sprintf(".%0d",0)}}return$string}sub stringify {my ($self)=@_;unless (_verify($self)){require Carp;Carp::croak("Invalid version object")}return exists$self->{original}? $self->{original}: exists$self->{qv}? $self->normal : $self->numify}sub vcmp {require UNIVERSAL;my ($left,$right,$swap)=@_;my$class=ref($left);unless (UNIVERSAL::isa($right,$class)){$right=$class->new($right)}if ($swap){($left,$right)=($right,$left)}unless (_verify($left)){require Carp;Carp::croak("Invalid version object")}unless (_verify($right)){require Carp;Carp::croak("Invalid version format")}my$l=$#{$left->{version}};my$r=$#{$right->{version}};my$m=$l < $r ? $l : $r;my$lalpha=$left->is_alpha;my$ralpha=$right->is_alpha;my$retval=0;my$i=0;while ($i <= $m && $retval==0){$retval=$left->{version}[$i]<=> $right->{version}[$i];$i++}if ($retval==0 && $l==$r && $left->{version}[$m]==$right->{version}[$m]&& ($lalpha || $ralpha)){if ($lalpha &&!$ralpha){$retval=-1}elsif ($ralpha &&!$lalpha){$retval=+1}}if ($retval==0 && $l!=$r){if ($l < $r){while ($i <= $r && $retval==0){if ($right->{version}[$i]!=0){$retval=-1}$i++}}else {while ($i <= $l && $retval==0){if ($left->{version}[$i]!=0){$retval=+1}$i++}}}return$retval}sub vbool {my ($self)=@_;return vcmp($self,$self->new("0"),1)}sub vnoop {require Carp;Carp::croak("operation not supported with version object")}sub is_alpha {my ($self)=@_;return (exists$self->{alpha})}sub qv {my$value=shift;my$class=$CLASS;if (@_){$class=ref($value)|| $value;$value=shift}$value=_un_vstring($value);$value='v'.$value unless$value =~ /(^v|\d+\.\d+\.\d)/;my$obj=$CLASS->new($value);return bless$obj,$class}*declare=\&qv;sub is_qv {my ($self)=@_;return (exists$self->{qv})}sub _verify {my ($self)=@_;if (ref($self)&& eval {exists$self->{version}}&& ref($self->{version})eq 'ARRAY'){return 1}else {return 0}}sub _is_non_alphanumeric {my$s=shift;$s=new charstar$s;while ($s){return 0 if isSPACE($s);return 1 unless (isALPHA($s)|| isDIGIT($s)|| $s =~ /[.-]/);$s++}return 0}sub _un_vstring {my$value=shift;if (length($value)>= 1 && $value !~ /[,._]/ && _is_non_alphanumeric($value)){my$tvalue;if ($] >= 5.008_001){$tvalue=_find_magic_vstring($value);$value=$tvalue if length$tvalue}elsif ($] >= 5.006_000){$tvalue=sprintf("v%vd",$value);if ($tvalue =~ /^v\d+(\.\d+)*$/){$value=$tvalue}}}return$value}sub _find_magic_vstring {my$value=shift;my$tvalue='';require B;my$sv=B::svref_2object(\$value);my$magic=ref($sv)eq 'B::PVMG' ? $sv->MAGIC : undef;while ($magic){if ($magic->TYPE eq 'V'){$tvalue=$magic->PTR;$tvalue =~ s/^v?(.+)$/v$1/;last}else {$magic=$magic->MOREMAGIC}}return$tvalue}sub _VERSION {my ($obj,$req)=@_;my$class=ref($obj)|| $obj;no strict 'refs';if (exists$INC{"$class.pm"}and not %{"$class\::"}and $] >= 5.008){require Carp;Carp::croak("$class defines neither package nor VERSION" ."--version check failed")}my$version=eval "\$$class\::VERSION";if (defined$version){local $^W if $] <= 5.008;$version=version::vpp->new($version)}if (defined$req){unless (defined$version){require Carp;my$msg=$] < 5.006 ? "$class version $req required--this is only version " : "$class does not define \$$class\::VERSION" ."--version check failed";if ($ENV{VERSION_DEBUG}){Carp::confess($msg)}else {Carp::croak($msg)}}$req=version::vpp->new($req);if ($req > $version){require Carp;if ($req->is_qv){Carp::croak(sprintf ("%s version %s required--"."this is only version %s",$class,$req->normal,$version->normal))}else {Carp::croak(sprintf ("%s version %s required--"."this is only version %s",$class,$req->stringify,$version->stringify))}}}return defined$version ? $version->stringify : undef}1; VERSION_VPP s/^ //mg for values %fatpacked; my $class = 'FatPacked::'.(0+\%fatpacked); no strict 'refs'; *{"${class}::files"} = sub { keys %{$_[0]} }; if ($] < 5.008) { *{"${class}::INC"} = sub { if (my $fat = $_[0]{$_[1]}) { 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; }); } }; } else { *{"${class}::INC"} = sub { if (my $fat = $_[0]{$_[1]}) { open my $fh, '<', \$fat or die "FatPacker error loading $_[1] (could be a perl installation issue?)"; return $fh; } return; }; } unshift @INC, bless \%fatpacked, $class; } # END OF FATPACK CODE use strict; use App::cpanminus::script; unless (caller) { my $app = App::cpanminus::script->new; $app->parse_options(@ARGV); exit $app->doit; } __END__ =head1 NAME cpanm - get, unpack build and install modules from CPAN =head1 SYNOPSIS cpanm Test::More # install Test::More cpanm MIYAGAWA/Plack-0.99_05.tar.gz # full distribution path cpanm http://example.org/LDS/CGI.pm-3.20.tar.gz # install from URL cpanm ~/dists/MyCompany-Enterprise-1.00.tar.gz # install from a local file cpanm --interactive Task::Kensho # Configure interactively cpanm . # install from local directory cpanm --installdeps . # install all the deps for the current directory cpanm -L extlib Plack # install Plack and all non-core deps into extlib cpanm --mirror http://cpan.cpantesters.org/ DBI # use the fast-syncing mirror cpanm --from https://cpan.metacpan.org/ Plack # use only the HTTPS mirror =head1 COMMANDS =over 4 =item (arguments) Command line arguments can be either a module name, distribution file, local file path, HTTP URL or git repository URL. Following commands will all work as you expect. cpanm Plack cpanm Plack/Request.pm cpanm MIYAGAWA/Plack-1.0000.tar.gz cpanm /path/to/Plack-1.0000.tar.gz cpanm http://cpan.metacpan.org/authors/id/M/MI/MIYAGAWA/Plack-0.9990.tar.gz cpanm git://github.com/plack/Plack.git Additionally, you can use the notation using C<~> and C<@> to specify version for a given module. C<~> specifies the version requirement in the L<CPAN::Meta::Spec> format, while C<@> pins the exact version, and is a shortcut for C<~"== VERSION">. cpanm Plack~1.0000 # 1.0000 or later cpanm Plack~">= 1.0000, < 2.0000" # latest of 1.xxxx cpanm Plack@0.9990 # specific version. same as Plack~"== 0.9990" The version query including specific version or range will be sent to L<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. For a git repository, you can specify a branch, tag, or commit SHA to build. The default is C<master> cpanm git://github.com/plack/Plack.git@1.0000 # tag cpanm git://github.com/plack/Plack.git@devel # branch =item -i, --install Installs the modules. This is a default behavior and this is just a compatibility option to make it work like L<cpan> or L<cpanp>. =item --self-upgrade Upgrades itself. It's just an alias for: cpanm App::cpanminus =item --info Displays the distribution information in C<AUTHOR/Dist-Name-ver.tar.gz> format in the standard out. =item --installdeps Installs the dependencies of the target distribution but won't build itself. Handy if you want to try the application from a version controlled repository such as git. cpanm --installdeps . =item --look Download and unpack the distribution and then open the directory with your shell. Handy to poke around the source code or do manual testing. =item -h, --help Displays the help message. =item -V, --version Displays the version number. =back =head1 OPTIONS You can specify the default options in C<PERL_CPANM_OPT> environment variable. =over 4 =item -f, --force Force install modules even when testing failed. =item -n, --notest Skip the testing of modules. Use this only when you just want to save time for installing hundreds of distributions to the same perl and architecture you've already tested to make sure it builds fine. Defaults to false, and you can say C<--no-notest> to override when it is set in the default options in C<PERL_CPANM_OPT>. =item --test-only Run the tests only, and do not install the specified module or distributions. Handy if you want to verify the new (or even old) releases pass its unit tests without installing the module. Note that if you specify this option with a module or distribution that has dependencies, these dependencies will be installed if you don't currently have them. =item -S, --sudo Switch to the root user with C<sudo> when installing modules. Use this if you want to install modules to the system perl include path. Defaults to false, and you can say C<--no-sudo> to override when it is set in the default options in C<PERL_CPANM_OPT>. =item -v, --verbose Makes the output verbose. It also enables the interactive configuration. (See --interactive) =item -q, --quiet Makes the output even more quiet than the default. It only shows the successful/failed dependencies to the output. =item -l, --local-lib Sets the L<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. =item -L, --local-lib-contained Same with C<--local-lib> but with L<--self-contained> set. All non-core dependencies will be installed even if they're already installed. For instance, cpanm -L extlib Plack would install Plack and all of its non-core dependencies into the directory C<extlib>, which can be loaded from your application with: use local::lib '/path/to/extlib'; 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. =item --self-contained When examining the dependencies, assume no non-core modules are installed on the system. Handy if you want to bundle application dependencies in one directory so you can distribute to other machines. =item --exclude-vendor Don't include modules installed under the 'vendor' paths when searching for core modules when the C<--self-contained> flag is in effect. This restores the behaviour from before version 1.7023 =item --mirror Specifies the base URL for the CPAN mirror to use, such as C<http://cpan.cpantesters.org/> (you can omit the trailing slash). You can specify multiple mirror URLs by repeating the command line option. You can use a local directory that has a CPAN mirror structure (created by tools such as L<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. cpanm --mirror file:///path/to/mirror cpanm --mirror ~/minicpan # Because shell expands ~ to /home/user Defaults to C<http://www.cpan.org/>. =item --mirror-only Download the mirror's 02packages.details.txt.gz index file instead of querying the CPAN Meta DB. This will also effectively opt out sending your local perl versions to backend database servers such as CPAN Meta DB and MetaCPAN. Select this option if you are using a local mirror of CPAN, such as minicpan when you're offline, or your own CPAN index (a.k.a darkpan). =item --from, -M cpanm -M https://cpan.metacpan.org/ cpanm --from https://cpan.metacpan.org/ Use the given mirror URL and its index as the I<only> source to search and download modules from. It works similar to C<--mirror> and C<--mirror-only> combined, with a small difference: unlike C<--mirror> which I<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. B<Tip:> It might be useful if you name these options with your shell aliases, like: alias minicpanm='cpanm --from ~/minicpan' alias darkpan='cpanm --from http://mycompany.example.com/DPAN' =item --mirror-index B<EXPERIMENTAL>: Specifies the file path to C<02packages.details.txt> for module search index. =item --cpanmetadb B<EXPERIMENTAL>: Specifies an alternate URI for CPAN MetaDB index lookups. =item --metacpan Prefers MetaCPAN API over CPAN MetaDB. =item --cpanfile B<EXPERIMENTAL>: Specified an alternate path for cpanfile to search for, when C<--installdeps> command is in use. Defaults to C<cpanfile>. =item --prompt Prompts when a test fails so that you can skip, force install, retry or look in the shell to see what's going wrong. It also prompts when one of the dependency failed if you want to proceed the installation. Defaults to false, and you can say C<--no-prompt> to override if it's set in the default options in C<PERL_CPANM_OPT>. =item --dev B<EXPERIMENTAL>: search for a newer developer release as well. Defaults to false. =item --reinstall cpanm, when given a module name in the command line (i.e. C<cpanm Plack>), checks the locally installed version first and skips if it is already installed. This option makes it skip the check, so: cpanm --reinstall Plack would reinstall L<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). Defaults to false. =item --interactive 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. 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>. =item --pp, --pureperl 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. =item --with-recommends, --with-suggests 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. 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. There's also C<--without-recommend> and C<--without-suggests> to override the default decision made earlier in C<PERL_CPANM_OPT>. Defaults to false for both. =item --with-develop B<EXPERIMENTAL>: Installs develop phase dependencies in META files or C<cpanfile> when used with C<--installdeps>. Defaults to false. =item --with-configure B<EXPERIMENTAL>: Installs configure phase dependencies in C<cpanfile> when used with C<--installdeps>. Defaults to false. =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. cpanm --with-feature=opt_csv Spreadsheet::Read the features can also be interactively chosen when C<--interactive> option is enabled. C<--with-all-features> enables all the optional features, and C<--without-feature> can select a feature to disable. =item --configure-timeout, --build-timeout, --test-timeout Specify the timeout length (in seconds) to wait for the configure, build and test process. Current default values are: 60 for configure, 3600 for build and 1800 for test. =item --configure-args, --build-args, --test-args, --install-args B<EXPERIMENTAL>: Pass arguments for configure/build/test/install commands respectively, for a given module to install. cpanm DBD::mysql --configure-args="--cflags=... --libs=..." The argument is only enabled for the module passed as a command line argument, not dependencies. =item --scandeps B<DEPRECATED>: Scans the depencencies of given modules and output the tree in a text format. (See C<--format> below for more options) Because this command doesn't actually install any distributions, it will be useful that by typing: cpanm --scandeps Catalyst::Runtime you can make sure what modules will be installed. This command takes into account which modules you already have installed in your system. If you want to see what modules will be installed against a vanilla perl installation, you might want to combine it with C<-L> option. =item --format B<DEPRECATED>: Determines what format to display the scanned dependency tree. Available options are C<tree>, C<json>, C<yaml> and C<dists>. =over 8 =item tree Displays the tree in a plain text format. This is the default value. =item json, yaml Outputs the tree in a JSON or YAML format. L<JSON> and L<YAML> modules need to be installed respectively. The output tree is represented as a recursive tuple of: [ distribution, dependencies ] and the container is an array containing the root elements. Note that there may be multiple root nodes, since you can give multiple modules to the C<--scandeps> command. =item dists C<dists> is a special output format, where it prints the distribution filename in the I<depth first order> after the dependency resolution, like: GAAS/MIME-Base64-3.13.tar.gz GAAS/URI-1.58.tar.gz PETDANCE/HTML-Tagset-3.20.tar.gz GAAS/HTML-Parser-3.68.tar.gz GAAS/libwww-perl-5.837.tar.gz which means you can install these distributions in this order without extra dependencies. When combined with C<-L> option, it will be useful to replay installations on other machines. =back =item --save-dists Specifies the optional directory path to copy downloaded tarballs in the CPAN mirror compatible directory structure i.e. I<authors/id/A/AU/AUTHORS/Foo-Bar-version.tar.gz> 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>. =item --uninst-shadows Uninstalls the shadow files of the distribution that you're installing. This eliminates the confusion if you're trying to install core (dual-life) modules from CPAN against perl 5.10 or older, or modules that used to be XS-based but switched to pure perl at some version. If you run cpanm as root and use C<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. Defaults to true if your perl version is smaller than 5.12, and you can disable that with C<--no-uninst-shadows>. 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. =item --uninstall, -U Uninstalls a module from the library path. It finds a packlist for given modules, and removes all the files included in the same distribution. If you enable local::lib, it only removes files from the local::lib directory. If you try to uninstall a module in C<perl> directory (i.e. core module), an error will be thrown. A dialog will be prompted to confirm the files to be deleted. If you pass C<-f> option as well, the dialog will be skipped and uninstallation will be forced. =item --cascade-search B<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. =item --skip-installed Specifies whether a module given in the command line is skipped if its latest version is already installed. Defaults to true. B<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. =item --skip-satisfied B<EXPERIMENTAL>: Specifies whether a module (and version) given in the command line is skipped if it's already installed. If you run: cpanm --skip-satisfied CGI DBI~1.2 cpanm won't install them if you already have CGI (for whatever versions) or have DBI with version higher than 1.2. It is similar to C<--skip-installed> but while C<--skip-installed> checks if the I<latest> version of CPAN is installed, C<--skip-satisfied> checks if a requested version (or not, which means any version) is installed. Defaults to false. =item --verify Verify the integrity of distribution files retrieved from CPAN using CHECKSUMS file, and SIGNATURES file (if found in the distribution). Defaults to false. Using this option does not verify the integrity of the CHECKSUMS file, and it's unsafe to rely on this option if you're using a CPAN mirror that you do not trust. =item --report-perl-version Whether it reports the locally installed perl version to the various web server as part of User-Agent. Defaults to true unless CI related environment variables such as C<TRAVIS>, C<CI> or C<AUTOMATED_TESTING> is enabled. You can disable it by using C<--no-report-perl-version>. =item --auto-cleanup Specifies the number of days in which cpanm's work directories expire. Defaults to 7, which means old work directories will be cleaned up in one week. You can set the value to C<0> to make cpan never cleanup those directories. =item --man-pages Generates man pages for executables (man1) and libraries (man3). Defaults to true (man pages generated) unless C<-L|--local-lib-contained> option is supplied in which case it's set to false. You can disable it with C<--no-man-pages>. =item --lwp Uses L<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. =item --wget Uses GNU Wget (if available) to download stuff. Defaults to true, and you can say C<--no-wget> to disable using Wget (versions of Wget older than 1.9 don't support the C<--retry-connrefused> option used by cpanm). =item --curl Uses cURL (if available) to download stuff. Defaults to true, and you can say C<--no-curl> to disable using cURL. Normally with C<--lwp>, C<--wget> and C<--curl> options set to true (which is the default) cpanm tries L<LWP>, Wget, cURL and L<HTTP::Tiny> (in that order) and uses the first one available. =back =head1 ENVIRONMENT VARIABLES =over 4 =item PERL_CPANM_HOME 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. =item PERL_CPANM_OPT If set, adds a set of default options to every cpanm command. These options come first, and so are overridden by command-line options. =back =head1 SEE ALSO L<App::cpanminus> =head1 COPYRIGHT Copyright 2010- Tatsuhiko Miyagawa. =head1 AUTHOR Tatsuhiko Miyagawa =cut PK jA[ blib/script/.existsnu �[��� PK jA[�D�� � blib/lib/App/cpanminus.pmnu ��6�$ package App::cpanminus; our $VERSION = "1.7047"; =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. =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<CPAN::Meta::Check> Copyright (c) 2012 by Leon Timmermans =item L<File::pushd> Copyright 2012 David Golden =item L<parent> Copyright (c) 2007-10 Max Maischein =item L<Parse::PMFile> Copyright 1995 - 2013 by Andreas Koenig, Copyright 2013 by Kenichi Ishigaki =item L<String::ShellQuote> by Roderick Schertler =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; PK jA[r��~� � # blib/lib/App/cpanminus/fatscript.pmnu ��6�$ package App::cpanminus::fatscript; # # This is a pre-compiled source code for the cpanm (cpanminus) program. # For more details about how to install cpanm, go to the following URL: # # https://github.com/miyagawa/cpanminus # # Quickstart: Run the following command and it will install itself for # you. You might want to run it as a root with sudo if you want to install # to places like /usr/local/bin. # # % curl -L https://cpanmin.us | perl - App::cpanminus # # If you don't have curl but wget, replace `curl -L` with `wget -O -`. # DO NOT EDIT -- this is an auto generated file # This chunk of stuff was generated by App::FatPacker. To find the original # file's code, look for the end of this BEGIN block or the string 'FATPACK' BEGIN { my %fatpacked; $fatpacked{"App/cpanminus.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_CPANMINUS'; package App::cpanminus; our $VERSION = "1.7047"; =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. =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<CPAN::Meta::Check> Copyright (c) 2012 by Leon Timmermans =item L<File::pushd> Copyright 2012 David Golden =item L<parent> Copyright (c) 2007-10 Max Maischein =item L<Parse::PMFile> Copyright 1995 - 2013 by Andreas Koenig, Copyright 2013 by Kenichi Ishigaki =item L<String::ShellQuote> by Roderick Schertler =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 $fatpacked{"App/cpanminus/Dependency.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_CPANMINUS_DEPENDENCY'; package App::cpanminus::Dependency; use strict; use CPAN::Meta::Requirements; sub from_prereqs { my($class, $prereqs, $phases, $types) = @_; my @deps; for my $type (@$types) { push @deps, $class->from_versions( $prereqs->merged_requirements($phases, [$type])->as_string_hash, $type, ); } return @deps; } sub from_versions { my($class, $versions, $type) = @_; my @deps; while (my($module, $version) = each %$versions) { push @deps, $class->new($module, $version, $type) } @deps; } sub merge_with { my($self, $requirements) = @_; # save the original requirement $self->{original_version} = $self->version; # should it clone? not cloning means we upgrade root $requirements on our way eval { $requirements->add_string_requirement($self->module, $self->version); }; if ($@ =~ /illegal requirements/) { # Just give a warning then replace with the root requirements # so that later CPAN::Meta::Check can give a valid error warn sprintf("Can't merge requirements for %s: '%s' and '%s'", $self->module, $self->version, $requirements->requirements_for_module($self->module)); } $self->{version} = $requirements->requirements_for_module($self->module); } sub new { my($class, $module, $version, $type) = @_; bless { module => $module, version => $version, type => $type || 'requires', }, $class; } sub module { $_[0]->{module} } sub version { $_[0]->{version} } sub type { $_[0]->{type} } sub requires_version { my $self = shift; # original_version may be 0 if (defined $self->{original_version}) { return $self->{original_version}; } $self->version; } sub is_requirement { $_[0]->{type} eq 'requires'; } 1; APP_CPANMINUS_DEPENDENCY $fatpacked{"App/cpanminus/script.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_CPANMINUS_SCRIPT'; package App::cpanminus::script; use strict; use Config; use Cwd (); use App::cpanminus; use App::cpanminus::Dependency; use File::Basename (); use File::Find (); use File::Path (); use File::Spec (); use File::Copy (); use File::Temp (); use Getopt::Long (); use Symbol (); use String::ShellQuote (); use version (); use constant WIN32 => $^O eq 'MSWin32'; use constant BAD_TAR => ($^O eq 'solaris' || $^O eq 'hpux'); use constant CAN_SYMLINK => eval { symlink("", ""); 1 }; our $VERSION = $App::cpanminus::VERSION; if ($INC{"App/FatPacker/Trace.pm"}) { require version::vpp; } my $quote = WIN32 ? q/"/ : q/'/; sub agent { my $self = shift; my $agent = "cpanminus/$VERSION"; $agent .= " perl/$]" if $self->{report_perl_version}; $agent; } sub determine_home { my $class = shift; my $homedir = $ENV{HOME} || eval { require File::HomeDir; File::HomeDir->my_home } || join('', @ENV{qw(HOMEDRIVE HOMEPATH)}); # Win32 if (WIN32) { require Win32; # no fatpack $homedir = Win32::GetShortPathName($homedir); } return "$homedir/.cpanm"; } sub new { my $class = shift; bless { home => $class->determine_home, cmd => 'install', seen => {}, notest => undef, test_only => undef, installdeps => undef, force => undef, sudo => undef, make => undef, verbose => undef, quiet => undef, interactive => undef, log => undef, mirrors => [], mirror_only => undef, mirror_index => undef, cpanmetadb => "http://cpanmetadb.plackperl.org/v1.0/", perl => $^X, argv => [], local_lib => undef, self_contained => undef, exclude_vendor => undef, prompt_timeout => 0, prompt => undef, configure_timeout => 60, build_timeout => 3600, test_timeout => 1800, try_lwp => 1, try_wget => 1, try_curl => 1, uninstall_shadows => ($] < 5.012), skip_installed => 1, skip_satisfied => 0, auto_cleanup => 7, # days pod2man => 1, installed_dists => 0, install_types => ['requires'], with_develop => 0, 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); $self->uri_escape($json); } sub decode_json { my($self, $json) = @_; require JSON::PP; JSON::PP::decode_json($json); } sub uri_escape { my($self, $fragment) = @_; $fragment =~ s/([^A-Za-z0-9\-\._~])/uc sprintf("%%%02X", ord($1))/eg; $fragment; } sub uri_params { my($self, @params) = @_; my @param_strings; while (my $key = shift @params) { my $value = shift @params; push @param_strings, join '=', map $self->uri_escape($_), $key, $value; } return join '&', @param_strings; } # version->new("1.00_00")->numify => "1.00_00" :/ sub numify_ver { my($self, $ver) = @_; eval version->new($ver)->numify; } sub search_metacpan { my($self, $module, $version, $dev_release) = @_; my $metacpan_uri = 'http://fastapi.metacpan.org/v1/download_url/'; my $url = $metacpan_uri . $module; my $query = $self->uri_params( ($version ? (version => $version) : ()), ($dev_release ? (dev => 1) : ()), ); $url .= '?' . $query if length $query; my $dist_json = $self->get($url); my $dist_meta = eval { $self->decode_json($dist_json) }; if ($dist_meta && $dist_meta->{download_url}) { (my $distfile = $dist_meta->{download_url}) =~ s!.+/authors/id/!!; local $self->{mirrors} = $self->{mirrors}; $self->{mirrors} = [ 'http://cpan.metacpan.org' ]; return $self->cpan_module($module, $distfile, $dist_meta->{version}); } $self->chat("! Could not find a release matching $module".($version?" ($version)":'')." on MetaCPAN.\n"); return; } sub search_database { my($self, $module, $version) = @_; my $found; 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; } } sub search_cpanmetadb { my($self, $module, $version, $dev_release) = @_; $self->chat("Searching $module ($version) on cpanmetadb ...\n"); if ($self->with_version_range($version)) { return $self->search_cpanmetadb_history($module, $version, $dev_release); } else { return $self->search_cpanmetadb_package($module, $version, $dev_release); } } sub search_cpanmetadb_package { my($self, $module, $version, $dev_release) = @_; 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_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_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 verification 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_file, $version) = @_; my $dist = $self->cpan_dist($dist_file); $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; FILE: { chomp $root; if ($root !~ s{^\s+testing:\s+([^/]+)/.*?\s+OK$}{$1}) { $root = shift(@others); redo FILE if $root; } } 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 $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 $fatpacked{"CPAN/Meta/Check.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_CHECK'; package CPAN::Meta::Check; # vi:noet:sts=2:sw=2:ts=2 $CPAN::Meta::Check::VERSION = '0.018'; 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) = @_; return $reqs->accepts_module($module, $]) ? () : sprintf "Your Perl (%s) is not in the range '%s'", $], $reqs->requirements_for_module($module) if $module eq 'perl'; 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.018 =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> =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; 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}; } 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}; } 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}), ); 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 $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 { 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"; } } } # 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/; } 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 $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 $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 $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 $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 $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 $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 $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 $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 $fatpacked{"Module/CPANfile/Prereq.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_PREREQ'; package Module::CPANfile::Prereq; use strict; sub new { my($class, %options) = @_; bless \%options, $class; } sub feature { $_[0]->{feature} } sub phase { $_[0]->{phase} } sub type { $_[0]->{type} } sub module { $_[0]->{module} } sub requirement { $_[0]->{requirement} } sub match_feature { my($self, $identifier) = @_; no warnings 'uninitialized'; $self->feature eq $identifier; } 1; MODULE_CPANFILE_PREREQ $fatpacked{"Module/CPANfile/Prereqs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_PREREQS'; package Module::CPANfile::Prereqs; use strict; use Carp (); use CPAN::Meta::Feature; use Module::CPANfile::Prereq; sub from_cpan_meta { my($class, $prereqs) = @_; my $self = $class->new; for my $phase (keys %$prereqs) { for my $type (keys %{ $prereqs->{$phase} }) { while (my($module, $requirement) = each %{ $prereqs->{$phase}{$type} }) { $self->add_prereq( phase => $phase, type => $type, module => $module, requirement => Module::CPANfile::Requirement->new(name => $module, version => $requirement), ); } } } $self; } sub new { my $class = shift; bless { prereqs => [], features => {}, }, $class; } sub add_feature { my($self, $identifier, $description) = @_; $self->{features}{$identifier} = { description => $description }; } sub add_prereq { my($self, %args) = @_; $self->add( Module::CPANfile::Prereq->new(%args) ); } sub add { my($self, $prereq) = @_; push @{$self->{prereqs}}, $prereq; } sub as_cpan_meta { my $self = shift; $self->{cpanmeta} ||= $self->build_cpan_meta; } sub build_cpan_meta { my($self, $identifier) = @_; my $prereq_spec = {}; $self->prereq_each($identifier, sub { my $prereq = shift; $prereq_spec->{$prereq->phase}{$prereq->type}{$prereq->module} = $prereq->requirement->version; }); CPAN::Meta::Prereqs->new($prereq_spec); } sub prereq_each { my($self, $identifier, $code) = @_; for my $prereq (@{$self->{prereqs}}) { next unless $prereq->match_feature($identifier); $code->($prereq); } } sub merged_requirements { my $self = shift; my $reqs = CPAN::Meta::Requirements->new; for my $prereq (@{$self->{prereqs}}) { $reqs->add_string_requirement($prereq->module, $prereq->requirement->version); } $reqs; } sub find { my($self, $module) = @_; for my $prereq (@{$self->{prereqs}}) { return $prereq if $prereq->module eq $module; } return; } sub identifiers { my $self = shift; keys %{$self->{features}}; } sub feature { my($self, $identifier) = @_; my $data = $self->{features}{$identifier} or Carp::croak("Unknown feature '$identifier'"); my $prereqs = $self->build_cpan_meta($identifier); CPAN::Meta::Feature->new($identifier, { description => $data->{description}, prereqs => $prereqs->as_string_hash, }); } 1; MODULE_CPANFILE_PREREQS $fatpacked{"Module/CPANfile/Requirement.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_REQUIREMENT'; package Module::CPANfile::Requirement; use strict; sub new { my ($class, %args) = @_; $args{version} ||= 0; bless +{ name => delete $args{name}, version => delete $args{version}, options => \%args, }, $class; } sub name { $_[0]->{name} } sub version { $_[0]->{version} } sub options { $_[0]->{options} } sub has_options { keys %{$_[0]->{options}} > 0; } 1; MODULE_CPANFILE_REQUIREMENT $fatpacked{"Module/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_METADATA'; # -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*- # vim:ts=8:sw=2:et:sta:sts=2 package Module::Metadata; # git description: v1.000026-12-g9b12bf1 # Adapted from Perl-licensed code originally distributed with # Module-Build by Ken Williams # This module provides routines to gather information about # perl modules (assuming this may be expanded in the distant # parrot future to look at other types of modules). sub __clean_eval { eval $_[0] } use strict; use warnings; our $VERSION = '1.000027'; use Carp qw/croak/; use File::Spec; BEGIN { # Try really hard to not depend ony any DynaLoaded module, such as IO::File or Fcntl eval { require Fcntl; Fcntl->import('SEEK_SET'); 1; } or *SEEK_SET = sub { 0 } } use version 0.87; BEGIN { if ($INC{'Log/Contextual.pm'}) { require "Log/Contextual/WarnLogger.pm"; # Hide from AutoPrereqs Log::Contextual->import('log_info', '-default_logger' => Log::Contextual::WarnLogger->new({ env_prefix => 'MODULE_METADATA', }), ); } else { *log_info = sub (&) { warn $_[0]->() }; } } use File::Find qw(find); my $V_NUM_REGEXP = qr{v?[0-9._]+}; # crudely, a v-string or decimal my $PKG_FIRST_WORD_REGEXP = qr{ # the FIRST word in a package name [a-zA-Z_] # the first word CANNOT start with a digit (?: [\w']? # can contain letters, digits, _, or ticks \w # But, NO multi-ticks or trailing ticks )* }x; my $PKG_ADDL_WORD_REGEXP = qr{ # the 2nd+ word in a package name \w # the 2nd+ word CAN start with digits (?: [\w']? # and can contain letters or ticks \w # But, NO multi-ticks or trailing ticks )* }x; my $PKG_NAME_REGEXP = qr{ # match a package name (?: :: )? # a pkg name can start with arisdottle $PKG_FIRST_WORD_REGEXP # a package word (?: (?: :: )+ ### arisdottle (allow one or many times) $PKG_ADDL_WORD_REGEXP ### a package word )* # ^ zero, one or many times (?: :: # allow trailing arisdottle )? }x; my $PKG_REGEXP = qr{ # match a package declaration ^[\s\{;]* # intro chars on a line package # the word 'package' \s+ # whitespace ($PKG_NAME_REGEXP) # a package name \s* # optional whitespace ($V_NUM_REGEXP)? # optional version number \s* # optional whitesapce [;\{] # semicolon line terminator or block start (since 5.16) }x; my $VARNAME_REGEXP = qr{ # match fully-qualified VERSION name ([\$*]) # sigil - $ or * ( ( # optional leading package name (?:::|\')? # possibly starting like just :: (a la $::VERSION) (?:\w+(?:::|\'))* # Foo::Bar:: ... )? VERSION )\b }x; my $VERS_REGEXP = qr{ # match a VERSION definition (?: \(\s*$VARNAME_REGEXP\s*\) # with parens | $VARNAME_REGEXP # without parens ) \s* =[^=~>] # = but not ==, nor =~, nor => }x; sub new_from_file { my $class = shift; my $filename = File::Spec->rel2abs( shift ); return undef unless defined( $filename ) && -f $filename; return $class->_init(undef, $filename, @_); } sub new_from_handle { my $class = shift; my $handle = shift; my $filename = shift; return undef unless defined($handle) && defined($filename); $filename = File::Spec->rel2abs( $filename ); return $class->_init(undef, $filename, @_, handle => $handle); } sub new_from_module { my $class = shift; my $module = shift; my %props = @_; $props{inc} ||= \@INC; my $filename = $class->find_module_by_name( $module, $props{inc} ); return undef unless defined( $filename ) && -f $filename; return $class->_init($module, $filename, %props); } { my $compare_versions = sub { my ($v1, $op, $v2) = @_; $v1 = version->new($v1) unless UNIVERSAL::isa($v1,'version'); my $eval_str = "\$v1 $op \$v2"; my $result = eval $eval_str; log_info { "error comparing versions: '$eval_str' $@" } if $@; return $result; }; my $normalize_version = sub { my ($version) = @_; if ( $version =~ /[=<>!,]/ ) { # logic, not just version # take as is without modification } elsif ( ref $version eq 'version' ) { # version objects $version = $version->is_qv ? $version->normal : $version->stringify; } elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots # normalize string tuples without "v": "1.2.3" -> "v1.2.3" $version = "v$version"; } else { # leave alone } return $version; }; # separate out some of the conflict resolution logic my $resolve_module_versions = sub { my $packages = shift; my( $file, $version ); my $err = ''; foreach my $p ( @$packages ) { if ( defined( $p->{version} ) ) { if ( defined( $version ) ) { if ( $compare_versions->( $version, '!=', $p->{version} ) ) { $err .= " $p->{file} ($p->{version})\n"; } else { # same version declared multiple times, ignore } } else { $file = $p->{file}; $version = $p->{version}; } } $file ||= $p->{file} if defined( $p->{file} ); } if ( $err ) { $err = " $file ($version)\n" . $err; } my %result = ( file => $file, version => $version, err => $err ); return \%result; }; sub provides { my $class = shift; croak "provides() requires key/value pairs \n" if @_ % 2; my %args = @_; croak "provides() takes only one of 'dir' or 'files'\n" if $args{dir} && $args{files}; croak "provides() requires a 'version' argument" unless defined $args{version}; croak "provides() does not support version '$args{version}' metadata" unless grep { $args{version} eq $_ } qw/1.4 2/; $args{prefix} = 'lib' unless defined $args{prefix}; my $p; if ( $args{dir} ) { $p = $class->package_versions_from_directory($args{dir}); } else { croak "provides() requires 'files' to be an array reference\n" unless ref $args{files} eq 'ARRAY'; $p = $class->package_versions_from_directory($args{files}); } # Now, fix up files with prefix if ( length $args{prefix} ) { # check in case disabled with q{} $args{prefix} =~ s{/$}{}; for my $v ( values %$p ) { $v->{file} = "$args{prefix}/$v->{file}"; } } return $p } sub package_versions_from_directory { my ( $class, $dir, $files ) = @_; my @files; if ( $files ) { @files = @$files; } else { find( { wanted => sub { push @files, $_ if -f $_ && /\.pm$/; }, no_chdir => 1, }, $dir ); } # First, we enumerate all packages & versions, # separating into primary & alternative candidates my( %prime, %alt ); foreach my $file (@files) { my $mapped_filename = File::Spec::Unix->abs2rel( $file, $dir ); my @path = split( /\//, $mapped_filename ); (my $prime_package = join( '::', @path )) =~ s/\.pm$//; my $pm_info = $class->new_from_file( $file ); foreach my $package ( $pm_info->packages_inside ) { next if $package eq 'main'; # main can appear numerous times, ignore next if $package eq 'DB'; # special debugging package, ignore next if grep /^_/, split( /::/, $package ); # private package, ignore my $version = $pm_info->version( $package ); $prime_package = $package if lc($prime_package) eq lc($package); if ( $package eq $prime_package ) { if ( exists( $prime{$package} ) ) { croak "Unexpected conflict in '$package'; multiple versions found.\n"; } else { $mapped_filename = "$package.pm" if lc("$package.pm") eq lc($mapped_filename); $prime{$package}{file} = $mapped_filename; $prime{$package}{version} = $version if defined( $version ); } } else { push( @{$alt{$package}}, { file => $mapped_filename, version => $version, } ); } } } # Then we iterate over all the packages found above, identifying conflicts # and selecting the "best" candidate for recording the file & version # for each package. foreach my $package ( keys( %alt ) ) { my $result = $resolve_module_versions->( $alt{$package} ); if ( exists( $prime{$package} ) ) { # primary package selected if ( $result->{err} ) { # Use the selected primary package, but there are conflicting # errors among multiple alternative packages that need to be # reported log_info { "Found conflicting versions for package '$package'\n" . " $prime{$package}{file} ($prime{$package}{version})\n" . $result->{err} }; } elsif ( defined( $result->{version} ) ) { # There is a primary package selected, and exactly one # alternative package if ( exists( $prime{$package}{version} ) && defined( $prime{$package}{version} ) ) { # Unless the version of the primary package agrees with the # version of the alternative package, report a conflict if ( $compare_versions->( $prime{$package}{version}, '!=', $result->{version} ) ) { log_info { "Found conflicting versions for package '$package'\n" . " $prime{$package}{file} ($prime{$package}{version})\n" . " $result->{file} ($result->{version})\n" }; } } else { # The prime package selected has no version so, we choose to # use any alternative package that does have a version $prime{$package}{file} = $result->{file}; $prime{$package}{version} = $result->{version}; } } else { # no alt package found with a version, but we have a prime # package so we use it whether it has a version or not } } else { # No primary package was selected, use the best alternative if ( $result->{err} ) { log_info { "Found conflicting versions for package '$package'\n" . $result->{err} }; } # Despite possible conflicting versions, we choose to record # something rather than nothing $prime{$package}{file} = $result->{file}; $prime{$package}{version} = $result->{version} if defined( $result->{version} ); } } # Normalize versions. Can't use exists() here because of bug in YAML::Node. # XXX "bug in YAML::Node" comment seems irrelevant -- dagolden, 2009-05-18 for (grep defined $_->{version}, values %prime) { $_->{version} = $normalize_version->( $_->{version} ); } return \%prime; } } sub _init { my $class = shift; my $module = shift; my $filename = shift; my %props = @_; my $handle = delete $props{handle}; my( %valid_props, @valid_props ); @valid_props = qw( collect_pod inc ); @valid_props{@valid_props} = delete( @props{@valid_props} ); warn "Unknown properties: @{[keys %props]}\n" if scalar( %props ); my %data = ( module => $module, filename => $filename, version => undef, packages => [], versions => {}, pod => {}, pod_headings => [], collect_pod => 0, %valid_props, ); my $self = bless(\%data, $class); if ( not $handle ) { my $filename = $self->{filename}; open $handle, '<', $filename or croak( "Can't open '$filename': $!" ); $self->_handle_bom($handle, $filename); } $self->_parse_fh($handle); unless($self->{module} and length($self->{module})) { my ($v, $d, $f) = File::Spec->splitpath($self->{filename}); if($f =~ /\.pm$/) { $f =~ s/\..+$//; my @candidates = grep /$f$/, @{$self->{packages}}; $self->{module} = shift(@candidates); # punt } else { if(grep /main/, @{$self->{packages}}) { $self->{module} = 'main'; } else { $self->{module} = $self->{packages}[0] || ''; } } } $self->{version} = $self->{versions}{$self->{module}} if defined( $self->{module} ); return $self; } # class method sub _do_find_module { my $class = shift; my $module = shift || croak 'find_module_by_name() requires a package name'; my $dirs = shift || \@INC; my $file = File::Spec->catfile(split( /::/, $module)); foreach my $dir ( @$dirs ) { my $testfile = File::Spec->catfile($dir, $file); return [ File::Spec->rel2abs( $testfile ), $dir ] if -e $testfile and !-d _; # For stuff like ExtUtils::xsubpp $testfile .= '.pm'; return [ File::Spec->rel2abs( $testfile ), $dir ] if -e $testfile; } return; } # class method sub find_module_by_name { my $found = shift()->_do_find_module(@_) or return; return $found->[0]; } # class method sub find_module_dir_by_name { my $found = shift()->_do_find_module(@_) or return; return $found->[1]; } # given a line of perl code, attempt to parse it if it looks like a # $VERSION assignment, returning sigil, full name, & package name sub _parse_version_expression { my $self = shift; my $line = shift; my( $sigil, $variable_name, $package); if ( $line =~ /$VERS_REGEXP/o ) { ( $sigil, $variable_name, $package) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 ); if ( $package ) { $package = ($package eq '::') ? 'main' : $package; $package =~ s/::$//; } } return ( $sigil, $variable_name, $package ); } # Look for a UTF-8/UTF-16BE/UTF-16LE BOM at the beginning of the stream. # If there's one, then skip it and set the :encoding layer appropriately. sub _handle_bom { my ($self, $fh, $filename) = @_; my $pos = tell $fh; return unless defined $pos; my $buf = ' ' x 2; my $count = read $fh, $buf, length $buf; return unless defined $count and $count >= 2; my $encoding; if ( $buf eq "\x{FE}\x{FF}" ) { $encoding = 'UTF-16BE'; } elsif ( $buf eq "\x{FF}\x{FE}" ) { $encoding = 'UTF-16LE'; } elsif ( $buf eq "\x{EF}\x{BB}" ) { $buf = ' '; $count = read $fh, $buf, length $buf; if ( defined $count and $count >= 1 and $buf eq "\x{BF}" ) { $encoding = 'UTF-8'; } } if ( defined $encoding ) { if ( "$]" >= 5.008 ) { binmode( $fh, ":encoding($encoding)" ); } } else { seek $fh, $pos, SEEK_SET or croak( sprintf "Can't reset position to the top of '$filename'" ); } return $encoding; } sub _parse_fh { my ($self, $fh) = @_; my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 ); my( @packages, %vers, %pod, @pod ); my $package = 'main'; my $pod_sect = ''; my $pod_data = ''; my $in_end = 0; while (defined( my $line = <$fh> )) { my $line_num = $.; chomp( $line ); # From toke.c : any line that begins by "=X", where X is an alphabetic # character, introduces a POD segment. my $is_cut; if ( $line =~ /^=([a-zA-Z].*)/ ) { my $cmd = $1; # Then it goes back to Perl code for "=cutX" where X is a non-alphabetic # character (which includes the newline, but here we chomped it away). $is_cut = $cmd =~ /^cut(?:[^a-zA-Z]|$)/; $in_pod = !$is_cut; } if ( $in_pod ) { if ( $line =~ /^=head[1-4]\s+(.+)\s*$/ ) { push( @pod, $1 ); if ( $self->{collect_pod} && length( $pod_data ) ) { $pod{$pod_sect} = $pod_data; $pod_data = ''; } $pod_sect = $1; } elsif ( $self->{collect_pod} ) { $pod_data .= "$line\n"; } } elsif ( $is_cut ) { if ( $self->{collect_pod} && length( $pod_data ) ) { $pod{$pod_sect} = $pod_data; $pod_data = ''; } $pod_sect = ''; } else { # Skip after __END__ next if $in_end; # Skip comments in code next if $line =~ /^\s*#/; # Would be nice if we could also check $in_string or something too if ($line eq '__END__') { $in_end++; next; } last if $line eq '__DATA__'; # parse $line to see if it's a $VERSION declaration my( $version_sigil, $version_fullname, $version_package ) = index($line, 'VERSION') >= 1 ? $self->_parse_version_expression( $line ) : (); if ( $line =~ /$PKG_REGEXP/o ) { $package = $1; my $version = $2; push( @packages, $package ) unless grep( $package eq $_, @packages ); $need_vers = defined $version ? 0 : 1; if ( not exists $vers{$package} and defined $version ){ # Upgrade to a version object. my $dwim_version = eval { _dwim_version($version) }; croak "Version '$version' from $self->{filename} does not appear to be valid:\n$line\n\nThe fatal error was: $@\n" unless defined $dwim_version; # "0" is OK! $vers{$package} = $dwim_version; } # VERSION defined with full package spec, i.e. $Module::VERSION } elsif ( $version_fullname && $version_package ) { push( @packages, $version_package ) unless grep( $version_package eq $_, @packages ); $need_vers = 0 if $version_package eq $package; unless ( defined $vers{$version_package} && length $vers{$version_package} ) { $vers{$version_package} = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line ); } # first non-comment line in undeclared package main is VERSION } elsif ( $package eq 'main' && $version_fullname && !exists($vers{main}) ) { $need_vers = 0; my $v = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line ); $vers{$package} = $v; push( @packages, 'main' ); # first non-comment line in undeclared package defines package main } elsif ( $package eq 'main' && !exists($vers{main}) && $line =~ /\w/ ) { $need_vers = 1; $vers{main} = ''; push( @packages, 'main' ); # only keep if this is the first $VERSION seen } elsif ( $version_fullname && $need_vers ) { $need_vers = 0; my $v = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line ); unless ( defined $vers{$package} && length $vers{$package} ) { $vers{$package} = $v; } } } } if ( $self->{collect_pod} && length($pod_data) ) { $pod{$pod_sect} = $pod_data; } $self->{versions} = \%vers; $self->{packages} = \@packages; $self->{pod} = \%pod; $self->{pod_headings} = \@pod; } { my $pn = 0; sub _evaluate_version_line { my $self = shift; my( $sigil, $variable_name, $line ) = @_; # We compile into a local sub because 'use version' would cause # compiletime/runtime issues with local() $pn++; # everybody gets their own package my $eval = qq{ my \$dummy = q# Hide from _packages_inside() #; package Module::Metadata::_version::p${pn}; use version; sub { local $sigil$variable_name; $line; \$$variable_name }; }; $eval = $1 if $eval =~ m{^(.+)}s; local $^W; # Try to get the $VERSION my $vsub = __clean_eval($eval); # some modules say $VERSION <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 $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 $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 $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 $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 $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 $fatpacked{"version.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'VERSION'; #!perl -w package version; use 5.006002; use strict; use warnings::register; if ($] >= 5.015) { warnings::register_categories(qw/version/); } use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv); $VERSION = 0.9912; $CLASS = 'version'; # !!!!Delete this next block completely when adding to Perl core!!!! { local $SIG{'__DIE__'}; if (1) { # always pretend there's no XS eval "use version::vpp $VERSION"; # don't tempt fate die "$@" if ( $@ ); push @ISA, "version::vpp"; local $^W; *version::qv = \&version::vpp::qv; *version::declare = \&version::vpp::declare; *version::_VERSION = \&version::vpp::_VERSION; *version::vcmp = \&version::vpp::vcmp; *version::new = \&version::vpp::new; *version::numify = \&version::vpp::numify; *version::normal = \&version::vpp::normal; if ($] >= 5.009000) { no strict 'refs'; *version::stringify = \&version::vpp::stringify; *{'version::(""'} = \&version::vpp::stringify; *{'version::(<=>'} = \&version::vpp::vcmp; *version::parse = \&version::vpp::parse; } } else { # use XS module push @ISA, "version::vxs"; local $^W; *version::declare = \&version::vxs::declare; *version::qv = \&version::vxs::qv; *version::_VERSION = \&version::vxs::_VERSION; *version::vcmp = \&version::vxs::VCMP; *version::new = \&version::vxs::new; *version::numify = \&version::vxs::numify; *version::normal = \&version::vxs::normal; if ($] >= 5.009000) { no strict 'refs'; *version::stringify = \&version::vxs::stringify; *{'version::(""'} = \&version::vxs::stringify; *{'version::(<=>'} = \&version::vxs::VCMP; *version::parse = \&version::vxs::parse; } } } # avoid using Exporter require version::regex; *version::is_lax = \&version::regex::is_lax; *version::is_strict = \&version::regex::is_strict; *LAX = \$version::regex::LAX; *STRICT = \$version::regex::STRICT; sub import { no strict 'refs'; my ($class) = shift; # Set up any derived class unless ($class eq $CLASS) { local $^W; *{$class.'::declare'} = \&{$CLASS.'::declare'}; *{$class.'::qv'} = \&{$CLASS.'::qv'}; } my %args; if (@_) { # any remaining terms are arguments map { $args{$_} = 1 } @_ } else { # no parameters at all on use line %args = ( qv => 1, 'UNIVERSAL::VERSION' => 1, ); } my $callpkg = caller(); if (exists($args{declare})) { *{$callpkg.'::declare'} = sub {return $class->declare(shift) } unless defined(&{$callpkg.'::declare'}); } if (exists($args{qv})) { *{$callpkg.'::qv'} = sub {return $class->qv(shift) } unless defined(&{$callpkg.'::qv'}); } if (exists($args{'UNIVERSAL::VERSION'})) { local $^W; *UNIVERSAL::VERSION = \&{$CLASS.'::_VERSION'}; } if (exists($args{'VERSION'})) { *{$callpkg.'::VERSION'} = \&{$CLASS.'::_VERSION'}; } if (exists($args{'is_strict'})) { *{$callpkg.'::is_strict'} = \&{$CLASS.'::is_strict'} unless defined(&{$callpkg.'::is_strict'}); } if (exists($args{'is_lax'})) { *{$callpkg.'::is_lax'} = \&{$CLASS.'::is_lax'} unless defined(&{$callpkg.'::is_lax'}); } } 1; VERSION $fatpacked{"version/regex.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'VERSION_REGEX'; package version::regex; use strict; use vars qw($VERSION $CLASS $STRICT $LAX); $VERSION = 0.9912; #--------------------------------------------------------------------------# # Version regexp components #--------------------------------------------------------------------------# # Fraction part of a decimal version number. This is a common part of # both strict and lax decimal versions my $FRACTION_PART = qr/\.[0-9]+/; # First part of either decimal or dotted-decimal strict version number. # Unsigned integer with no leading zeroes (except for zero itself) to # avoid confusion with octal. my $STRICT_INTEGER_PART = qr/0|[1-9][0-9]*/; # First part of either decimal or dotted-decimal lax version number. # Unsigned integer, but allowing leading zeros. Always interpreted # as decimal. However, some forms of the resulting syntax give odd # results if used as ordinary Perl expressions, due to how perl treats # octals. E.g. # version->new("010" ) == 10 # version->new( 010 ) == 8 # version->new( 010.2) == 82 # "8" . "2" my $LAX_INTEGER_PART = qr/[0-9]+/; # Second and subsequent part of a strict dotted-decimal version number. # Leading zeroes are permitted, and the number is always decimal. # Limited to three digits to avoid overflow when converting to decimal # form and also avoid problematic style with excessive leading zeroes. my $STRICT_DOTTED_DECIMAL_PART = qr/\.[0-9]{1,3}/; # Second and subsequent part of a lax dotted-decimal version number. # Leading zeroes are permitted, and the number is always decimal. No # limit on the numerical value or number of digits, so there is the # possibility of overflow when converting to decimal form. my $LAX_DOTTED_DECIMAL_PART = qr/\.[0-9]+/; # Alpha suffix part of lax version number syntax. Acts like a # dotted-decimal part. my $LAX_ALPHA_PART = qr/_[0-9]+/; #--------------------------------------------------------------------------# # Strict version regexp definitions #--------------------------------------------------------------------------# # Strict decimal version number. my $STRICT_DECIMAL_VERSION = qr/ $STRICT_INTEGER_PART $FRACTION_PART? /x; # Strict dotted-decimal version number. Must have both leading "v" and # at least three parts, to avoid confusion with decimal syntax. my $STRICT_DOTTED_DECIMAL_VERSION = qr/ v $STRICT_INTEGER_PART $STRICT_DOTTED_DECIMAL_PART{2,} /x; # Complete strict version number syntax -- should generally be used # anchored: qr/ \A $STRICT \z /x $STRICT = qr/ $STRICT_DECIMAL_VERSION | $STRICT_DOTTED_DECIMAL_VERSION /x; #--------------------------------------------------------------------------# # Lax version regexp definitions #--------------------------------------------------------------------------# # Lax decimal version number. Just like the strict one except for # allowing an alpha suffix or allowing a leading or trailing # decimal-point my $LAX_DECIMAL_VERSION = qr/ $LAX_INTEGER_PART (?: \. | $FRACTION_PART $LAX_ALPHA_PART? )? | $FRACTION_PART $LAX_ALPHA_PART? /x; # Lax dotted-decimal version number. Distinguished by having either # leading "v" or at least three non-alpha parts. Alpha part is only # permitted if there are at least two non-alpha parts. Strangely # enough, without the leading "v", Perl takes .1.2 to mean v0.1.2, # so when there is no "v", the leading part is optional my $LAX_DOTTED_DECIMAL_VERSION = qr/ v $LAX_INTEGER_PART (?: $LAX_DOTTED_DECIMAL_PART+ $LAX_ALPHA_PART? )? | $LAX_INTEGER_PART? $LAX_DOTTED_DECIMAL_PART{2,} $LAX_ALPHA_PART? /x; # Complete lax version number syntax -- should generally be used # anchored: qr/ \A $LAX \z /x # # The string 'undef' is a special case to make for easier handling # of return values from ExtUtils::MM->parse_version $LAX = qr/ undef | $LAX_DECIMAL_VERSION | $LAX_DOTTED_DECIMAL_VERSION /x; #--------------------------------------------------------------------------# # Preloaded methods go here. sub is_strict { defined $_[0] && $_[0] =~ qr/ \A $STRICT \z /x } sub is_lax { defined $_[0] && $_[0] =~ qr/ \A $LAX \z /x } 1; VERSION_REGEX $fatpacked{"version/vpp.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'VERSION_VPP'; package charstar; # a little helper class to emulate C char* semantics in Perl # so that prescan_version can use the same code as in C use overload ( '""' => \&thischar, '0+' => \&thischar, '++' => \&increment, '--' => \&decrement, '+' => \&plus, '-' => \&minus, '*' => \&multiply, 'cmp' => \&cmp, '<=>' => \&spaceship, 'bool' => \&thischar, '=' => \&clone, ); sub new { my ($self, $string) = @_; my $class = ref($self) || $self; my $obj = { string => [split(//,$string)], current => 0, }; return bless $obj, $class; } sub thischar { my ($self) = @_; my $last = $#{$self->{string}}; my $curr = $self->{current}; if ($curr >= 0 && $curr <= $last) { return $self->{string}->[$curr]; } else { return ''; } } sub increment { my ($self) = @_; $self->{current}++; } sub decrement { my ($self) = @_; $self->{current}--; } sub plus { my ($self, $offset) = @_; my $rself = $self->clone; $rself->{current} += $offset; return $rself; } sub minus { my ($self, $offset) = @_; my $rself = $self->clone; $rself->{current} -= $offset; return $rself; } sub multiply { my ($left, $right, $swapped) = @_; my $char = $left->thischar(); return $char * $right; } sub spaceship { my ($left, $right, $swapped) = @_; unless (ref($right)) { # not an object already $right = $left->new($right); } return $left->{current} <=> $right->{current}; } sub cmp { my ($left, $right, $swapped) = @_; unless (ref($right)) { # not an object already if (length($right) == 1) { # comparing single character only return $left->thischar cmp $right; } $right = $left->new($right); } return $left->currstr cmp $right->currstr; } sub bool { my ($self) = @_; my $char = $self->thischar; return ($char ne ''); } sub clone { my ($left, $right, $swapped) = @_; $right = { string => [@{$left->{string}}], current => $left->{current}, }; return bless $right, ref($left); } sub currstr { my ($self, $s) = @_; my $curr = $self->{current}; my $last = $#{$self->{string}}; if (defined($s) && $s->{current} < $last) { $last = $s->{current}; } my $string = join('', @{$self->{string}}[$curr..$last]); return $string; } package version::vpp; use 5.006002; use strict; use warnings::register; use Config; use vars qw($VERSION $CLASS @ISA $LAX $STRICT $WARN_CATEGORY); $VERSION = 0.9912; $CLASS = 'version::vpp'; if ($] > 5.015) { warnings::register_categories(qw/version/); $WARN_CATEGORY = 'version'; } else { $WARN_CATEGORY = 'numeric'; } require version::regex; *version::vpp::is_strict = \&version::regex::is_strict; *version::vpp::is_lax = \&version::regex::is_lax; *LAX = \$version::regex::LAX; *STRICT = \$version::regex::STRICT; use overload ( '""' => \&stringify, '0+' => \&numify, 'cmp' => \&vcmp, '<=>' => \&vcmp, 'bool' => \&vbool, '+' => \&vnoop, '-' => \&vnoop, '*' => \&vnoop, '/' => \&vnoop, '+=' => \&vnoop, '-=' => \&vnoop, '*=' => \&vnoop, '/=' => \&vnoop, 'abs' => \&vnoop, ); sub import { no strict 'refs'; my ($class) = shift; # Set up any derived class unless ($class eq $CLASS) { local $^W; *{$class.'::declare'} = \&{$CLASS.'::declare'}; *{$class.'::qv'} = \&{$CLASS.'::qv'}; } my %args; if (@_) { # any remaining terms are arguments map { $args{$_} = 1 } @_ } else { # no parameters at all on use line %args = ( qv => 1, 'UNIVERSAL::VERSION' => 1, ); } my $callpkg = caller(); if (exists($args{declare})) { *{$callpkg.'::declare'} = sub {return $class->declare(shift) } unless defined(&{$callpkg.'::declare'}); } if (exists($args{qv})) { *{$callpkg.'::qv'} = sub {return $class->qv(shift) } unless defined(&{$callpkg.'::qv'}); } if (exists($args{'UNIVERSAL::VERSION'})) { no warnings qw/redefine/; *UNIVERSAL::VERSION = \&{$CLASS.'::_VERSION'}; } if (exists($args{'VERSION'})) { *{$callpkg.'::VERSION'} = \&{$CLASS.'::_VERSION'}; } if (exists($args{'is_strict'})) { *{$callpkg.'::is_strict'} = \&{$CLASS.'::is_strict'} unless defined(&{$callpkg.'::is_strict'}); } if (exists($args{'is_lax'})) { *{$callpkg.'::is_lax'} = \&{$CLASS.'::is_lax'} unless defined(&{$callpkg.'::is_lax'}); } } my $VERSION_MAX = 0x7FFFFFFF; # implement prescan_version as closely to the C version as possible use constant TRUE => 1; use constant FALSE => 0; sub isDIGIT { my ($char) = shift->thischar(); return ($char =~ /\d/); } sub isALPHA { my ($char) = shift->thischar(); return ($char =~ /[a-zA-Z]/); } sub isSPACE { my ($char) = shift->thischar(); return ($char =~ /\s/); } sub BADVERSION { my ($s, $errstr, $error) = @_; if ($errstr) { $$errstr = $error; } return $s; } sub prescan_version { my ($s, $strict, $errstr, $sqv, $ssaw_decimal, $swidth, $salpha) = @_; my $qv = defined $sqv ? $$sqv : FALSE; my $saw_decimal = defined $ssaw_decimal ? $$ssaw_decimal : 0; my $width = defined $swidth ? $$swidth : 3; my $alpha = defined $salpha ? $$salpha : FALSE; my $d = $s; if ($qv && isDIGIT($d)) { goto dotted_decimal_version; } if ($d eq 'v') { # explicit v-string $d++; if (isDIGIT($d)) { $qv = TRUE; } else { # degenerate v-string # requires v1.2.3 return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); } dotted_decimal_version: if ($strict && $d eq '0' && isDIGIT($d+1)) { # no leading zeros allowed return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)"); } while (isDIGIT($d)) { # integer part $d++; } if ($d eq '.') { $saw_decimal++; $d++; # decimal point } else { if ($strict) { # require v1.2.3 return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); } else { goto version_prescan_finish; } } { my $i = 0; my $j = 0; while (isDIGIT($d)) { # just keep reading $i++; while (isDIGIT($d)) { $d++; $j++; # maximum 3 digits between decimal if ($strict && $j > 3) { return BADVERSION($s,$errstr,"Invalid version format (maximum 3 digits between decimals)"); } } if ($d eq '_') { if ($strict) { return BADVERSION($s,$errstr,"Invalid version format (no underscores)"); } if ( $alpha ) { return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)"); } $d++; $alpha = TRUE; } elsif ($d eq '.') { if ($alpha) { return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)"); } $saw_decimal++; $d++; } elsif (!isDIGIT($d)) { last; } $j = 0; } if ($strict && $i < 2) { # requires v1.2.3 return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); } } } # end if dotted-decimal else { # decimal versions my $j = 0; # special $strict case for leading '.' or '0' if ($strict) { if ($d eq '.') { return BADVERSION($s,$errstr,"Invalid version format (0 before decimal required)"); } if ($d eq '0' && isDIGIT($d+1)) { return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)"); } } # and we never support negative version numbers if ($d eq '-') { return BADVERSION($s,$errstr,"Invalid version format (negative version number)"); } # consume all of the integer part while (isDIGIT($d)) { $d++; } # look for a fractional part if ($d eq '.') { # we found it, so consume it $saw_decimal++; $d++; } elsif (!$d || $d eq ';' || isSPACE($d) || $d eq '}') { if ( $d == $s ) { # found nothing return BADVERSION($s,$errstr,"Invalid version format (version required)"); } # found just an integer goto version_prescan_finish; } elsif ( $d == $s ) { # didn't find either integer or period return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)"); } elsif ($d eq '_') { # underscore can't come after integer part if ($strict) { return BADVERSION($s,$errstr,"Invalid version format (no underscores)"); } elsif (isDIGIT($d+1)) { return BADVERSION($s,$errstr,"Invalid version format (alpha without decimal)"); } else { return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)"); } } elsif ($d) { # anything else after integer part is just invalid data return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)"); } # scan the fractional part after the decimal point if ($d && !isDIGIT($d) && ($strict || ! ($d eq ';' || isSPACE($d) || $d eq '}') )) { # $strict or lax-but-not-the-end return BADVERSION($s,$errstr,"Invalid version format (fractional part required)"); } while (isDIGIT($d)) { $d++; $j++; if ($d eq '.' && isDIGIT($d-1)) { if ($alpha) { return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)"); } if ($strict) { return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions must begin with 'v')"); } $d = $s; # start all over again $qv = TRUE; goto dotted_decimal_version; } if ($d eq '_') { if ($strict) { return BADVERSION($s,$errstr,"Invalid version format (no underscores)"); } if ( $alpha ) { return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)"); } if ( ! isDIGIT($d+1) ) { return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)"); } $width = $j; $d++; $alpha = TRUE; } } } version_prescan_finish: while (isSPACE($d)) { $d++; } if ($d && !isDIGIT($d) && (! ($d eq ';' || $d eq '}') )) { # trailing non-numeric data return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)"); } if ($saw_decimal > 1 && ($d-1) eq '.') { # no trailing period allowed return BADVERSION($s,$errstr,"Invalid version format (trailing decimal)"); } if (defined $sqv) { $$sqv = $qv; } if (defined $swidth) { $$swidth = $width; } if (defined $ssaw_decimal) { $$ssaw_decimal = $saw_decimal; } if (defined $salpha) { $$salpha = $alpha; } return $d; } sub scan_version { my ($s, $rv, $qv) = @_; my $start; my $pos; my $last; my $errstr; my $saw_decimal = 0; my $width = 3; my $alpha = FALSE; my $vinf = FALSE; my @av; $s = new charstar $s; while (isSPACE($s)) { # leading whitespace is OK $s++; } $last = prescan_version($s, FALSE, \$errstr, \$qv, \$saw_decimal, \$width, \$alpha); if ($errstr) { # 'undef' is a special case and not an error if ( $s ne 'undef') { require Carp; Carp::croak($errstr); } } $start = $s; if ($s eq 'v') { $s++; } $pos = $s; if ( $qv ) { $$rv->{qv} = $qv; } if ( $alpha ) { $$rv->{alpha} = $alpha; } if ( !$qv && $width < 3 ) { $$rv->{width} = $width; } while (isDIGIT($pos)) { $pos++; } if (!isALPHA($pos)) { my $rev; for (;;) { $rev = 0; { # this is atoi() that delimits on underscores my $end = $pos; my $mult = 1; my $orev; # the following if() will only be true after the decimal # point of a version originally created with a bare # floating point number, i.e. not quoted in any way # if ( !$qv && $s > $start && $saw_decimal == 1 ) { $mult *= 100; while ( $s < $end ) { $orev = $rev; $rev += $s * $mult; $mult /= 10; if ( (abs($orev) > abs($rev)) || (abs($rev) > $VERSION_MAX )) { warn("Integer overflow in version %d", $VERSION_MAX); $s = $end - 1; $rev = $VERSION_MAX; $vinf = 1; } $s++; if ( $s eq '_' ) { $s++; } } } else { while (--$end >= $s) { $orev = $rev; $rev += $end * $mult; $mult *= 10; if ( (abs($orev) > abs($rev)) || (abs($rev) > $VERSION_MAX )) { warn("Integer overflow in version"); $end = $s - 1; $rev = $VERSION_MAX; $vinf = 1; } } } } # Append revision push @av, $rev; if ( $vinf ) { $s = $last; last; } elsif ( $pos eq '.' ) { $pos++; if ($qv) { # skip leading zeros while ($pos eq '0') { $pos++; } } $s = $pos; } elsif ( $pos eq '_' && isDIGIT($pos+1) ) { $s = ++$pos; } elsif ( $pos eq ',' && isDIGIT($pos+1) ) { $s = ++$pos; } elsif ( isDIGIT($pos) ) { $s = $pos; } else { $s = $pos; last; } if ( $qv ) { while ( isDIGIT($pos) ) { $pos++; } } else { my $digits = 0; while ( ( isDIGIT($pos) || $pos eq '_' ) && $digits < 3 ) { if ( $pos ne '_' ) { $digits++; } $pos++; } } } } if ( $qv ) { # quoted versions always get at least three terms my $len = $#av; # This for loop appears to trigger a compiler bug on OS X, as it # loops infinitely. Yes, len is negative. No, it makes no sense. # Compiler in question is: # gcc version 3.3 20030304 (Apple Computer, Inc. build 1640) # for ( len = 2 - len; len > 0; len-- ) # av_push(MUTABLE_AV(sv), newSViv(0)); # $len = 2 - $len; while ($len-- > 0) { push @av, 0; } } # need to save off the current version string for later if ( $vinf ) { $$rv->{original} = "v.Inf"; $$rv->{vinf} = 1; } elsif ( $s > $start ) { $$rv->{original} = $start->currstr($s); if ( $qv && $saw_decimal == 1 && $start ne 'v' ) { # need to insert a v to be consistent $$rv->{original} = 'v' . $$rv->{original}; } } else { $$rv->{original} = '0'; push(@av, 0); } # And finally, store the AV in the hash $$rv->{version} = \@av; # fix RT#19517 - special case 'undef' as string if ($s eq 'undef') { $s += 5; } return $s; } sub new { my $class = shift; unless (defined $class or $#_ > 1) { require Carp; Carp::croak('Usage: version::new(class, version)'); } my $self = bless ({}, ref ($class) || $class); my $qv = FALSE; if ( $#_ == 1 ) { # must be CVS-style $qv = TRUE; } my $value = pop; # always going to be the last element if ( ref($value) && eval('$value->isa("version")') ) { # Can copy the elements directly $self->{version} = [ @{$value->{version} } ]; $self->{qv} = 1 if $value->{qv}; $self->{alpha} = 1 if $value->{alpha}; $self->{original} = ''.$value->{original}; return $self; } if ( not defined $value or $value =~ /^undef$/ ) { # RT #19517 - special case for undef comparison # or someone forgot to pass a value push @{$self->{version}}, 0; $self->{original} = "0"; return ($self); } if (ref($value) =~ m/ARRAY|HASH/) { require Carp; Carp::croak("Invalid version format (non-numeric data)"); } $value = _un_vstring($value); if ($Config{d_setlocale}) { use POSIX qw/locale_h/; use if $Config{d_setlocale}, 'locale'; my $currlocale = setlocale(LC_ALL); # if the current locale uses commas for decimal points, we # just replace commas with decimal places, rather than changing # locales if ( localeconv()->{decimal_point} eq ',' ) { $value =~ tr/,/./; } } # exponential notation if ( $value =~ /\d+.?\d*e[-+]?\d+/ ) { $value = sprintf("%.9f",$value); $value =~ s/(0+)$//; # trim trailing zeros } my $s = scan_version($value, \$self, $qv); if ($s) { # must be something left over warn("Version string '%s' contains invalid data; " ."ignoring: '%s'", $value, $s); } return ($self); } *parse = \&new; sub numify { my ($self) = @_; unless (_verify($self)) { require Carp; Carp::croak("Invalid version object"); } my $width = $self->{width} || 3; my $alpha = $self->{alpha} || ""; my $len = $#{$self->{version}}; my $digit = $self->{version}[0]; my $string = sprintf("%d.", $digit ); if ($alpha and warnings::enabled()) { warnings::warn($WARN_CATEGORY, 'alpha->numify() is lossy'); } for ( my $i = 1 ; $i < $len ; $i++ ) { $digit = $self->{version}[$i]; if ( $width < 3 ) { my $denom = 10**(3-$width); my $quot = int($digit/$denom); my $rem = $digit - ($quot * $denom); $string .= sprintf("%0".$width."d_%d", $quot, $rem); } else { $string .= sprintf("%03d", $digit); } } if ( $len > 0 ) { $digit = $self->{version}[$len]; if ( $alpha && $width == 3 ) { $string .= "_"; } $string .= sprintf("%0".$width."d", $digit); } else # $len = 0 { $string .= sprintf("000"); } return $string; } sub normal { my ($self) = @_; unless (_verify($self)) { require Carp; Carp::croak("Invalid version object"); } my $alpha = $self->{alpha} || ""; my $qv = $self->{qv} || ""; my $len = $#{$self->{version}}; my $digit = $self->{version}[0]; my $string = sprintf("v%d", $digit ); for ( my $i = 1 ; $i < $len ; $i++ ) { $digit = $self->{version}[$i]; $string .= sprintf(".%d", $digit); } if ( $len > 0 ) { $digit = $self->{version}[$len]; if ( $alpha ) { $string .= sprintf("_%0d", $digit); } else { $string .= sprintf(".%0d", $digit); } } if ( $len <= 2 ) { for ( $len = 2 - $len; $len != 0; $len-- ) { $string .= sprintf(".%0d", 0); } } return $string; } sub stringify { my ($self) = @_; unless (_verify($self)) { require Carp; Carp::croak("Invalid version object"); } return exists $self->{original} ? $self->{original} : exists $self->{qv} ? $self->normal : $self->numify; } sub vcmp { require UNIVERSAL; my ($left,$right,$swap) = @_; my $class = ref($left); unless ( UNIVERSAL::isa($right, $class) ) { $right = $class->new($right); } if ( $swap ) { ($left, $right) = ($right, $left); } unless (_verify($left)) { require Carp; Carp::croak("Invalid version object"); } unless (_verify($right)) { require Carp; Carp::croak("Invalid version format"); } my $l = $#{$left->{version}}; my $r = $#{$right->{version}}; my $m = $l < $r ? $l : $r; my $lalpha = $left->is_alpha; my $ralpha = $right->is_alpha; my $retval = 0; my $i = 0; while ( $i <= $m && $retval == 0 ) { $retval = $left->{version}[$i] <=> $right->{version}[$i]; $i++; } # tiebreaker for alpha with identical terms if ( $retval == 0 && $l == $r && $left->{version}[$m] == $right->{version}[$m] && ( $lalpha || $ralpha ) ) { if ( $lalpha && !$ralpha ) { $retval = -1; } elsif ( $ralpha && !$lalpha) { $retval = +1; } } # possible match except for trailing 0's if ( $retval == 0 && $l != $r ) { if ( $l < $r ) { while ( $i <= $r && $retval == 0 ) { if ( $right->{version}[$i] != 0 ) { $retval = -1; # not a match after all } $i++; } } else { while ( $i <= $l && $retval == 0 ) { if ( $left->{version}[$i] != 0 ) { $retval = +1; # not a match after all } $i++; } } } return $retval; } sub vbool { my ($self) = @_; return vcmp($self,$self->new("0"),1); } sub vnoop { require Carp; Carp::croak("operation not supported with version object"); } sub is_alpha { my ($self) = @_; return (exists $self->{alpha}); } sub qv { my $value = shift; my $class = $CLASS; if (@_) { $class = ref($value) || $value; $value = shift; } $value = _un_vstring($value); $value = 'v'.$value unless $value =~ /(^v|\d+\.\d+\.\d)/; my $obj = $CLASS->new($value); return bless $obj, $class; } *declare = \&qv; sub is_qv { my ($self) = @_; return (exists $self->{qv}); } sub _verify { my ($self) = @_; if ( ref($self) && eval { exists $self->{version} } && ref($self->{version}) eq 'ARRAY' ) { return 1; } else { return 0; } } sub _is_non_alphanumeric { my $s = shift; $s = new charstar $s; while ($s) { return 0 if isSPACE($s); # early out return 1 unless (isALPHA($s) || isDIGIT($s) || $s =~ /[.-]/); $s++; } return 0; } sub _un_vstring { my $value = shift; # may be a v-string if ( length($value) >= 1 && $value !~ /[,._]/ && _is_non_alphanumeric($value)) { my $tvalue; if ( $] >= 5.008_001 ) { $tvalue = _find_magic_vstring($value); $value = $tvalue if length $tvalue; } elsif ( $] >= 5.006_000 ) { $tvalue = sprintf("v%vd",$value); if ( $tvalue =~ /^v\d+(\.\d+)*$/ ) { # must be a v-string $value = $tvalue; } } } return $value; } sub _find_magic_vstring { my $value = shift; my $tvalue = ''; require B; my $sv = B::svref_2object(\$value); my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef; while ( $magic ) { if ( $magic->TYPE eq 'V' ) { $tvalue = $magic->PTR; $tvalue =~ s/^v?(.+)$/v$1/; last; } else { $magic = $magic->MOREMAGIC; } } return $tvalue; } sub _VERSION { my ($obj, $req) = @_; my $class = ref($obj) || $obj; no strict 'refs'; if ( exists $INC{"$class.pm"} and not %{"$class\::"} and $] >= 5.008) { # file but no package require Carp; Carp::croak( "$class defines neither package nor VERSION" ."--version check failed"); } my $version = eval "\$$class\::VERSION"; if ( defined $version ) { local $^W if $] <= 5.008; $version = version::vpp->new($version); } if ( defined $req ) { unless ( defined $version ) { require Carp; my $msg = $] < 5.006 ? "$class version $req required--this is only version " : "$class does not define \$$class\::VERSION" ."--version check failed"; if ( $ENV{VERSION_DEBUG} ) { Carp::confess($msg); } else { Carp::croak($msg); } } $req = version::vpp->new($req); if ( $req > $version ) { require Carp; if ( $req->is_qv ) { Carp::croak( sprintf ("%s version %s required--". "this is only version %s", $class, $req->normal, $version->normal) ); } else { Carp::croak( sprintf ("%s version %s required--". "this is only version %s", $class, $req->stringify, $version->stringify) ); } } } return defined $version ? $version->stringify : undef; } 1; #this line is important and will help the module return a true value VERSION_VPP s/^ //mg for values %fatpacked; my $class = 'FatPacked::'.(0+\%fatpacked); no strict 'refs'; *{"${class}::files"} = sub { keys %{$_[0]} }; if ($] < 5.008) { *{"${class}::INC"} = sub { if (my $fat = $_[0]{$_[1]}) { 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; }); } }; } else { *{"${class}::INC"} = sub { if (my $fat = $_[0]{$_[1]}) { open my $fh, '<', \$fat or die "FatPacker error loading $_[1] (could be a perl installation issue?)"; return $fh; } return; }; } unshift @INC, bless \%fatpacked, $class; } # END OF FATPACK CODE use strict; use App::cpanminus::script; unless (caller) { my $app = App::cpanminus::script->new; $app->parse_options(@ARGV); exit $app->doit; } __END__ =head1 NAME cpanm - get, unpack build and install modules from CPAN =head1 SYNOPSIS cpanm Test::More # install Test::More cpanm MIYAGAWA/Plack-0.99_05.tar.gz # full distribution path cpanm http://example.org/LDS/CGI.pm-3.20.tar.gz # install from URL cpanm ~/dists/MyCompany-Enterprise-1.00.tar.gz # install from a local file cpanm --interactive Task::Kensho # Configure interactively cpanm . # install from local directory cpanm --installdeps . # install all the deps for the current directory cpanm -L extlib Plack # install Plack and all non-core deps into extlib cpanm --mirror http://cpan.cpantesters.org/ DBI # use the fast-syncing mirror cpanm --from https://cpan.metacpan.org/ Plack # use only the HTTPS mirror =head1 COMMANDS =over 4 =item (arguments) Command line arguments can be either a module name, distribution file, local file path, HTTP URL or git repository URL. Following commands will all work as you expect. cpanm Plack cpanm Plack/Request.pm cpanm MIYAGAWA/Plack-1.0000.tar.gz cpanm /path/to/Plack-1.0000.tar.gz cpanm http://cpan.metacpan.org/authors/id/M/MI/MIYAGAWA/Plack-0.9990.tar.gz cpanm git://github.com/plack/Plack.git Additionally, you can use the notation using C<~> and C<@> to specify version for a given module. C<~> specifies the version requirement in the L<CPAN::Meta::Spec> format, while C<@> pins the exact version, and is a shortcut for C<~"== VERSION">. cpanm Plack~1.0000 # 1.0000 or later cpanm Plack~">= 1.0000, < 2.0000" # latest of 1.xxxx cpanm Plack@0.9990 # specific version. same as Plack~"== 0.9990" The version query including specific version or range will be sent to L<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. For a git repository, you can specify a branch, tag, or commit SHA to build. The default is C<master> cpanm git://github.com/plack/Plack.git@1.0000 # tag cpanm git://github.com/plack/Plack.git@devel # branch =item -i, --install Installs the modules. This is a default behavior and this is just a compatibility option to make it work like L<cpan> or L<cpanp>. =item --self-upgrade Upgrades itself. It's just an alias for: cpanm App::cpanminus =item --info Displays the distribution information in C<AUTHOR/Dist-Name-ver.tar.gz> format in the standard out. =item --installdeps Installs the dependencies of the target distribution but won't build itself. Handy if you want to try the application from a version controlled repository such as git. cpanm --installdeps . =item --look Download and unpack the distribution and then open the directory with your shell. Handy to poke around the source code or do manual testing. =item -h, --help Displays the help message. =item -V, --version Displays the version number. =back =head1 OPTIONS You can specify the default options in C<PERL_CPANM_OPT> environment variable. =over 4 =item -f, --force Force install modules even when testing failed. =item -n, --notest Skip the testing of modules. Use this only when you just want to save time for installing hundreds of distributions to the same perl and architecture you've already tested to make sure it builds fine. Defaults to false, and you can say C<--no-notest> to override when it is set in the default options in C<PERL_CPANM_OPT>. =item --test-only Run the tests only, and do not install the specified module or distributions. Handy if you want to verify the new (or even old) releases pass its unit tests without installing the module. Note that if you specify this option with a module or distribution that has dependencies, these dependencies will be installed if you don't currently have them. =item -S, --sudo Switch to the root user with C<sudo> when installing modules. Use this if you want to install modules to the system perl include path. Defaults to false, and you can say C<--no-sudo> to override when it is set in the default options in C<PERL_CPANM_OPT>. =item -v, --verbose Makes the output verbose. It also enables the interactive configuration. (See --interactive) =item -q, --quiet Makes the output even more quiet than the default. It only shows the successful/failed dependencies to the output. =item -l, --local-lib Sets the L<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. =item -L, --local-lib-contained Same with C<--local-lib> but with L<--self-contained> set. All non-core dependencies will be installed even if they're already installed. For instance, cpanm -L extlib Plack would install Plack and all of its non-core dependencies into the directory C<extlib>, which can be loaded from your application with: use local::lib '/path/to/extlib'; 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. =item --self-contained When examining the dependencies, assume no non-core modules are installed on the system. Handy if you want to bundle application dependencies in one directory so you can distribute to other machines. =item --exclude-vendor Don't include modules installed under the 'vendor' paths when searching for core modules when the C<--self-contained> flag is in effect. This restores the behaviour from before version 1.7023 =item --mirror Specifies the base URL for the CPAN mirror to use, such as C<http://cpan.cpantesters.org/> (you can omit the trailing slash). You can specify multiple mirror URLs by repeating the command line option. You can use a local directory that has a CPAN mirror structure (created by tools such as L<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. cpanm --mirror file:///path/to/mirror cpanm --mirror ~/minicpan # Because shell expands ~ to /home/user Defaults to C<http://www.cpan.org/>. =item --mirror-only Download the mirror's 02packages.details.txt.gz index file instead of querying the CPAN Meta DB. This will also effectively opt out sending your local perl versions to backend database servers such as CPAN Meta DB and MetaCPAN. Select this option if you are using a local mirror of CPAN, such as minicpan when you're offline, or your own CPAN index (a.k.a darkpan). =item --from, -M cpanm -M https://cpan.metacpan.org/ cpanm --from https://cpan.metacpan.org/ Use the given mirror URL and its index as the I<only> source to search and download modules from. It works similar to C<--mirror> and C<--mirror-only> combined, with a small difference: unlike C<--mirror> which I<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. B<Tip:> It might be useful if you name these options with your shell aliases, like: alias minicpanm='cpanm --from ~/minicpan' alias darkpan='cpanm --from http://mycompany.example.com/DPAN' =item --mirror-index B<EXPERIMENTAL>: Specifies the file path to C<02packages.details.txt> for module search index. =item --cpanmetadb B<EXPERIMENTAL>: Specifies an alternate URI for CPAN MetaDB index lookups. =item --metacpan Prefers MetaCPAN API over CPAN MetaDB. =item --cpanfile B<EXPERIMENTAL>: Specified an alternate path for cpanfile to search for, when C<--installdeps> command is in use. Defaults to C<cpanfile>. =item --prompt Prompts when a test fails so that you can skip, force install, retry or look in the shell to see what's going wrong. It also prompts when one of the dependency failed if you want to proceed the installation. Defaults to false, and you can say C<--no-prompt> to override if it's set in the default options in C<PERL_CPANM_OPT>. =item --dev B<EXPERIMENTAL>: search for a newer developer release as well. Defaults to false. =item --reinstall cpanm, when given a module name in the command line (i.e. C<cpanm Plack>), checks the locally installed version first and skips if it is already installed. This option makes it skip the check, so: cpanm --reinstall Plack would reinstall L<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). Defaults to false. =item --interactive 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. 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>. =item --pp, --pureperl 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. =item --with-recommends, --with-suggests 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. 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. There's also C<--without-recommend> and C<--without-suggests> to override the default decision made earlier in C<PERL_CPANM_OPT>. Defaults to false for both. =item --with-develop B<EXPERIMENTAL>: Installs develop phase dependencies in META files or C<cpanfile> when used with C<--installdeps>. Defaults to false. =item --with-configure B<EXPERIMENTAL>: Installs configure phase dependencies in C<cpanfile> when used with C<--installdeps>. Defaults to false. =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. cpanm --with-feature=opt_csv Spreadsheet::Read the features can also be interactively chosen when C<--interactive> option is enabled. C<--with-all-features> enables all the optional features, and C<--without-feature> can select a feature to disable. =item --configure-timeout, --build-timeout, --test-timeout Specify the timeout length (in seconds) to wait for the configure, build and test process. Current default values are: 60 for configure, 3600 for build and 1800 for test. =item --configure-args, --build-args, --test-args, --install-args B<EXPERIMENTAL>: Pass arguments for configure/build/test/install commands respectively, for a given module to install. cpanm DBD::mysql --configure-args="--cflags=... --libs=..." The argument is only enabled for the module passed as a command line argument, not dependencies. =item --scandeps B<DEPRECATED>: Scans the depencencies of given modules and output the tree in a text format. (See C<--format> below for more options) Because this command doesn't actually install any distributions, it will be useful that by typing: cpanm --scandeps Catalyst::Runtime you can make sure what modules will be installed. This command takes into account which modules you already have installed in your system. If you want to see what modules will be installed against a vanilla perl installation, you might want to combine it with C<-L> option. =item --format B<DEPRECATED>: Determines what format to display the scanned dependency tree. Available options are C<tree>, C<json>, C<yaml> and C<dists>. =over 8 =item tree Displays the tree in a plain text format. This is the default value. =item json, yaml Outputs the tree in a JSON or YAML format. L<JSON> and L<YAML> modules need to be installed respectively. The output tree is represented as a recursive tuple of: [ distribution, dependencies ] and the container is an array containing the root elements. Note that there may be multiple root nodes, since you can give multiple modules to the C<--scandeps> command. =item dists C<dists> is a special output format, where it prints the distribution filename in the I<depth first order> after the dependency resolution, like: GAAS/MIME-Base64-3.13.tar.gz GAAS/URI-1.58.tar.gz PETDANCE/HTML-Tagset-3.20.tar.gz GAAS/HTML-Parser-3.68.tar.gz GAAS/libwww-perl-5.837.tar.gz which means you can install these distributions in this order without extra dependencies. When combined with C<-L> option, it will be useful to replay installations on other machines. =back =item --save-dists Specifies the optional directory path to copy downloaded tarballs in the CPAN mirror compatible directory structure i.e. I<authors/id/A/AU/AUTHORS/Foo-Bar-version.tar.gz> 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>. =item --uninst-shadows Uninstalls the shadow files of the distribution that you're installing. This eliminates the confusion if you're trying to install core (dual-life) modules from CPAN against perl 5.10 or older, or modules that used to be XS-based but switched to pure perl at some version. If you run cpanm as root and use C<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. Defaults to true if your perl version is smaller than 5.12, and you can disable that with C<--no-uninst-shadows>. 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. =item --uninstall, -U Uninstalls a module from the library path. It finds a packlist for given modules, and removes all the files included in the same distribution. If you enable local::lib, it only removes files from the local::lib directory. If you try to uninstall a module in C<perl> directory (i.e. core module), an error will be thrown. A dialog will be prompted to confirm the files to be deleted. If you pass C<-f> option as well, the dialog will be skipped and uninstallation will be forced. =item --cascade-search B<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. =item --skip-installed Specifies whether a module given in the command line is skipped if its latest version is already installed. Defaults to true. B<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. =item --skip-satisfied B<EXPERIMENTAL>: Specifies whether a module (and version) given in the command line is skipped if it's already installed. If you run: cpanm --skip-satisfied CGI DBI~1.2 cpanm won't install them if you already have CGI (for whatever versions) or have DBI with version higher than 1.2. It is similar to C<--skip-installed> but while C<--skip-installed> checks if the I<latest> version of CPAN is installed, C<--skip-satisfied> checks if a requested version (or not, which means any version) is installed. Defaults to false. =item --verify Verify the integrity of distribution files retrieved from CPAN using CHECKSUMS file, and SIGNATURES file (if found in the distribution). Defaults to false. Using this option does not verify the integrity of the CHECKSUMS file, and it's unsafe to rely on this option if you're using a CPAN mirror that you do not trust. =item --report-perl-version Whether it reports the locally installed perl version to the various web server as part of User-Agent. Defaults to true unless CI related environment variables such as C<TRAVIS>, C<CI> or C<AUTOMATED_TESTING> is enabled. You can disable it by using C<--no-report-perl-version>. =item --auto-cleanup Specifies the number of days in which cpanm's work directories expire. Defaults to 7, which means old work directories will be cleaned up in one week. You can set the value to C<0> to make cpan never cleanup those directories. =item --man-pages Generates man pages for executables (man1) and libraries (man3). Defaults to true (man pages generated) unless C<-L|--local-lib-contained> option is supplied in which case it's set to false. You can disable it with C<--no-man-pages>. =item --lwp Uses L<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. =item --wget Uses GNU Wget (if available) to download stuff. Defaults to true, and you can say C<--no-wget> to disable using Wget (versions of Wget older than 1.9 don't support the C<--retry-connrefused> option used by cpanm). =item --curl Uses cURL (if available) to download stuff. Defaults to true, and you can say C<--no-curl> to disable using cURL. Normally with C<--lwp>, C<--wget> and C<--curl> options set to true (which is the default) cpanm tries L<LWP>, Wget, cURL and L<HTTP::Tiny> (in that order) and uses the first one available. =back =head1 ENVIRONMENT VARIABLES =over 4 =item PERL_CPANM_HOME 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. =item PERL_CPANM_OPT If set, adds a set of default options to every cpanm command. These options come first, and so are overridden by command-line options. =back =head1 SEE ALSO L<App::cpanminus> =head1 COPYRIGHT Copyright 2010- Tatsuhiko Miyagawa. =head1 AUTHOR Tatsuhiko Miyagawa =cut PK jA[ blib/lib/App/.existsnu �[��� PK jA[ # blib/lib/auto/App/cpanminus/.existsnu �[��� PK jA[#�H2 2 MYMETA.ymlnu �[��� --- abstract: 'get, unpack, build and install modules from CPAN' author: - '- Tatsuhiko Miyagawa' build_requires: ExtUtils::MakeMaker: '0' Test::More: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 0 generated_by: 'Dist::Milla version v1.0.22, Dist::Zilla version 6.025, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: App-cpanminus no_index: directory: - eg - examples - inc - share - t - xt file: - lib/App/cpanminus/fatscript.pm requires: perl: '5.008001' resources: bugtracker: https://github.com/miyagawa/cpanminus/issues homepage: https://github.com/miyagawa/cpanminus repository: https://github.com/miyagawa/cpanminus.git version: '1.7047' x_contributors: - 'Aaron Moses <mosesa02@localhost.localdomain>' - 'Alessandro Ghedini <al3xbio@gmail.com>' - 'Andrew Rodland <andrew@cleverdomain.org>' - 'Andy Jones <andy@broadbean.com>' - 'andyjones <andy_jones@outgun.com>' - 'Ash Berlin <ash_github@firemirror.com>' - 'Ben Bullock <benkasminbullock@gmail.com>' - 'Breno G. de Oliveira <garu@cpan.org>' - 'Brian Wightman <MidLifeXis@wightmanfam.org>' - 'cho45 <cho45@lowreal.net>' - 'Christian Walde <walde.christian@googlemail.com>' - 'chromatic <chromatic@wgz.org>' - 'Dagfinn Ilmari Mannsaker <ilmari@ilmari.org>' - 'Dana M. Diederich <diederich@gmail.com>' - 'Dave Goodell <davidjgoodell@gmail.com>' - 'Dave Rolsky <autarch@urth.org>' - 'David Golden <dagolden@cpan.org>' - 'David Steinbrunner <dsteinbrunner@pobox.com>' - 'Doug Bell <madcityzen@gmail.com>' - 'Eli Flanagan <eflanagan@innovu.com>' - 'fREW Schmidt <frioux@gmail.com>' - 'Fuji, Goro <g.psy.va@gmail.com>' - 'Gareth Kirwan <gbjk@thermeon.com>' - 'gfx <gfuji@cpan.org>' - 'Graham Knop <haarg@haarg.org>' - 'Graham Ollis <perl@wdlabs.com>' - 'ikasam_a <masaki.nakagawa@gmail.com>' - 'Ingy dot Net <ingy@ingy.net>' - 'Jan Dubois <jand@activestate.com>' - 'Jeffrey Ryan Thalhammer <jeff@imaginative-software.com>' - 'Jesse Luehrs <doy@tozt.net>' - 'J. Nick Koston <nick@cpanel.net>' - 'jonallen <jj@jonallen.info>' - 'Jonathan Scott Duff <duff@pobox.com>' - 'Kahlil (Kal) Hodgson <kahlil.hodgson@dealmax.com.au>' - 'Kenichi Ishigaki <ishigaki@cpan.org>' - 'Kent Fredric <kentnl@cpan.org>' - 'kmx <kmx@cpan.org>' - 'Larry Leszczynski <larryl@atomiclearning.com>' - 'lestrrat <lestrrat+github@gmail.com>' - 'Masahiro Nagano <kazeburo@gmail.com>' - 'Masayoshi Sekimura <sekimura@gmail.com>' - 'Matthew Horsfall <wolfsage@gmail.com>' - 'Matt S Trout <>' - 'Matt S Trout <mst@shadowcat.co.uk>' - 'Michael G. Schwern <schwern@pobox.com>' - 'motemen <motemen@gmail.com>' - 'moznion <moznion@gmail.com>' - 'Nicolas R <atoomic@cpan.org>' - 'Norman Nunley <nnunley@gmail.com>' - 'Olaf Alders <olaf@wundersolutions.com>' - 'Olivier Mengue <dolmen@cpan.org>' - 'Pedro Melo <melo@simplicidade.org>' - 'Rafal Pocztarski <r.pocztarski@gmail.com>' - 'reezer <kind@gmx.at>' - 'Ricardo Signes <rjbs@cpan.org>' - 'robario <webmaster@robario.com>' - 'Robert Buels <rmb32@cornell.edu>' - 'Rob Hoelz <rob@hoelz.ro>' - 'Roman Jurkov <rjurkov@verio.net>' - 'Sebastian Riedel <sri@cpan.org>' - 'Shoichi Kaji <skaji@cpan.org>' - 'Slaven Rezic <slaven@rezic.de>' - 'Smylers <Smylers@stripey.com>' - 'Stoned Elipot <stoned.elipot@gmail.com>' - 'Syohei YOSHIDA <syohex@gmail.com>' - 'Tatsuhiko Miyagawa <miyagawa@bulknews.net>' - 'Tatsuhiko Miyagawa <miyagawa@gmail.com>' - 'Thomas Sibley <tom@zulutango.org>' - 'Tokuhiro Matsuno <tokuhirom@gmail.com>' - 'Tuure Laurinolli <tuure.laurinolli@portalify.com>' - 'vti <viacheslav.t@gmail.com>' - 'Vyacheslav Matyukhin <mmcleric@yandex-team.ru>' - 'xaicron <xaicron@gmail.com>' - 'Yann Kerherve <yann@cyberion.net>' - 'yappo <yappo@shibuya.pl>' - 'zebardy <zebardy@gmail.com>' x_generated_by_perl: v5.34.1 x_serialization_backend: 'CPAN::Meta::YAML version 0.018' x_spdx_expression: 'Artistic-1.0-Perl OR GPL-1.0-or-later' x_static_install: 0 PK jA[t�N*� � MANIFESTnu �[��� # This file was automatically generated by Dist::Zilla::Plugin::Manifest v6.025. Changes LICENSE MANIFEST MANIFEST.SKIP META.json META.yml Makefile.PL README bin/cpanm cpanfile lib/App/cpanminus.pm lib/App/cpanminus/fatscript.pm t/happy_cpantesters.t PK jA[�D�� � lib/App/cpanminus.pmnu �[��� package App::cpanminus; our $VERSION = "1.7047"; =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. =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<CPAN::Meta::Check> Copyright (c) 2012 by Leon Timmermans =item L<File::pushd> Copyright 2012 David Golden =item L<parent> Copyright (c) 2007-10 Max Maischein =item L<Parse::PMFile> Copyright 1995 - 2013 by Andreas Koenig, Copyright 2013 by Kenichi Ishigaki =item L<String::ShellQuote> by Roderick Schertler =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; PK jA[r��~� � lib/App/cpanminus/fatscript.pmnu �[��� package App::cpanminus::fatscript; # # This is a pre-compiled source code for the cpanm (cpanminus) program. # For more details about how to install cpanm, go to the following URL: # # https://github.com/miyagawa/cpanminus # # Quickstart: Run the following command and it will install itself for # you. You might want to run it as a root with sudo if you want to install # to places like /usr/local/bin. # # % curl -L https://cpanmin.us | perl - App::cpanminus # # If you don't have curl but wget, replace `curl -L` with `wget -O -`. # DO NOT EDIT -- this is an auto generated file # This chunk of stuff was generated by App::FatPacker. To find the original # file's code, look for the end of this BEGIN block or the string 'FATPACK' BEGIN { my %fatpacked; $fatpacked{"App/cpanminus.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_CPANMINUS'; package App::cpanminus; our $VERSION = "1.7047"; =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. =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<CPAN::Meta::Check> Copyright (c) 2012 by Leon Timmermans =item L<File::pushd> Copyright 2012 David Golden =item L<parent> Copyright (c) 2007-10 Max Maischein =item L<Parse::PMFile> Copyright 1995 - 2013 by Andreas Koenig, Copyright 2013 by Kenichi Ishigaki =item L<String::ShellQuote> by Roderick Schertler =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 $fatpacked{"App/cpanminus/Dependency.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_CPANMINUS_DEPENDENCY'; package App::cpanminus::Dependency; use strict; use CPAN::Meta::Requirements; sub from_prereqs { my($class, $prereqs, $phases, $types) = @_; my @deps; for my $type (@$types) { push @deps, $class->from_versions( $prereqs->merged_requirements($phases, [$type])->as_string_hash, $type, ); } return @deps; } sub from_versions { my($class, $versions, $type) = @_; my @deps; while (my($module, $version) = each %$versions) { push @deps, $class->new($module, $version, $type) } @deps; } sub merge_with { my($self, $requirements) = @_; # save the original requirement $self->{original_version} = $self->version; # should it clone? not cloning means we upgrade root $requirements on our way eval { $requirements->add_string_requirement($self->module, $self->version); }; if ($@ =~ /illegal requirements/) { # Just give a warning then replace with the root requirements # so that later CPAN::Meta::Check can give a valid error warn sprintf("Can't merge requirements for %s: '%s' and '%s'", $self->module, $self->version, $requirements->requirements_for_module($self->module)); } $self->{version} = $requirements->requirements_for_module($self->module); } sub new { my($class, $module, $version, $type) = @_; bless { module => $module, version => $version, type => $type || 'requires', }, $class; } sub module { $_[0]->{module} } sub version { $_[0]->{version} } sub type { $_[0]->{type} } sub requires_version { my $self = shift; # original_version may be 0 if (defined $self->{original_version}) { return $self->{original_version}; } $self->version; } sub is_requirement { $_[0]->{type} eq 'requires'; } 1; APP_CPANMINUS_DEPENDENCY $fatpacked{"App/cpanminus/script.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_CPANMINUS_SCRIPT'; package App::cpanminus::script; use strict; use Config; use Cwd (); use App::cpanminus; use App::cpanminus::Dependency; use File::Basename (); use File::Find (); use File::Path (); use File::Spec (); use File::Copy (); use File::Temp (); use Getopt::Long (); use Symbol (); use String::ShellQuote (); use version (); use constant WIN32 => $^O eq 'MSWin32'; use constant BAD_TAR => ($^O eq 'solaris' || $^O eq 'hpux'); use constant CAN_SYMLINK => eval { symlink("", ""); 1 }; our $VERSION = $App::cpanminus::VERSION; if ($INC{"App/FatPacker/Trace.pm"}) { require version::vpp; } my $quote = WIN32 ? q/"/ : q/'/; sub agent { my $self = shift; my $agent = "cpanminus/$VERSION"; $agent .= " perl/$]" if $self->{report_perl_version}; $agent; } sub determine_home { my $class = shift; my $homedir = $ENV{HOME} || eval { require File::HomeDir; File::HomeDir->my_home } || join('', @ENV{qw(HOMEDRIVE HOMEPATH)}); # Win32 if (WIN32) { require Win32; # no fatpack $homedir = Win32::GetShortPathName($homedir); } return "$homedir/.cpanm"; } sub new { my $class = shift; bless { home => $class->determine_home, cmd => 'install', seen => {}, notest => undef, test_only => undef, installdeps => undef, force => undef, sudo => undef, make => undef, verbose => undef, quiet => undef, interactive => undef, log => undef, mirrors => [], mirror_only => undef, mirror_index => undef, cpanmetadb => "http://cpanmetadb.plackperl.org/v1.0/", perl => $^X, argv => [], local_lib => undef, self_contained => undef, exclude_vendor => undef, prompt_timeout => 0, prompt => undef, configure_timeout => 60, build_timeout => 3600, test_timeout => 1800, try_lwp => 1, try_wget => 1, try_curl => 1, uninstall_shadows => ($] < 5.012), skip_installed => 1, skip_satisfied => 0, auto_cleanup => 7, # days pod2man => 1, installed_dists => 0, install_types => ['requires'], with_develop => 0, 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); $self->uri_escape($json); } sub decode_json { my($self, $json) = @_; require JSON::PP; JSON::PP::decode_json($json); } sub uri_escape { my($self, $fragment) = @_; $fragment =~ s/([^A-Za-z0-9\-\._~])/uc sprintf("%%%02X", ord($1))/eg; $fragment; } sub uri_params { my($self, @params) = @_; my @param_strings; while (my $key = shift @params) { my $value = shift @params; push @param_strings, join '=', map $self->uri_escape($_), $key, $value; } return join '&', @param_strings; } # version->new("1.00_00")->numify => "1.00_00" :/ sub numify_ver { my($self, $ver) = @_; eval version->new($ver)->numify; } sub search_metacpan { my($self, $module, $version, $dev_release) = @_; my $metacpan_uri = 'http://fastapi.metacpan.org/v1/download_url/'; my $url = $metacpan_uri . $module; my $query = $self->uri_params( ($version ? (version => $version) : ()), ($dev_release ? (dev => 1) : ()), ); $url .= '?' . $query if length $query; my $dist_json = $self->get($url); my $dist_meta = eval { $self->decode_json($dist_json) }; if ($dist_meta && $dist_meta->{download_url}) { (my $distfile = $dist_meta->{download_url}) =~ s!.+/authors/id/!!; local $self->{mirrors} = $self->{mirrors}; $self->{mirrors} = [ 'http://cpan.metacpan.org' ]; return $self->cpan_module($module, $distfile, $dist_meta->{version}); } $self->chat("! Could not find a release matching $module".($version?" ($version)":'')." on MetaCPAN.\n"); return; } sub search_database { my($self, $module, $version) = @_; my $found; 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; } } sub search_cpanmetadb { my($self, $module, $version, $dev_release) = @_; $self->chat("Searching $module ($version) on cpanmetadb ...\n"); if ($self->with_version_range($version)) { return $self->search_cpanmetadb_history($module, $version, $dev_release); } else { return $self->search_cpanmetadb_package($module, $version, $dev_release); } } sub search_cpanmetadb_package { my($self, $module, $version, $dev_release) = @_; 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_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_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 verification 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_file, $version) = @_; my $dist = $self->cpan_dist($dist_file); $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; FILE: { chomp $root; if ($root !~ s{^\s+testing:\s+([^/]+)/.*?\s+OK$}{$1}) { $root = shift(@others); redo FILE if $root; } } 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 $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 $fatpacked{"CPAN/Meta/Check.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'CPAN_META_CHECK'; package CPAN::Meta::Check; # vi:noet:sts=2:sw=2:ts=2 $CPAN::Meta::Check::VERSION = '0.018'; 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) = @_; return $reqs->accepts_module($module, $]) ? () : sprintf "Your Perl (%s) is not in the range '%s'", $], $reqs->requirements_for_module($module) if $module eq 'perl'; 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.018 =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> =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; 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}; } 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}; } 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}), ); 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 $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 { 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"; } } } # 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/; } 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 $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 $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 $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 $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 $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 $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 $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 $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 $fatpacked{"Module/CPANfile/Prereq.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_PREREQ'; package Module::CPANfile::Prereq; use strict; sub new { my($class, %options) = @_; bless \%options, $class; } sub feature { $_[0]->{feature} } sub phase { $_[0]->{phase} } sub type { $_[0]->{type} } sub module { $_[0]->{module} } sub requirement { $_[0]->{requirement} } sub match_feature { my($self, $identifier) = @_; no warnings 'uninitialized'; $self->feature eq $identifier; } 1; MODULE_CPANFILE_PREREQ $fatpacked{"Module/CPANfile/Prereqs.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_PREREQS'; package Module::CPANfile::Prereqs; use strict; use Carp (); use CPAN::Meta::Feature; use Module::CPANfile::Prereq; sub from_cpan_meta { my($class, $prereqs) = @_; my $self = $class->new; for my $phase (keys %$prereqs) { for my $type (keys %{ $prereqs->{$phase} }) { while (my($module, $requirement) = each %{ $prereqs->{$phase}{$type} }) { $self->add_prereq( phase => $phase, type => $type, module => $module, requirement => Module::CPANfile::Requirement->new(name => $module, version => $requirement), ); } } } $self; } sub new { my $class = shift; bless { prereqs => [], features => {}, }, $class; } sub add_feature { my($self, $identifier, $description) = @_; $self->{features}{$identifier} = { description => $description }; } sub add_prereq { my($self, %args) = @_; $self->add( Module::CPANfile::Prereq->new(%args) ); } sub add { my($self, $prereq) = @_; push @{$self->{prereqs}}, $prereq; } sub as_cpan_meta { my $self = shift; $self->{cpanmeta} ||= $self->build_cpan_meta; } sub build_cpan_meta { my($self, $identifier) = @_; my $prereq_spec = {}; $self->prereq_each($identifier, sub { my $prereq = shift; $prereq_spec->{$prereq->phase}{$prereq->type}{$prereq->module} = $prereq->requirement->version; }); CPAN::Meta::Prereqs->new($prereq_spec); } sub prereq_each { my($self, $identifier, $code) = @_; for my $prereq (@{$self->{prereqs}}) { next unless $prereq->match_feature($identifier); $code->($prereq); } } sub merged_requirements { my $self = shift; my $reqs = CPAN::Meta::Requirements->new; for my $prereq (@{$self->{prereqs}}) { $reqs->add_string_requirement($prereq->module, $prereq->requirement->version); } $reqs; } sub find { my($self, $module) = @_; for my $prereq (@{$self->{prereqs}}) { return $prereq if $prereq->module eq $module; } return; } sub identifiers { my $self = shift; keys %{$self->{features}}; } sub feature { my($self, $identifier) = @_; my $data = $self->{features}{$identifier} or Carp::croak("Unknown feature '$identifier'"); my $prereqs = $self->build_cpan_meta($identifier); CPAN::Meta::Feature->new($identifier, { description => $data->{description}, prereqs => $prereqs->as_string_hash, }); } 1; MODULE_CPANFILE_PREREQS $fatpacked{"Module/CPANfile/Requirement.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_CPANFILE_REQUIREMENT'; package Module::CPANfile::Requirement; use strict; sub new { my ($class, %args) = @_; $args{version} ||= 0; bless +{ name => delete $args{name}, version => delete $args{version}, options => \%args, }, $class; } sub name { $_[0]->{name} } sub version { $_[0]->{version} } sub options { $_[0]->{options} } sub has_options { keys %{$_[0]->{options}} > 0; } 1; MODULE_CPANFILE_REQUIREMENT $fatpacked{"Module/Metadata.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'MODULE_METADATA'; # -*- mode: cperl; tab-width: 8; indent-tabs-mode: nil; basic-offset: 2 -*- # vim:ts=8:sw=2:et:sta:sts=2 package Module::Metadata; # git description: v1.000026-12-g9b12bf1 # Adapted from Perl-licensed code originally distributed with # Module-Build by Ken Williams # This module provides routines to gather information about # perl modules (assuming this may be expanded in the distant # parrot future to look at other types of modules). sub __clean_eval { eval $_[0] } use strict; use warnings; our $VERSION = '1.000027'; use Carp qw/croak/; use File::Spec; BEGIN { # Try really hard to not depend ony any DynaLoaded module, such as IO::File or Fcntl eval { require Fcntl; Fcntl->import('SEEK_SET'); 1; } or *SEEK_SET = sub { 0 } } use version 0.87; BEGIN { if ($INC{'Log/Contextual.pm'}) { require "Log/Contextual/WarnLogger.pm"; # Hide from AutoPrereqs Log::Contextual->import('log_info', '-default_logger' => Log::Contextual::WarnLogger->new({ env_prefix => 'MODULE_METADATA', }), ); } else { *log_info = sub (&) { warn $_[0]->() }; } } use File::Find qw(find); my $V_NUM_REGEXP = qr{v?[0-9._]+}; # crudely, a v-string or decimal my $PKG_FIRST_WORD_REGEXP = qr{ # the FIRST word in a package name [a-zA-Z_] # the first word CANNOT start with a digit (?: [\w']? # can contain letters, digits, _, or ticks \w # But, NO multi-ticks or trailing ticks )* }x; my $PKG_ADDL_WORD_REGEXP = qr{ # the 2nd+ word in a package name \w # the 2nd+ word CAN start with digits (?: [\w']? # and can contain letters or ticks \w # But, NO multi-ticks or trailing ticks )* }x; my $PKG_NAME_REGEXP = qr{ # match a package name (?: :: )? # a pkg name can start with arisdottle $PKG_FIRST_WORD_REGEXP # a package word (?: (?: :: )+ ### arisdottle (allow one or many times) $PKG_ADDL_WORD_REGEXP ### a package word )* # ^ zero, one or many times (?: :: # allow trailing arisdottle )? }x; my $PKG_REGEXP = qr{ # match a package declaration ^[\s\{;]* # intro chars on a line package # the word 'package' \s+ # whitespace ($PKG_NAME_REGEXP) # a package name \s* # optional whitespace ($V_NUM_REGEXP)? # optional version number \s* # optional whitesapce [;\{] # semicolon line terminator or block start (since 5.16) }x; my $VARNAME_REGEXP = qr{ # match fully-qualified VERSION name ([\$*]) # sigil - $ or * ( ( # optional leading package name (?:::|\')? # possibly starting like just :: (a la $::VERSION) (?:\w+(?:::|\'))* # Foo::Bar:: ... )? VERSION )\b }x; my $VERS_REGEXP = qr{ # match a VERSION definition (?: \(\s*$VARNAME_REGEXP\s*\) # with parens | $VARNAME_REGEXP # without parens ) \s* =[^=~>] # = but not ==, nor =~, nor => }x; sub new_from_file { my $class = shift; my $filename = File::Spec->rel2abs( shift ); return undef unless defined( $filename ) && -f $filename; return $class->_init(undef, $filename, @_); } sub new_from_handle { my $class = shift; my $handle = shift; my $filename = shift; return undef unless defined($handle) && defined($filename); $filename = File::Spec->rel2abs( $filename ); return $class->_init(undef, $filename, @_, handle => $handle); } sub new_from_module { my $class = shift; my $module = shift; my %props = @_; $props{inc} ||= \@INC; my $filename = $class->find_module_by_name( $module, $props{inc} ); return undef unless defined( $filename ) && -f $filename; return $class->_init($module, $filename, %props); } { my $compare_versions = sub { my ($v1, $op, $v2) = @_; $v1 = version->new($v1) unless UNIVERSAL::isa($v1,'version'); my $eval_str = "\$v1 $op \$v2"; my $result = eval $eval_str; log_info { "error comparing versions: '$eval_str' $@" } if $@; return $result; }; my $normalize_version = sub { my ($version) = @_; if ( $version =~ /[=<>!,]/ ) { # logic, not just version # take as is without modification } elsif ( ref $version eq 'version' ) { # version objects $version = $version->is_qv ? $version->normal : $version->stringify; } elsif ( $version =~ /^[^v][^.]*\.[^.]+\./ ) { # no leading v, multiple dots # normalize string tuples without "v": "1.2.3" -> "v1.2.3" $version = "v$version"; } else { # leave alone } return $version; }; # separate out some of the conflict resolution logic my $resolve_module_versions = sub { my $packages = shift; my( $file, $version ); my $err = ''; foreach my $p ( @$packages ) { if ( defined( $p->{version} ) ) { if ( defined( $version ) ) { if ( $compare_versions->( $version, '!=', $p->{version} ) ) { $err .= " $p->{file} ($p->{version})\n"; } else { # same version declared multiple times, ignore } } else { $file = $p->{file}; $version = $p->{version}; } } $file ||= $p->{file} if defined( $p->{file} ); } if ( $err ) { $err = " $file ($version)\n" . $err; } my %result = ( file => $file, version => $version, err => $err ); return \%result; }; sub provides { my $class = shift; croak "provides() requires key/value pairs \n" if @_ % 2; my %args = @_; croak "provides() takes only one of 'dir' or 'files'\n" if $args{dir} && $args{files}; croak "provides() requires a 'version' argument" unless defined $args{version}; croak "provides() does not support version '$args{version}' metadata" unless grep { $args{version} eq $_ } qw/1.4 2/; $args{prefix} = 'lib' unless defined $args{prefix}; my $p; if ( $args{dir} ) { $p = $class->package_versions_from_directory($args{dir}); } else { croak "provides() requires 'files' to be an array reference\n" unless ref $args{files} eq 'ARRAY'; $p = $class->package_versions_from_directory($args{files}); } # Now, fix up files with prefix if ( length $args{prefix} ) { # check in case disabled with q{} $args{prefix} =~ s{/$}{}; for my $v ( values %$p ) { $v->{file} = "$args{prefix}/$v->{file}"; } } return $p } sub package_versions_from_directory { my ( $class, $dir, $files ) = @_; my @files; if ( $files ) { @files = @$files; } else { find( { wanted => sub { push @files, $_ if -f $_ && /\.pm$/; }, no_chdir => 1, }, $dir ); } # First, we enumerate all packages & versions, # separating into primary & alternative candidates my( %prime, %alt ); foreach my $file (@files) { my $mapped_filename = File::Spec::Unix->abs2rel( $file, $dir ); my @path = split( /\//, $mapped_filename ); (my $prime_package = join( '::', @path )) =~ s/\.pm$//; my $pm_info = $class->new_from_file( $file ); foreach my $package ( $pm_info->packages_inside ) { next if $package eq 'main'; # main can appear numerous times, ignore next if $package eq 'DB'; # special debugging package, ignore next if grep /^_/, split( /::/, $package ); # private package, ignore my $version = $pm_info->version( $package ); $prime_package = $package if lc($prime_package) eq lc($package); if ( $package eq $prime_package ) { if ( exists( $prime{$package} ) ) { croak "Unexpected conflict in '$package'; multiple versions found.\n"; } else { $mapped_filename = "$package.pm" if lc("$package.pm") eq lc($mapped_filename); $prime{$package}{file} = $mapped_filename; $prime{$package}{version} = $version if defined( $version ); } } else { push( @{$alt{$package}}, { file => $mapped_filename, version => $version, } ); } } } # Then we iterate over all the packages found above, identifying conflicts # and selecting the "best" candidate for recording the file & version # for each package. foreach my $package ( keys( %alt ) ) { my $result = $resolve_module_versions->( $alt{$package} ); if ( exists( $prime{$package} ) ) { # primary package selected if ( $result->{err} ) { # Use the selected primary package, but there are conflicting # errors among multiple alternative packages that need to be # reported log_info { "Found conflicting versions for package '$package'\n" . " $prime{$package}{file} ($prime{$package}{version})\n" . $result->{err} }; } elsif ( defined( $result->{version} ) ) { # There is a primary package selected, and exactly one # alternative package if ( exists( $prime{$package}{version} ) && defined( $prime{$package}{version} ) ) { # Unless the version of the primary package agrees with the # version of the alternative package, report a conflict if ( $compare_versions->( $prime{$package}{version}, '!=', $result->{version} ) ) { log_info { "Found conflicting versions for package '$package'\n" . " $prime{$package}{file} ($prime{$package}{version})\n" . " $result->{file} ($result->{version})\n" }; } } else { # The prime package selected has no version so, we choose to # use any alternative package that does have a version $prime{$package}{file} = $result->{file}; $prime{$package}{version} = $result->{version}; } } else { # no alt package found with a version, but we have a prime # package so we use it whether it has a version or not } } else { # No primary package was selected, use the best alternative if ( $result->{err} ) { log_info { "Found conflicting versions for package '$package'\n" . $result->{err} }; } # Despite possible conflicting versions, we choose to record # something rather than nothing $prime{$package}{file} = $result->{file}; $prime{$package}{version} = $result->{version} if defined( $result->{version} ); } } # Normalize versions. Can't use exists() here because of bug in YAML::Node. # XXX "bug in YAML::Node" comment seems irrelevant -- dagolden, 2009-05-18 for (grep defined $_->{version}, values %prime) { $_->{version} = $normalize_version->( $_->{version} ); } return \%prime; } } sub _init { my $class = shift; my $module = shift; my $filename = shift; my %props = @_; my $handle = delete $props{handle}; my( %valid_props, @valid_props ); @valid_props = qw( collect_pod inc ); @valid_props{@valid_props} = delete( @props{@valid_props} ); warn "Unknown properties: @{[keys %props]}\n" if scalar( %props ); my %data = ( module => $module, filename => $filename, version => undef, packages => [], versions => {}, pod => {}, pod_headings => [], collect_pod => 0, %valid_props, ); my $self = bless(\%data, $class); if ( not $handle ) { my $filename = $self->{filename}; open $handle, '<', $filename or croak( "Can't open '$filename': $!" ); $self->_handle_bom($handle, $filename); } $self->_parse_fh($handle); unless($self->{module} and length($self->{module})) { my ($v, $d, $f) = File::Spec->splitpath($self->{filename}); if($f =~ /\.pm$/) { $f =~ s/\..+$//; my @candidates = grep /$f$/, @{$self->{packages}}; $self->{module} = shift(@candidates); # punt } else { if(grep /main/, @{$self->{packages}}) { $self->{module} = 'main'; } else { $self->{module} = $self->{packages}[0] || ''; } } } $self->{version} = $self->{versions}{$self->{module}} if defined( $self->{module} ); return $self; } # class method sub _do_find_module { my $class = shift; my $module = shift || croak 'find_module_by_name() requires a package name'; my $dirs = shift || \@INC; my $file = File::Spec->catfile(split( /::/, $module)); foreach my $dir ( @$dirs ) { my $testfile = File::Spec->catfile($dir, $file); return [ File::Spec->rel2abs( $testfile ), $dir ] if -e $testfile and !-d _; # For stuff like ExtUtils::xsubpp $testfile .= '.pm'; return [ File::Spec->rel2abs( $testfile ), $dir ] if -e $testfile; } return; } # class method sub find_module_by_name { my $found = shift()->_do_find_module(@_) or return; return $found->[0]; } # class method sub find_module_dir_by_name { my $found = shift()->_do_find_module(@_) or return; return $found->[1]; } # given a line of perl code, attempt to parse it if it looks like a # $VERSION assignment, returning sigil, full name, & package name sub _parse_version_expression { my $self = shift; my $line = shift; my( $sigil, $variable_name, $package); if ( $line =~ /$VERS_REGEXP/o ) { ( $sigil, $variable_name, $package) = $2 ? ( $1, $2, $3 ) : ( $4, $5, $6 ); if ( $package ) { $package = ($package eq '::') ? 'main' : $package; $package =~ s/::$//; } } return ( $sigil, $variable_name, $package ); } # Look for a UTF-8/UTF-16BE/UTF-16LE BOM at the beginning of the stream. # If there's one, then skip it and set the :encoding layer appropriately. sub _handle_bom { my ($self, $fh, $filename) = @_; my $pos = tell $fh; return unless defined $pos; my $buf = ' ' x 2; my $count = read $fh, $buf, length $buf; return unless defined $count and $count >= 2; my $encoding; if ( $buf eq "\x{FE}\x{FF}" ) { $encoding = 'UTF-16BE'; } elsif ( $buf eq "\x{FF}\x{FE}" ) { $encoding = 'UTF-16LE'; } elsif ( $buf eq "\x{EF}\x{BB}" ) { $buf = ' '; $count = read $fh, $buf, length $buf; if ( defined $count and $count >= 1 and $buf eq "\x{BF}" ) { $encoding = 'UTF-8'; } } if ( defined $encoding ) { if ( "$]" >= 5.008 ) { binmode( $fh, ":encoding($encoding)" ); } } else { seek $fh, $pos, SEEK_SET or croak( sprintf "Can't reset position to the top of '$filename'" ); } return $encoding; } sub _parse_fh { my ($self, $fh) = @_; my( $in_pod, $seen_end, $need_vers ) = ( 0, 0, 0 ); my( @packages, %vers, %pod, @pod ); my $package = 'main'; my $pod_sect = ''; my $pod_data = ''; my $in_end = 0; while (defined( my $line = <$fh> )) { my $line_num = $.; chomp( $line ); # From toke.c : any line that begins by "=X", where X is an alphabetic # character, introduces a POD segment. my $is_cut; if ( $line =~ /^=([a-zA-Z].*)/ ) { my $cmd = $1; # Then it goes back to Perl code for "=cutX" where X is a non-alphabetic # character (which includes the newline, but here we chomped it away). $is_cut = $cmd =~ /^cut(?:[^a-zA-Z]|$)/; $in_pod = !$is_cut; } if ( $in_pod ) { if ( $line =~ /^=head[1-4]\s+(.+)\s*$/ ) { push( @pod, $1 ); if ( $self->{collect_pod} && length( $pod_data ) ) { $pod{$pod_sect} = $pod_data; $pod_data = ''; } $pod_sect = $1; } elsif ( $self->{collect_pod} ) { $pod_data .= "$line\n"; } } elsif ( $is_cut ) { if ( $self->{collect_pod} && length( $pod_data ) ) { $pod{$pod_sect} = $pod_data; $pod_data = ''; } $pod_sect = ''; } else { # Skip after __END__ next if $in_end; # Skip comments in code next if $line =~ /^\s*#/; # Would be nice if we could also check $in_string or something too if ($line eq '__END__') { $in_end++; next; } last if $line eq '__DATA__'; # parse $line to see if it's a $VERSION declaration my( $version_sigil, $version_fullname, $version_package ) = index($line, 'VERSION') >= 1 ? $self->_parse_version_expression( $line ) : (); if ( $line =~ /$PKG_REGEXP/o ) { $package = $1; my $version = $2; push( @packages, $package ) unless grep( $package eq $_, @packages ); $need_vers = defined $version ? 0 : 1; if ( not exists $vers{$package} and defined $version ){ # Upgrade to a version object. my $dwim_version = eval { _dwim_version($version) }; croak "Version '$version' from $self->{filename} does not appear to be valid:\n$line\n\nThe fatal error was: $@\n" unless defined $dwim_version; # "0" is OK! $vers{$package} = $dwim_version; } # VERSION defined with full package spec, i.e. $Module::VERSION } elsif ( $version_fullname && $version_package ) { push( @packages, $version_package ) unless grep( $version_package eq $_, @packages ); $need_vers = 0 if $version_package eq $package; unless ( defined $vers{$version_package} && length $vers{$version_package} ) { $vers{$version_package} = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line ); } # first non-comment line in undeclared package main is VERSION } elsif ( $package eq 'main' && $version_fullname && !exists($vers{main}) ) { $need_vers = 0; my $v = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line ); $vers{$package} = $v; push( @packages, 'main' ); # first non-comment line in undeclared package defines package main } elsif ( $package eq 'main' && !exists($vers{main}) && $line =~ /\w/ ) { $need_vers = 1; $vers{main} = ''; push( @packages, 'main' ); # only keep if this is the first $VERSION seen } elsif ( $version_fullname && $need_vers ) { $need_vers = 0; my $v = $self->_evaluate_version_line( $version_sigil, $version_fullname, $line ); unless ( defined $vers{$package} && length $vers{$package} ) { $vers{$package} = $v; } } } } if ( $self->{collect_pod} && length($pod_data) ) { $pod{$pod_sect} = $pod_data; } $self->{versions} = \%vers; $self->{packages} = \@packages; $self->{pod} = \%pod; $self->{pod_headings} = \@pod; } { my $pn = 0; sub _evaluate_version_line { my $self = shift; my( $sigil, $variable_name, $line ) = @_; # We compile into a local sub because 'use version' would cause # compiletime/runtime issues with local() $pn++; # everybody gets their own package my $eval = qq{ my \$dummy = q# Hide from _packages_inside() #; package Module::Metadata::_version::p${pn}; use version; sub { local $sigil$variable_name; $line; \$$variable_name }; }; $eval = $1 if $eval =~ m{^(.+)}s; local $^W; # Try to get the $VERSION my $vsub = __clean_eval($eval); # some modules say $VERSION <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 $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 $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 $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 $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 $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 $fatpacked{"version.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'VERSION'; #!perl -w package version; use 5.006002; use strict; use warnings::register; if ($] >= 5.015) { warnings::register_categories(qw/version/); } use vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv); $VERSION = 0.9912; $CLASS = 'version'; # !!!!Delete this next block completely when adding to Perl core!!!! { local $SIG{'__DIE__'}; if (1) { # always pretend there's no XS eval "use version::vpp $VERSION"; # don't tempt fate die "$@" if ( $@ ); push @ISA, "version::vpp"; local $^W; *version::qv = \&version::vpp::qv; *version::declare = \&version::vpp::declare; *version::_VERSION = \&version::vpp::_VERSION; *version::vcmp = \&version::vpp::vcmp; *version::new = \&version::vpp::new; *version::numify = \&version::vpp::numify; *version::normal = \&version::vpp::normal; if ($] >= 5.009000) { no strict 'refs'; *version::stringify = \&version::vpp::stringify; *{'version::(""'} = \&version::vpp::stringify; *{'version::(<=>'} = \&version::vpp::vcmp; *version::parse = \&version::vpp::parse; } } else { # use XS module push @ISA, "version::vxs"; local $^W; *version::declare = \&version::vxs::declare; *version::qv = \&version::vxs::qv; *version::_VERSION = \&version::vxs::_VERSION; *version::vcmp = \&version::vxs::VCMP; *version::new = \&version::vxs::new; *version::numify = \&version::vxs::numify; *version::normal = \&version::vxs::normal; if ($] >= 5.009000) { no strict 'refs'; *version::stringify = \&version::vxs::stringify; *{'version::(""'} = \&version::vxs::stringify; *{'version::(<=>'} = \&version::vxs::VCMP; *version::parse = \&version::vxs::parse; } } } # avoid using Exporter require version::regex; *version::is_lax = \&version::regex::is_lax; *version::is_strict = \&version::regex::is_strict; *LAX = \$version::regex::LAX; *STRICT = \$version::regex::STRICT; sub import { no strict 'refs'; my ($class) = shift; # Set up any derived class unless ($class eq $CLASS) { local $^W; *{$class.'::declare'} = \&{$CLASS.'::declare'}; *{$class.'::qv'} = \&{$CLASS.'::qv'}; } my %args; if (@_) { # any remaining terms are arguments map { $args{$_} = 1 } @_ } else { # no parameters at all on use line %args = ( qv => 1, 'UNIVERSAL::VERSION' => 1, ); } my $callpkg = caller(); if (exists($args{declare})) { *{$callpkg.'::declare'} = sub {return $class->declare(shift) } unless defined(&{$callpkg.'::declare'}); } if (exists($args{qv})) { *{$callpkg.'::qv'} = sub {return $class->qv(shift) } unless defined(&{$callpkg.'::qv'}); } if (exists($args{'UNIVERSAL::VERSION'})) { local $^W; *UNIVERSAL::VERSION = \&{$CLASS.'::_VERSION'}; } if (exists($args{'VERSION'})) { *{$callpkg.'::VERSION'} = \&{$CLASS.'::_VERSION'}; } if (exists($args{'is_strict'})) { *{$callpkg.'::is_strict'} = \&{$CLASS.'::is_strict'} unless defined(&{$callpkg.'::is_strict'}); } if (exists($args{'is_lax'})) { *{$callpkg.'::is_lax'} = \&{$CLASS.'::is_lax'} unless defined(&{$callpkg.'::is_lax'}); } } 1; VERSION $fatpacked{"version/regex.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'VERSION_REGEX'; package version::regex; use strict; use vars qw($VERSION $CLASS $STRICT $LAX); $VERSION = 0.9912; #--------------------------------------------------------------------------# # Version regexp components #--------------------------------------------------------------------------# # Fraction part of a decimal version number. This is a common part of # both strict and lax decimal versions my $FRACTION_PART = qr/\.[0-9]+/; # First part of either decimal or dotted-decimal strict version number. # Unsigned integer with no leading zeroes (except for zero itself) to # avoid confusion with octal. my $STRICT_INTEGER_PART = qr/0|[1-9][0-9]*/; # First part of either decimal or dotted-decimal lax version number. # Unsigned integer, but allowing leading zeros. Always interpreted # as decimal. However, some forms of the resulting syntax give odd # results if used as ordinary Perl expressions, due to how perl treats # octals. E.g. # version->new("010" ) == 10 # version->new( 010 ) == 8 # version->new( 010.2) == 82 # "8" . "2" my $LAX_INTEGER_PART = qr/[0-9]+/; # Second and subsequent part of a strict dotted-decimal version number. # Leading zeroes are permitted, and the number is always decimal. # Limited to three digits to avoid overflow when converting to decimal # form and also avoid problematic style with excessive leading zeroes. my $STRICT_DOTTED_DECIMAL_PART = qr/\.[0-9]{1,3}/; # Second and subsequent part of a lax dotted-decimal version number. # Leading zeroes are permitted, and the number is always decimal. No # limit on the numerical value or number of digits, so there is the # possibility of overflow when converting to decimal form. my $LAX_DOTTED_DECIMAL_PART = qr/\.[0-9]+/; # Alpha suffix part of lax version number syntax. Acts like a # dotted-decimal part. my $LAX_ALPHA_PART = qr/_[0-9]+/; #--------------------------------------------------------------------------# # Strict version regexp definitions #--------------------------------------------------------------------------# # Strict decimal version number. my $STRICT_DECIMAL_VERSION = qr/ $STRICT_INTEGER_PART $FRACTION_PART? /x; # Strict dotted-decimal version number. Must have both leading "v" and # at least three parts, to avoid confusion with decimal syntax. my $STRICT_DOTTED_DECIMAL_VERSION = qr/ v $STRICT_INTEGER_PART $STRICT_DOTTED_DECIMAL_PART{2,} /x; # Complete strict version number syntax -- should generally be used # anchored: qr/ \A $STRICT \z /x $STRICT = qr/ $STRICT_DECIMAL_VERSION | $STRICT_DOTTED_DECIMAL_VERSION /x; #--------------------------------------------------------------------------# # Lax version regexp definitions #--------------------------------------------------------------------------# # Lax decimal version number. Just like the strict one except for # allowing an alpha suffix or allowing a leading or trailing # decimal-point my $LAX_DECIMAL_VERSION = qr/ $LAX_INTEGER_PART (?: \. | $FRACTION_PART $LAX_ALPHA_PART? )? | $FRACTION_PART $LAX_ALPHA_PART? /x; # Lax dotted-decimal version number. Distinguished by having either # leading "v" or at least three non-alpha parts. Alpha part is only # permitted if there are at least two non-alpha parts. Strangely # enough, without the leading "v", Perl takes .1.2 to mean v0.1.2, # so when there is no "v", the leading part is optional my $LAX_DOTTED_DECIMAL_VERSION = qr/ v $LAX_INTEGER_PART (?: $LAX_DOTTED_DECIMAL_PART+ $LAX_ALPHA_PART? )? | $LAX_INTEGER_PART? $LAX_DOTTED_DECIMAL_PART{2,} $LAX_ALPHA_PART? /x; # Complete lax version number syntax -- should generally be used # anchored: qr/ \A $LAX \z /x # # The string 'undef' is a special case to make for easier handling # of return values from ExtUtils::MM->parse_version $LAX = qr/ undef | $LAX_DECIMAL_VERSION | $LAX_DOTTED_DECIMAL_VERSION /x; #--------------------------------------------------------------------------# # Preloaded methods go here. sub is_strict { defined $_[0] && $_[0] =~ qr/ \A $STRICT \z /x } sub is_lax { defined $_[0] && $_[0] =~ qr/ \A $LAX \z /x } 1; VERSION_REGEX $fatpacked{"version/vpp.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'VERSION_VPP'; package charstar; # a little helper class to emulate C char* semantics in Perl # so that prescan_version can use the same code as in C use overload ( '""' => \&thischar, '0+' => \&thischar, '++' => \&increment, '--' => \&decrement, '+' => \&plus, '-' => \&minus, '*' => \&multiply, 'cmp' => \&cmp, '<=>' => \&spaceship, 'bool' => \&thischar, '=' => \&clone, ); sub new { my ($self, $string) = @_; my $class = ref($self) || $self; my $obj = { string => [split(//,$string)], current => 0, }; return bless $obj, $class; } sub thischar { my ($self) = @_; my $last = $#{$self->{string}}; my $curr = $self->{current}; if ($curr >= 0 && $curr <= $last) { return $self->{string}->[$curr]; } else { return ''; } } sub increment { my ($self) = @_; $self->{current}++; } sub decrement { my ($self) = @_; $self->{current}--; } sub plus { my ($self, $offset) = @_; my $rself = $self->clone; $rself->{current} += $offset; return $rself; } sub minus { my ($self, $offset) = @_; my $rself = $self->clone; $rself->{current} -= $offset; return $rself; } sub multiply { my ($left, $right, $swapped) = @_; my $char = $left->thischar(); return $char * $right; } sub spaceship { my ($left, $right, $swapped) = @_; unless (ref($right)) { # not an object already $right = $left->new($right); } return $left->{current} <=> $right->{current}; } sub cmp { my ($left, $right, $swapped) = @_; unless (ref($right)) { # not an object already if (length($right) == 1) { # comparing single character only return $left->thischar cmp $right; } $right = $left->new($right); } return $left->currstr cmp $right->currstr; } sub bool { my ($self) = @_; my $char = $self->thischar; return ($char ne ''); } sub clone { my ($left, $right, $swapped) = @_; $right = { string => [@{$left->{string}}], current => $left->{current}, }; return bless $right, ref($left); } sub currstr { my ($self, $s) = @_; my $curr = $self->{current}; my $last = $#{$self->{string}}; if (defined($s) && $s->{current} < $last) { $last = $s->{current}; } my $string = join('', @{$self->{string}}[$curr..$last]); return $string; } package version::vpp; use 5.006002; use strict; use warnings::register; use Config; use vars qw($VERSION $CLASS @ISA $LAX $STRICT $WARN_CATEGORY); $VERSION = 0.9912; $CLASS = 'version::vpp'; if ($] > 5.015) { warnings::register_categories(qw/version/); $WARN_CATEGORY = 'version'; } else { $WARN_CATEGORY = 'numeric'; } require version::regex; *version::vpp::is_strict = \&version::regex::is_strict; *version::vpp::is_lax = \&version::regex::is_lax; *LAX = \$version::regex::LAX; *STRICT = \$version::regex::STRICT; use overload ( '""' => \&stringify, '0+' => \&numify, 'cmp' => \&vcmp, '<=>' => \&vcmp, 'bool' => \&vbool, '+' => \&vnoop, '-' => \&vnoop, '*' => \&vnoop, '/' => \&vnoop, '+=' => \&vnoop, '-=' => \&vnoop, '*=' => \&vnoop, '/=' => \&vnoop, 'abs' => \&vnoop, ); sub import { no strict 'refs'; my ($class) = shift; # Set up any derived class unless ($class eq $CLASS) { local $^W; *{$class.'::declare'} = \&{$CLASS.'::declare'}; *{$class.'::qv'} = \&{$CLASS.'::qv'}; } my %args; if (@_) { # any remaining terms are arguments map { $args{$_} = 1 } @_ } else { # no parameters at all on use line %args = ( qv => 1, 'UNIVERSAL::VERSION' => 1, ); } my $callpkg = caller(); if (exists($args{declare})) { *{$callpkg.'::declare'} = sub {return $class->declare(shift) } unless defined(&{$callpkg.'::declare'}); } if (exists($args{qv})) { *{$callpkg.'::qv'} = sub {return $class->qv(shift) } unless defined(&{$callpkg.'::qv'}); } if (exists($args{'UNIVERSAL::VERSION'})) { no warnings qw/redefine/; *UNIVERSAL::VERSION = \&{$CLASS.'::_VERSION'}; } if (exists($args{'VERSION'})) { *{$callpkg.'::VERSION'} = \&{$CLASS.'::_VERSION'}; } if (exists($args{'is_strict'})) { *{$callpkg.'::is_strict'} = \&{$CLASS.'::is_strict'} unless defined(&{$callpkg.'::is_strict'}); } if (exists($args{'is_lax'})) { *{$callpkg.'::is_lax'} = \&{$CLASS.'::is_lax'} unless defined(&{$callpkg.'::is_lax'}); } } my $VERSION_MAX = 0x7FFFFFFF; # implement prescan_version as closely to the C version as possible use constant TRUE => 1; use constant FALSE => 0; sub isDIGIT { my ($char) = shift->thischar(); return ($char =~ /\d/); } sub isALPHA { my ($char) = shift->thischar(); return ($char =~ /[a-zA-Z]/); } sub isSPACE { my ($char) = shift->thischar(); return ($char =~ /\s/); } sub BADVERSION { my ($s, $errstr, $error) = @_; if ($errstr) { $$errstr = $error; } return $s; } sub prescan_version { my ($s, $strict, $errstr, $sqv, $ssaw_decimal, $swidth, $salpha) = @_; my $qv = defined $sqv ? $$sqv : FALSE; my $saw_decimal = defined $ssaw_decimal ? $$ssaw_decimal : 0; my $width = defined $swidth ? $$swidth : 3; my $alpha = defined $salpha ? $$salpha : FALSE; my $d = $s; if ($qv && isDIGIT($d)) { goto dotted_decimal_version; } if ($d eq 'v') { # explicit v-string $d++; if (isDIGIT($d)) { $qv = TRUE; } else { # degenerate v-string # requires v1.2.3 return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); } dotted_decimal_version: if ($strict && $d eq '0' && isDIGIT($d+1)) { # no leading zeros allowed return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)"); } while (isDIGIT($d)) { # integer part $d++; } if ($d eq '.') { $saw_decimal++; $d++; # decimal point } else { if ($strict) { # require v1.2.3 return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); } else { goto version_prescan_finish; } } { my $i = 0; my $j = 0; while (isDIGIT($d)) { # just keep reading $i++; while (isDIGIT($d)) { $d++; $j++; # maximum 3 digits between decimal if ($strict && $j > 3) { return BADVERSION($s,$errstr,"Invalid version format (maximum 3 digits between decimals)"); } } if ($d eq '_') { if ($strict) { return BADVERSION($s,$errstr,"Invalid version format (no underscores)"); } if ( $alpha ) { return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)"); } $d++; $alpha = TRUE; } elsif ($d eq '.') { if ($alpha) { return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)"); } $saw_decimal++; $d++; } elsif (!isDIGIT($d)) { last; } $j = 0; } if ($strict && $i < 2) { # requires v1.2.3 return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions require at least three parts)"); } } } # end if dotted-decimal else { # decimal versions my $j = 0; # special $strict case for leading '.' or '0' if ($strict) { if ($d eq '.') { return BADVERSION($s,$errstr,"Invalid version format (0 before decimal required)"); } if ($d eq '0' && isDIGIT($d+1)) { return BADVERSION($s,$errstr,"Invalid version format (no leading zeros)"); } } # and we never support negative version numbers if ($d eq '-') { return BADVERSION($s,$errstr,"Invalid version format (negative version number)"); } # consume all of the integer part while (isDIGIT($d)) { $d++; } # look for a fractional part if ($d eq '.') { # we found it, so consume it $saw_decimal++; $d++; } elsif (!$d || $d eq ';' || isSPACE($d) || $d eq '}') { if ( $d == $s ) { # found nothing return BADVERSION($s,$errstr,"Invalid version format (version required)"); } # found just an integer goto version_prescan_finish; } elsif ( $d == $s ) { # didn't find either integer or period return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)"); } elsif ($d eq '_') { # underscore can't come after integer part if ($strict) { return BADVERSION($s,$errstr,"Invalid version format (no underscores)"); } elsif (isDIGIT($d+1)) { return BADVERSION($s,$errstr,"Invalid version format (alpha without decimal)"); } else { return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)"); } } elsif ($d) { # anything else after integer part is just invalid data return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)"); } # scan the fractional part after the decimal point if ($d && !isDIGIT($d) && ($strict || ! ($d eq ';' || isSPACE($d) || $d eq '}') )) { # $strict or lax-but-not-the-end return BADVERSION($s,$errstr,"Invalid version format (fractional part required)"); } while (isDIGIT($d)) { $d++; $j++; if ($d eq '.' && isDIGIT($d-1)) { if ($alpha) { return BADVERSION($s,$errstr,"Invalid version format (underscores before decimal)"); } if ($strict) { return BADVERSION($s,$errstr,"Invalid version format (dotted-decimal versions must begin with 'v')"); } $d = $s; # start all over again $qv = TRUE; goto dotted_decimal_version; } if ($d eq '_') { if ($strict) { return BADVERSION($s,$errstr,"Invalid version format (no underscores)"); } if ( $alpha ) { return BADVERSION($s,$errstr,"Invalid version format (multiple underscores)"); } if ( ! isDIGIT($d+1) ) { return BADVERSION($s,$errstr,"Invalid version format (misplaced underscore)"); } $width = $j; $d++; $alpha = TRUE; } } } version_prescan_finish: while (isSPACE($d)) { $d++; } if ($d && !isDIGIT($d) && (! ($d eq ';' || $d eq '}') )) { # trailing non-numeric data return BADVERSION($s,$errstr,"Invalid version format (non-numeric data)"); } if ($saw_decimal > 1 && ($d-1) eq '.') { # no trailing period allowed return BADVERSION($s,$errstr,"Invalid version format (trailing decimal)"); } if (defined $sqv) { $$sqv = $qv; } if (defined $swidth) { $$swidth = $width; } if (defined $ssaw_decimal) { $$ssaw_decimal = $saw_decimal; } if (defined $salpha) { $$salpha = $alpha; } return $d; } sub scan_version { my ($s, $rv, $qv) = @_; my $start; my $pos; my $last; my $errstr; my $saw_decimal = 0; my $width = 3; my $alpha = FALSE; my $vinf = FALSE; my @av; $s = new charstar $s; while (isSPACE($s)) { # leading whitespace is OK $s++; } $last = prescan_version($s, FALSE, \$errstr, \$qv, \$saw_decimal, \$width, \$alpha); if ($errstr) { # 'undef' is a special case and not an error if ( $s ne 'undef') { require Carp; Carp::croak($errstr); } } $start = $s; if ($s eq 'v') { $s++; } $pos = $s; if ( $qv ) { $$rv->{qv} = $qv; } if ( $alpha ) { $$rv->{alpha} = $alpha; } if ( !$qv && $width < 3 ) { $$rv->{width} = $width; } while (isDIGIT($pos)) { $pos++; } if (!isALPHA($pos)) { my $rev; for (;;) { $rev = 0; { # this is atoi() that delimits on underscores my $end = $pos; my $mult = 1; my $orev; # the following if() will only be true after the decimal # point of a version originally created with a bare # floating point number, i.e. not quoted in any way # if ( !$qv && $s > $start && $saw_decimal == 1 ) { $mult *= 100; while ( $s < $end ) { $orev = $rev; $rev += $s * $mult; $mult /= 10; if ( (abs($orev) > abs($rev)) || (abs($rev) > $VERSION_MAX )) { warn("Integer overflow in version %d", $VERSION_MAX); $s = $end - 1; $rev = $VERSION_MAX; $vinf = 1; } $s++; if ( $s eq '_' ) { $s++; } } } else { while (--$end >= $s) { $orev = $rev; $rev += $end * $mult; $mult *= 10; if ( (abs($orev) > abs($rev)) || (abs($rev) > $VERSION_MAX )) { warn("Integer overflow in version"); $end = $s - 1; $rev = $VERSION_MAX; $vinf = 1; } } } } # Append revision push @av, $rev; if ( $vinf ) { $s = $last; last; } elsif ( $pos eq '.' ) { $pos++; if ($qv) { # skip leading zeros while ($pos eq '0') { $pos++; } } $s = $pos; } elsif ( $pos eq '_' && isDIGIT($pos+1) ) { $s = ++$pos; } elsif ( $pos eq ',' && isDIGIT($pos+1) ) { $s = ++$pos; } elsif ( isDIGIT($pos) ) { $s = $pos; } else { $s = $pos; last; } if ( $qv ) { while ( isDIGIT($pos) ) { $pos++; } } else { my $digits = 0; while ( ( isDIGIT($pos) || $pos eq '_' ) && $digits < 3 ) { if ( $pos ne '_' ) { $digits++; } $pos++; } } } } if ( $qv ) { # quoted versions always get at least three terms my $len = $#av; # This for loop appears to trigger a compiler bug on OS X, as it # loops infinitely. Yes, len is negative. No, it makes no sense. # Compiler in question is: # gcc version 3.3 20030304 (Apple Computer, Inc. build 1640) # for ( len = 2 - len; len > 0; len-- ) # av_push(MUTABLE_AV(sv), newSViv(0)); # $len = 2 - $len; while ($len-- > 0) { push @av, 0; } } # need to save off the current version string for later if ( $vinf ) { $$rv->{original} = "v.Inf"; $$rv->{vinf} = 1; } elsif ( $s > $start ) { $$rv->{original} = $start->currstr($s); if ( $qv && $saw_decimal == 1 && $start ne 'v' ) { # need to insert a v to be consistent $$rv->{original} = 'v' . $$rv->{original}; } } else { $$rv->{original} = '0'; push(@av, 0); } # And finally, store the AV in the hash $$rv->{version} = \@av; # fix RT#19517 - special case 'undef' as string if ($s eq 'undef') { $s += 5; } return $s; } sub new { my $class = shift; unless (defined $class or $#_ > 1) { require Carp; Carp::croak('Usage: version::new(class, version)'); } my $self = bless ({}, ref ($class) || $class); my $qv = FALSE; if ( $#_ == 1 ) { # must be CVS-style $qv = TRUE; } my $value = pop; # always going to be the last element if ( ref($value) && eval('$value->isa("version")') ) { # Can copy the elements directly $self->{version} = [ @{$value->{version} } ]; $self->{qv} = 1 if $value->{qv}; $self->{alpha} = 1 if $value->{alpha}; $self->{original} = ''.$value->{original}; return $self; } if ( not defined $value or $value =~ /^undef$/ ) { # RT #19517 - special case for undef comparison # or someone forgot to pass a value push @{$self->{version}}, 0; $self->{original} = "0"; return ($self); } if (ref($value) =~ m/ARRAY|HASH/) { require Carp; Carp::croak("Invalid version format (non-numeric data)"); } $value = _un_vstring($value); if ($Config{d_setlocale}) { use POSIX qw/locale_h/; use if $Config{d_setlocale}, 'locale'; my $currlocale = setlocale(LC_ALL); # if the current locale uses commas for decimal points, we # just replace commas with decimal places, rather than changing # locales if ( localeconv()->{decimal_point} eq ',' ) { $value =~ tr/,/./; } } # exponential notation if ( $value =~ /\d+.?\d*e[-+]?\d+/ ) { $value = sprintf("%.9f",$value); $value =~ s/(0+)$//; # trim trailing zeros } my $s = scan_version($value, \$self, $qv); if ($s) { # must be something left over warn("Version string '%s' contains invalid data; " ."ignoring: '%s'", $value, $s); } return ($self); } *parse = \&new; sub numify { my ($self) = @_; unless (_verify($self)) { require Carp; Carp::croak("Invalid version object"); } my $width = $self->{width} || 3; my $alpha = $self->{alpha} || ""; my $len = $#{$self->{version}}; my $digit = $self->{version}[0]; my $string = sprintf("%d.", $digit ); if ($alpha and warnings::enabled()) { warnings::warn($WARN_CATEGORY, 'alpha->numify() is lossy'); } for ( my $i = 1 ; $i < $len ; $i++ ) { $digit = $self->{version}[$i]; if ( $width < 3 ) { my $denom = 10**(3-$width); my $quot = int($digit/$denom); my $rem = $digit - ($quot * $denom); $string .= sprintf("%0".$width."d_%d", $quot, $rem); } else { $string .= sprintf("%03d", $digit); } } if ( $len > 0 ) { $digit = $self->{version}[$len]; if ( $alpha && $width == 3 ) { $string .= "_"; } $string .= sprintf("%0".$width."d", $digit); } else # $len = 0 { $string .= sprintf("000"); } return $string; } sub normal { my ($self) = @_; unless (_verify($self)) { require Carp; Carp::croak("Invalid version object"); } my $alpha = $self->{alpha} || ""; my $qv = $self->{qv} || ""; my $len = $#{$self->{version}}; my $digit = $self->{version}[0]; my $string = sprintf("v%d", $digit ); for ( my $i = 1 ; $i < $len ; $i++ ) { $digit = $self->{version}[$i]; $string .= sprintf(".%d", $digit); } if ( $len > 0 ) { $digit = $self->{version}[$len]; if ( $alpha ) { $string .= sprintf("_%0d", $digit); } else { $string .= sprintf(".%0d", $digit); } } if ( $len <= 2 ) { for ( $len = 2 - $len; $len != 0; $len-- ) { $string .= sprintf(".%0d", 0); } } return $string; } sub stringify { my ($self) = @_; unless (_verify($self)) { require Carp; Carp::croak("Invalid version object"); } return exists $self->{original} ? $self->{original} : exists $self->{qv} ? $self->normal : $self->numify; } sub vcmp { require UNIVERSAL; my ($left,$right,$swap) = @_; my $class = ref($left); unless ( UNIVERSAL::isa($right, $class) ) { $right = $class->new($right); } if ( $swap ) { ($left, $right) = ($right, $left); } unless (_verify($left)) { require Carp; Carp::croak("Invalid version object"); } unless (_verify($right)) { require Carp; Carp::croak("Invalid version format"); } my $l = $#{$left->{version}}; my $r = $#{$right->{version}}; my $m = $l < $r ? $l : $r; my $lalpha = $left->is_alpha; my $ralpha = $right->is_alpha; my $retval = 0; my $i = 0; while ( $i <= $m && $retval == 0 ) { $retval = $left->{version}[$i] <=> $right->{version}[$i]; $i++; } # tiebreaker for alpha with identical terms if ( $retval == 0 && $l == $r && $left->{version}[$m] == $right->{version}[$m] && ( $lalpha || $ralpha ) ) { if ( $lalpha && !$ralpha ) { $retval = -1; } elsif ( $ralpha && !$lalpha) { $retval = +1; } } # possible match except for trailing 0's if ( $retval == 0 && $l != $r ) { if ( $l < $r ) { while ( $i <= $r && $retval == 0 ) { if ( $right->{version}[$i] != 0 ) { $retval = -1; # not a match after all } $i++; } } else { while ( $i <= $l && $retval == 0 ) { if ( $left->{version}[$i] != 0 ) { $retval = +1; # not a match after all } $i++; } } } return $retval; } sub vbool { my ($self) = @_; return vcmp($self,$self->new("0"),1); } sub vnoop { require Carp; Carp::croak("operation not supported with version object"); } sub is_alpha { my ($self) = @_; return (exists $self->{alpha}); } sub qv { my $value = shift; my $class = $CLASS; if (@_) { $class = ref($value) || $value; $value = shift; } $value = _un_vstring($value); $value = 'v'.$value unless $value =~ /(^v|\d+\.\d+\.\d)/; my $obj = $CLASS->new($value); return bless $obj, $class; } *declare = \&qv; sub is_qv { my ($self) = @_; return (exists $self->{qv}); } sub _verify { my ($self) = @_; if ( ref($self) && eval { exists $self->{version} } && ref($self->{version}) eq 'ARRAY' ) { return 1; } else { return 0; } } sub _is_non_alphanumeric { my $s = shift; $s = new charstar $s; while ($s) { return 0 if isSPACE($s); # early out return 1 unless (isALPHA($s) || isDIGIT($s) || $s =~ /[.-]/); $s++; } return 0; } sub _un_vstring { my $value = shift; # may be a v-string if ( length($value) >= 1 && $value !~ /[,._]/ && _is_non_alphanumeric($value)) { my $tvalue; if ( $] >= 5.008_001 ) { $tvalue = _find_magic_vstring($value); $value = $tvalue if length $tvalue; } elsif ( $] >= 5.006_000 ) { $tvalue = sprintf("v%vd",$value); if ( $tvalue =~ /^v\d+(\.\d+)*$/ ) { # must be a v-string $value = $tvalue; } } } return $value; } sub _find_magic_vstring { my $value = shift; my $tvalue = ''; require B; my $sv = B::svref_2object(\$value); my $magic = ref($sv) eq 'B::PVMG' ? $sv->MAGIC : undef; while ( $magic ) { if ( $magic->TYPE eq 'V' ) { $tvalue = $magic->PTR; $tvalue =~ s/^v?(.+)$/v$1/; last; } else { $magic = $magic->MOREMAGIC; } } return $tvalue; } sub _VERSION { my ($obj, $req) = @_; my $class = ref($obj) || $obj; no strict 'refs'; if ( exists $INC{"$class.pm"} and not %{"$class\::"} and $] >= 5.008) { # file but no package require Carp; Carp::croak( "$class defines neither package nor VERSION" ."--version check failed"); } my $version = eval "\$$class\::VERSION"; if ( defined $version ) { local $^W if $] <= 5.008; $version = version::vpp->new($version); } if ( defined $req ) { unless ( defined $version ) { require Carp; my $msg = $] < 5.006 ? "$class version $req required--this is only version " : "$class does not define \$$class\::VERSION" ."--version check failed"; if ( $ENV{VERSION_DEBUG} ) { Carp::confess($msg); } else { Carp::croak($msg); } } $req = version::vpp->new($req); if ( $req > $version ) { require Carp; if ( $req->is_qv ) { Carp::croak( sprintf ("%s version %s required--". "this is only version %s", $class, $req->normal, $version->normal) ); } else { Carp::croak( sprintf ("%s version %s required--". "this is only version %s", $class, $req->stringify, $version->stringify) ); } } } return defined $version ? $version->stringify : undef; } 1; #this line is important and will help the module return a true value VERSION_VPP s/^ //mg for values %fatpacked; my $class = 'FatPacked::'.(0+\%fatpacked); no strict 'refs'; *{"${class}::files"} = sub { keys %{$_[0]} }; if ($] < 5.008) { *{"${class}::INC"} = sub { if (my $fat = $_[0]{$_[1]}) { 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; }); } }; } else { *{"${class}::INC"} = sub { if (my $fat = $_[0]{$_[1]}) { open my $fh, '<', \$fat or die "FatPacker error loading $_[1] (could be a perl installation issue?)"; return $fh; } return; }; } unshift @INC, bless \%fatpacked, $class; } # END OF FATPACK CODE use strict; use App::cpanminus::script; unless (caller) { my $app = App::cpanminus::script->new; $app->parse_options(@ARGV); exit $app->doit; } __END__ =head1 NAME cpanm - get, unpack build and install modules from CPAN =head1 SYNOPSIS cpanm Test::More # install Test::More cpanm MIYAGAWA/Plack-0.99_05.tar.gz # full distribution path cpanm http://example.org/LDS/CGI.pm-3.20.tar.gz # install from URL cpanm ~/dists/MyCompany-Enterprise-1.00.tar.gz # install from a local file cpanm --interactive Task::Kensho # Configure interactively cpanm . # install from local directory cpanm --installdeps . # install all the deps for the current directory cpanm -L extlib Plack # install Plack and all non-core deps into extlib cpanm --mirror http://cpan.cpantesters.org/ DBI # use the fast-syncing mirror cpanm --from https://cpan.metacpan.org/ Plack # use only the HTTPS mirror =head1 COMMANDS =over 4 =item (arguments) Command line arguments can be either a module name, distribution file, local file path, HTTP URL or git repository URL. Following commands will all work as you expect. cpanm Plack cpanm Plack/Request.pm cpanm MIYAGAWA/Plack-1.0000.tar.gz cpanm /path/to/Plack-1.0000.tar.gz cpanm http://cpan.metacpan.org/authors/id/M/MI/MIYAGAWA/Plack-0.9990.tar.gz cpanm git://github.com/plack/Plack.git Additionally, you can use the notation using C<~> and C<@> to specify version for a given module. C<~> specifies the version requirement in the L<CPAN::Meta::Spec> format, while C<@> pins the exact version, and is a shortcut for C<~"== VERSION">. cpanm Plack~1.0000 # 1.0000 or later cpanm Plack~">= 1.0000, < 2.0000" # latest of 1.xxxx cpanm Plack@0.9990 # specific version. same as Plack~"== 0.9990" The version query including specific version or range will be sent to L<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. For a git repository, you can specify a branch, tag, or commit SHA to build. The default is C<master> cpanm git://github.com/plack/Plack.git@1.0000 # tag cpanm git://github.com/plack/Plack.git@devel # branch =item -i, --install Installs the modules. This is a default behavior and this is just a compatibility option to make it work like L<cpan> or L<cpanp>. =item --self-upgrade Upgrades itself. It's just an alias for: cpanm App::cpanminus =item --info Displays the distribution information in C<AUTHOR/Dist-Name-ver.tar.gz> format in the standard out. =item --installdeps Installs the dependencies of the target distribution but won't build itself. Handy if you want to try the application from a version controlled repository such as git. cpanm --installdeps . =item --look Download and unpack the distribution and then open the directory with your shell. Handy to poke around the source code or do manual testing. =item -h, --help Displays the help message. =item -V, --version Displays the version number. =back =head1 OPTIONS You can specify the default options in C<PERL_CPANM_OPT> environment variable. =over 4 =item -f, --force Force install modules even when testing failed. =item -n, --notest Skip the testing of modules. Use this only when you just want to save time for installing hundreds of distributions to the same perl and architecture you've already tested to make sure it builds fine. Defaults to false, and you can say C<--no-notest> to override when it is set in the default options in C<PERL_CPANM_OPT>. =item --test-only Run the tests only, and do not install the specified module or distributions. Handy if you want to verify the new (or even old) releases pass its unit tests without installing the module. Note that if you specify this option with a module or distribution that has dependencies, these dependencies will be installed if you don't currently have them. =item -S, --sudo Switch to the root user with C<sudo> when installing modules. Use this if you want to install modules to the system perl include path. Defaults to false, and you can say C<--no-sudo> to override when it is set in the default options in C<PERL_CPANM_OPT>. =item -v, --verbose Makes the output verbose. It also enables the interactive configuration. (See --interactive) =item -q, --quiet Makes the output even more quiet than the default. It only shows the successful/failed dependencies to the output. =item -l, --local-lib Sets the L<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. =item -L, --local-lib-contained Same with C<--local-lib> but with L<--self-contained> set. All non-core dependencies will be installed even if they're already installed. For instance, cpanm -L extlib Plack would install Plack and all of its non-core dependencies into the directory C<extlib>, which can be loaded from your application with: use local::lib '/path/to/extlib'; 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. =item --self-contained When examining the dependencies, assume no non-core modules are installed on the system. Handy if you want to bundle application dependencies in one directory so you can distribute to other machines. =item --exclude-vendor Don't include modules installed under the 'vendor' paths when searching for core modules when the C<--self-contained> flag is in effect. This restores the behaviour from before version 1.7023 =item --mirror Specifies the base URL for the CPAN mirror to use, such as C<http://cpan.cpantesters.org/> (you can omit the trailing slash). You can specify multiple mirror URLs by repeating the command line option. You can use a local directory that has a CPAN mirror structure (created by tools such as L<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. cpanm --mirror file:///path/to/mirror cpanm --mirror ~/minicpan # Because shell expands ~ to /home/user Defaults to C<http://www.cpan.org/>. =item --mirror-only Download the mirror's 02packages.details.txt.gz index file instead of querying the CPAN Meta DB. This will also effectively opt out sending your local perl versions to backend database servers such as CPAN Meta DB and MetaCPAN. Select this option if you are using a local mirror of CPAN, such as minicpan when you're offline, or your own CPAN index (a.k.a darkpan). =item --from, -M cpanm -M https://cpan.metacpan.org/ cpanm --from https://cpan.metacpan.org/ Use the given mirror URL and its index as the I<only> source to search and download modules from. It works similar to C<--mirror> and C<--mirror-only> combined, with a small difference: unlike C<--mirror> which I<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. B<Tip:> It might be useful if you name these options with your shell aliases, like: alias minicpanm='cpanm --from ~/minicpan' alias darkpan='cpanm --from http://mycompany.example.com/DPAN' =item --mirror-index B<EXPERIMENTAL>: Specifies the file path to C<02packages.details.txt> for module search index. =item --cpanmetadb B<EXPERIMENTAL>: Specifies an alternate URI for CPAN MetaDB index lookups. =item --metacpan Prefers MetaCPAN API over CPAN MetaDB. =item --cpanfile B<EXPERIMENTAL>: Specified an alternate path for cpanfile to search for, when C<--installdeps> command is in use. Defaults to C<cpanfile>. =item --prompt Prompts when a test fails so that you can skip, force install, retry or look in the shell to see what's going wrong. It also prompts when one of the dependency failed if you want to proceed the installation. Defaults to false, and you can say C<--no-prompt> to override if it's set in the default options in C<PERL_CPANM_OPT>. =item --dev B<EXPERIMENTAL>: search for a newer developer release as well. Defaults to false. =item --reinstall cpanm, when given a module name in the command line (i.e. C<cpanm Plack>), checks the locally installed version first and skips if it is already installed. This option makes it skip the check, so: cpanm --reinstall Plack would reinstall L<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). Defaults to false. =item --interactive 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. 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>. =item --pp, --pureperl 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. =item --with-recommends, --with-suggests 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. 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. There's also C<--without-recommend> and C<--without-suggests> to override the default decision made earlier in C<PERL_CPANM_OPT>. Defaults to false for both. =item --with-develop B<EXPERIMENTAL>: Installs develop phase dependencies in META files or C<cpanfile> when used with C<--installdeps>. Defaults to false. =item --with-configure B<EXPERIMENTAL>: Installs configure phase dependencies in C<cpanfile> when used with C<--installdeps>. Defaults to false. =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. cpanm --with-feature=opt_csv Spreadsheet::Read the features can also be interactively chosen when C<--interactive> option is enabled. C<--with-all-features> enables all the optional features, and C<--without-feature> can select a feature to disable. =item --configure-timeout, --build-timeout, --test-timeout Specify the timeout length (in seconds) to wait for the configure, build and test process. Current default values are: 60 for configure, 3600 for build and 1800 for test. =item --configure-args, --build-args, --test-args, --install-args B<EXPERIMENTAL>: Pass arguments for configure/build/test/install commands respectively, for a given module to install. cpanm DBD::mysql --configure-args="--cflags=... --libs=..." The argument is only enabled for the module passed as a command line argument, not dependencies. =item --scandeps B<DEPRECATED>: Scans the depencencies of given modules and output the tree in a text format. (See C<--format> below for more options) Because this command doesn't actually install any distributions, it will be useful that by typing: cpanm --scandeps Catalyst::Runtime you can make sure what modules will be installed. This command takes into account which modules you already have installed in your system. If you want to see what modules will be installed against a vanilla perl installation, you might want to combine it with C<-L> option. =item --format B<DEPRECATED>: Determines what format to display the scanned dependency tree. Available options are C<tree>, C<json>, C<yaml> and C<dists>. =over 8 =item tree Displays the tree in a plain text format. This is the default value. =item json, yaml Outputs the tree in a JSON or YAML format. L<JSON> and L<YAML> modules need to be installed respectively. The output tree is represented as a recursive tuple of: [ distribution, dependencies ] and the container is an array containing the root elements. Note that there may be multiple root nodes, since you can give multiple modules to the C<--scandeps> command. =item dists C<dists> is a special output format, where it prints the distribution filename in the I<depth first order> after the dependency resolution, like: GAAS/MIME-Base64-3.13.tar.gz GAAS/URI-1.58.tar.gz PETDANCE/HTML-Tagset-3.20.tar.gz GAAS/HTML-Parser-3.68.tar.gz GAAS/libwww-perl-5.837.tar.gz which means you can install these distributions in this order without extra dependencies. When combined with C<-L> option, it will be useful to replay installations on other machines. =back =item --save-dists Specifies the optional directory path to copy downloaded tarballs in the CPAN mirror compatible directory structure i.e. I<authors/id/A/AU/AUTHORS/Foo-Bar-version.tar.gz> 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>. =item --uninst-shadows Uninstalls the shadow files of the distribution that you're installing. This eliminates the confusion if you're trying to install core (dual-life) modules from CPAN against perl 5.10 or older, or modules that used to be XS-based but switched to pure perl at some version. If you run cpanm as root and use C<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. Defaults to true if your perl version is smaller than 5.12, and you can disable that with C<--no-uninst-shadows>. 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. =item --uninstall, -U Uninstalls a module from the library path. It finds a packlist for given modules, and removes all the files included in the same distribution. If you enable local::lib, it only removes files from the local::lib directory. If you try to uninstall a module in C<perl> directory (i.e. core module), an error will be thrown. A dialog will be prompted to confirm the files to be deleted. If you pass C<-f> option as well, the dialog will be skipped and uninstallation will be forced. =item --cascade-search B<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. =item --skip-installed Specifies whether a module given in the command line is skipped if its latest version is already installed. Defaults to true. B<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. =item --skip-satisfied B<EXPERIMENTAL>: Specifies whether a module (and version) given in the command line is skipped if it's already installed. If you run: cpanm --skip-satisfied CGI DBI~1.2 cpanm won't install them if you already have CGI (for whatever versions) or have DBI with version higher than 1.2. It is similar to C<--skip-installed> but while C<--skip-installed> checks if the I<latest> version of CPAN is installed, C<--skip-satisfied> checks if a requested version (or not, which means any version) is installed. Defaults to false. =item --verify Verify the integrity of distribution files retrieved from CPAN using CHECKSUMS file, and SIGNATURES file (if found in the distribution). Defaults to false. Using this option does not verify the integrity of the CHECKSUMS file, and it's unsafe to rely on this option if you're using a CPAN mirror that you do not trust. =item --report-perl-version Whether it reports the locally installed perl version to the various web server as part of User-Agent. Defaults to true unless CI related environment variables such as C<TRAVIS>, C<CI> or C<AUTOMATED_TESTING> is enabled. You can disable it by using C<--no-report-perl-version>. =item --auto-cleanup Specifies the number of days in which cpanm's work directories expire. Defaults to 7, which means old work directories will be cleaned up in one week. You can set the value to C<0> to make cpan never cleanup those directories. =item --man-pages Generates man pages for executables (man1) and libraries (man3). Defaults to true (man pages generated) unless C<-L|--local-lib-contained> option is supplied in which case it's set to false. You can disable it with C<--no-man-pages>. =item --lwp Uses L<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. =item --wget Uses GNU Wget (if available) to download stuff. Defaults to true, and you can say C<--no-wget> to disable using Wget (versions of Wget older than 1.9 don't support the C<--retry-connrefused> option used by cpanm). =item --curl Uses cURL (if available) to download stuff. Defaults to true, and you can say C<--no-curl> to disable using cURL. Normally with C<--lwp>, C<--wget> and C<--curl> options set to true (which is the default) cpanm tries L<LWP>, Wget, cURL and L<HTTP::Tiny> (in that order) and uses the first one available. =back =head1 ENVIRONMENT VARIABLES =over 4 =item PERL_CPANM_HOME 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. =item PERL_CPANM_OPT If set, adds a set of default options to every cpanm command. These options come first, and so are overridden by command-line options. =back =head1 SEE ALSO L<App::cpanminus> =head1 COPYRIGHT Copyright 2010- Tatsuhiko Miyagawa. =head1 AUTHOR Tatsuhiko Miyagawa =cut PK jA[S��L� � MYMETA.jsonnu �[��� { "abstract" : "get, unpack, build and install modules from CPAN", "author" : [ "- Tatsuhiko Miyagawa" ], "dynamic_config" : 0, "generated_by" : "Dist::Milla version v1.0.22, Dist::Zilla version 6.025, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "App-cpanminus", "no_index" : { "directory" : [ "eg", "examples", "inc", "share", "t", "xt" ], "file" : [ "lib/App/cpanminus/fatscript.pm" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "develop" : { "recommends" : { "Archive::Tar" : "0", "Archive::Zip" : "0", "Compress::Zlib" : "0", "File::HomeDir" : "0", "Module::Signature" : "0" }, "requires" : { "App::FatPacker" : "0", "CPAN::DistnameInfo" : "0", "CPAN::Meta" : "2.132830", "CPAN::Meta::Check" : "0", "CPAN::Meta::Prereqs" : "0", "CPAN::Meta::Requirements" : "0", "CPAN::Meta::YAML" : "0", "Capture::Tiny" : "0", "Digest::SHA" : "0", "Dist::Milla" : "v1.0.22", "Exporter" : "5.63", "File::Temp" : "0", "File::pushd" : "0", "Getopt::Long" : "0", "HTTP::Tiny" : "0", "JSON" : "0", "JSON::PP" : "0", "LWP::Simple" : "0", "LWP::UserAgent" : "5.802", "Module::CPANfile" : "0", "Module::CoreList" : "0", "Module::Install" : "0", "Module::Metadata" : "0", "Parse::CPAN::Meta" : "0", "Parse::PMFile" : "0.26", "Perl::Strip" : "0", "String::ShellQuote" : "0", "Test::More" : "0.90", "Test::Pod" : "1.41", "Test::Requires" : "0", "Tie::File" : "0", "YAML" : "0", "YAML::Tiny" : "0", "local::lib" : "0", "version" : "0" } }, "runtime" : { "requires" : { "perl" : "5.008001" } }, "test" : { "requires" : { "Test::More" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/miyagawa/cpanminus/issues" }, "homepage" : "https://github.com/miyagawa/cpanminus", "repository" : { "type" : "git", "url" : "https://github.com/miyagawa/cpanminus.git", "web" : "https://github.com/miyagawa/cpanminus" } }, "version" : "1.7047", "x_contributors" : [ "Aaron Moses <mosesa02@localhost.localdomain>", "Alessandro Ghedini <al3xbio@gmail.com>", "Andrew Rodland <andrew@cleverdomain.org>", "Andy Jones <andy@broadbean.com>", "andyjones <andy_jones@outgun.com>", "Ash Berlin <ash_github@firemirror.com>", "Ben Bullock <benkasminbullock@gmail.com>", "Breno G. de Oliveira <garu@cpan.org>", "Brian Wightman <MidLifeXis@wightmanfam.org>", "cho45 <cho45@lowreal.net>", "Christian Walde <walde.christian@googlemail.com>", "chromatic <chromatic@wgz.org>", "Dagfinn Ilmari Mannsaker <ilmari@ilmari.org>", "Dana M. Diederich <diederich@gmail.com>", "Dave Goodell <davidjgoodell@gmail.com>", "Dave Rolsky <autarch@urth.org>", "David Golden <dagolden@cpan.org>", "David Steinbrunner <dsteinbrunner@pobox.com>", "Doug Bell <madcityzen@gmail.com>", "Eli Flanagan <eflanagan@innovu.com>", "fREW Schmidt <frioux@gmail.com>", "Fuji, Goro <g.psy.va@gmail.com>", "Gareth Kirwan <gbjk@thermeon.com>", "gfx <gfuji@cpan.org>", "Graham Knop <haarg@haarg.org>", "Graham Ollis <perl@wdlabs.com>", "ikasam_a <masaki.nakagawa@gmail.com>", "Ingy dot Net <ingy@ingy.net>", "Jan Dubois <jand@activestate.com>", "Jeffrey Ryan Thalhammer <jeff@imaginative-software.com>", "Jesse Luehrs <doy@tozt.net>", "J. Nick Koston <nick@cpanel.net>", "jonallen <jj@jonallen.info>", "Jonathan Scott Duff <duff@pobox.com>", "Kahlil (Kal) Hodgson <kahlil.hodgson@dealmax.com.au>", "Kenichi Ishigaki <ishigaki@cpan.org>", "Kent Fredric <kentnl@cpan.org>", "kmx <kmx@cpan.org>", "Larry Leszczynski <larryl@atomiclearning.com>", "lestrrat <lestrrat+github@gmail.com>", "Masahiro Nagano <kazeburo@gmail.com>", "Masayoshi Sekimura <sekimura@gmail.com>", "Matthew Horsfall <wolfsage@gmail.com>", "Matt S Trout <>", "Matt S Trout <mst@shadowcat.co.uk>", "Michael G. Schwern <schwern@pobox.com>", "motemen <motemen@gmail.com>", "moznion <moznion@gmail.com>", "Nicolas R <atoomic@cpan.org>", "Norman Nunley <nnunley@gmail.com>", "Olaf Alders <olaf@wundersolutions.com>", "Olivier Mengue <dolmen@cpan.org>", "Pedro Melo <melo@simplicidade.org>", "Rafal Pocztarski <r.pocztarski@gmail.com>", "reezer <kind@gmx.at>", "Ricardo Signes <rjbs@cpan.org>", "robario <webmaster@robario.com>", "Robert Buels <rmb32@cornell.edu>", "Rob Hoelz <rob@hoelz.ro>", "Roman Jurkov <rjurkov@verio.net>", "Sebastian Riedel <sri@cpan.org>", "Shoichi Kaji <skaji@cpan.org>", "Slaven Rezic <slaven@rezic.de>", "Smylers <Smylers@stripey.com>", "Stoned Elipot <stoned.elipot@gmail.com>", "Syohei YOSHIDA <syohex@gmail.com>", "Tatsuhiko Miyagawa <miyagawa@bulknews.net>", "Tatsuhiko Miyagawa <miyagawa@gmail.com>", "Thomas Sibley <tom@zulutango.org>", "Tokuhiro Matsuno <tokuhirom@gmail.com>", "Tuure Laurinolli <tuure.laurinolli@portalify.com>", "vti <viacheslav.t@gmail.com>", "Vyacheslav Matyukhin <mmcleric@yandex-team.ru>", "xaicron <xaicron@gmail.com>", "Yann Kerherve <yann@cyberion.net>", "yappo <yappo@shibuya.pl>", "zebardy <zebardy@gmail.com>" ], "x_generated_by_perl" : "v5.34.1", "x_serialization_backend" : "JSON::PP version 4.06", "x_spdx_expression" : "Artistic-1.0-Perl OR GPL-1.0-or-later", "x_static_install" : 0 } PK jA[l �|| | READMEnu �[��� NAME App::cpanminus - get, unpack, build and install modules from CPAN SYNOPSIS cpanm Module Run cpanm -h or perldoc cpanm for more options. 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. INSTALLATION There are several ways to install cpanminus to your system. 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 cpanm to your system without thinking about where to install, and later upgrade. 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 cpanm to your bin directory like /usr/local/bin and you'll need the --sudo option to write to the directory, unless you configured INSTALL_BASE with local::lib. Installing to local perl (perlbrew, plenv etc.) If you have perl in your home directory, which is the case if you use tools like perlbrew or plenv, you don't need the --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 cpanm executable to the perl's bin path, like ~/perl5/perlbrew/bin/cpanm. 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 --self-upgrade might not work with this installation setup. Troubleshoot: HTTPS warnings When you run 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 -k option with curl. DEPENDENCIES perl 5.8.1 or later. * 'tar' executable (bsdtar or GNU tar version 1.22 are recommended) or Archive::Tar to unpack files. * C compiler, if you want to build XS modules. * make * Module::Build (core in 5.10) QUESTIONS How does cpanm get/parse/update the CPAN index? It queries the CPAN Meta DB site at 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 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 --no-report-perl-version option. Read more about the option with cpanm, and read more about the privacy policy about this data collection at http://cpanmetadb.plackperl.org/#privacy Fetched files are unpacked in ~/.cpanm and automatically cleaned up periodically. You can configure the location of this with the PERL_CPANM_HOME environment variable. Where does this install modules to? Do I need root access? It installs to wherever ExtUtils::MakeMaker and Module::Build are configured to (via PERL_MM_OPT and 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 perl -V and it will be likely something under /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 perl5 directory under your home directory. To avoid this, run cpanm either as a root user, with --sudo option, or with --local-lib option. 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: * Tests that require input from STDIN. * Build.PL or Makefile.PL that prompts for input even when PERL_MM_USE_DEFAULT is enabled. * Modules that have invalid numeric values as VERSION (such as 1.1a) These failures can be reported back to the author of the module so that they can fix it accordingly, rather than to cpanminus. Does cpanm support the feature XYZ of CPAN and CPANPLUS? Most likely not. Here are the things that cpanm doesn't do by itself. If you need these features, use CPAN, CPANPLUS or the standalone tools that are mentioned. * CPAN testers reporting. See App::cpanminus::reporter * Building RPM packages from CPAN modules * Listing the outdated modules that needs upgrading. See App::cpanoutdated * Showing the changes of the modules you're about to upgrade. See cpan-listchanges * Patching CPAN modules with distroprefs. See cpanm or cpanm -h to see what cpanminus can do :) COPYRIGHT Copyright 2010- Tatsuhiko Miyagawa The standalone executable contains the following modules embedded. CPAN::DistnameInfo Copyright 2003 Graham Barr local::lib Copyright 2007-2009 Matt S Trout HTTP::Tiny Copyright 2011 Christian Hansen Module::Metadata Copyright 2001-2006 Ken Williams. 2010 Matt S Trout version Copyright 2004-2010 John Peacock JSON::PP Copyright 2007-2011 by Makamaka Hannyaharamitu CPAN::Meta, CPAN::Meta::Requirements Copyright (c) 2010 by David Golden and Ricardo Signes CPAN::Meta::YAML Copyright 2010 Adam Kennedy CPAN::Meta::Check Copyright (c) 2012 by Leon Timmermans File::pushd Copyright 2012 David Golden parent Copyright (c) 2007-10 Max Maischein Parse::PMFile Copyright 1995 - 2013 by Andreas Koenig, Copyright 2013 by Kenichi Ishigaki String::ShellQuote by Roderick Schertler LICENSE This software is licensed under the same terms as Perl. CREDITS 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. 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. COMMUNITY http://github.com/miyagawa/cpanminus - source code repository, issue tracker irc://irc.perl.org/#cpanm - discussions about cpanm and its related tools 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. SEE ALSO CPAN CPANPLUS pip PK jA[ pm_to_blibnu �[��� PK jA[a�HMS� S� : Changesnu �[��� PK jA[ ,1�x x �� MANIFEST.SKIPnu �[��� PK jA[���O y� cpanfilenu �[��� PK jA[�Kd>�t �t �� Makefilenu �[��� PK jA[��;l l �[ META.jsonnu �[��� PK jA[�� ��G �G Zu LICENSEnu �[��� PK jA[�{R� � T� t/happy_cpantesters.tnu ȯ�� PK jA[�� t� META.ymlnu �[��� PK jA[Fk�r �� Makefile.PLnu �[��� PK jA[�%"�F� F� � bin/cpanmnu �[��� PK jA[��b b ' �p blib/man3/App::cpanminus::fatscript.3pmnu �[��� PK jA[�?��2 2 �� blib/man3/App::cpanminus.3pmnu �[��� PK jA[ F blib/man3/.existsnu �[��� PK jA[ � blib/man1/.existsnu �[��� PK jA[އ�}�a �a � blib/man1/cpanm.1nu �[��� PK jA[ �g blib/arch/.existsnu �[��� PK jA[ $ 0h blib/arch/auto/App/cpanminus/.existsnu �[��� PK jA[ �h blib/bin/.existsnu �[��� PK jA[{%�O� O� �h blib/script/cpanmnu ȯ�� PK jA[ T blib/script/.existsnu �[��� PK jA[�D�� � � blib/lib/App/cpanminus.pmnu ��6�$ PK jA[r��~� � # �& blib/lib/App/cpanminus/fatscript.pmnu ��6�$ PK jA[ 2� blib/lib/App/.existsnu �[��� PK jA[ # v� blib/lib/auto/App/cpanminus/.existsnu �[��� PK jA[#�H2 2 �� MYMETA.ymlnu �[��� PK jA[t�N*� � 5� MANIFESTnu �[��� PK jA[�D�� � h� lib/App/cpanminus.pmnu �[��� PK jA[r��~� � � lib/App/cpanminus/fatscript.pmnu �[��� PK jA[S��L� � ��# MYMETA.jsonnu �[��� PK jA[l �|| | ��# READMEnu �[��� PK � ��#
| ver. 1.4 |
Github
|
.
| PHP 8.2.29 | Генераци� �траницы: 0.03 |
proxy
|
phpinfo
|
�а�тройка