Pinto-0.14/000755 000766 000024 00000000000 13141540305 012601 5ustar00jeffstaff000000 000000 Pinto-0.14/bin/000755 000766 000024 00000000000 13141540305 013351 5ustar00jeffstaff000000 000000 Pinto-0.14/Changes000644 000766 000024 00000224634 13141540305 014107 0ustar00jeffstaff000000 000000 0.14 2017-08-06 00:09:07-07:00 America/Los_Angeles [BUG FIXES] - Fixed argument processing in the `reset` and `revert` commands. - Fixed some typos in the documentation. [OTHER] - Upgraded to latest Module::CoreList to support newer perls. - Switched to an internal fork of Term::EditorEdit to avoid unwanted dependency on deprecated module Any::Moose - Switched to using MakeMaker instead of ModuleBuild, now that the later is no longer in core. I recommend installing with UNINST=1 to clean up the cruft from older releases. 0.13 2017-08-05 22:46:26-07:00 America/Los_Angeles BROKEN RELEASE. DO NOT USE. 0.12 2016-07-25 20:58:40-07:00 America/Los_Angeles [BUG FIXES] - The 02packages index is now sorted case-insensitively, just like PAUSE. Fixes GH #226. Thanks @miyagawa - Now requires Module::Metadata 1.000031, fixing GH #204. - Now requires latest Module::CoreList (currently 5.20160720) to support latest perl releases. 0.11_01 2016-07-16 21:37:51-07:00 America/Los_Angeles [DEVELOPER RELEASE] - Changes consolidated above under version 0.12 0.11 2015-08-12 01:25:13-07:00 America/Los_Angeles [BUG FIXES] - Workaround conflict between version and EU::MM::version. GH #204. 0.09999 2015-06-13 22:13:46-07:00 America/Los_Angeles [BUG FIXES] - Fixed tests that failed in environments using an HTTP proxy. GH #202. 0.09998 2015-06-10 00:28:12-07:00 America/Los_Angeles [THANKS] Several of the changes in this release were contributed by Chris Kirke as part of the CPAN Pull Request Challenge, organized by Neil Bowers. I am sincerely grateful for their efforts. [BUG FIXES] - The t/, xt/, inc, and local/ directories are always ignored when indexing a distribution. This is exactly what PAUSE does. - Fixed test failures caused by the presence of a ~/.pause file. GH #172. [NEW COMMANDS] - The "look" command will unpack a distribution into a temporary directory and spawn a subshell in that location. Contributed by Kal Hodgson. [ENHANCMENTS] - The "diff" command now has a --format option for more precise control of the output. Contributed by Florian Ragwitz. - A stale repository lockfile can be stollen if the PINTO_STALE_LOCKFILE_TIMEOUT environment variable is set. Contributed by Chris Kirke. GH #209. - Operations with the --dry-run option are now allowed on locked stacks. Contributed by Chris Kirke. GH #207. - Improved error messages when a repository is not in a sane state. Contributed by Chris Kirke. GH #199. - Improved latency from Pinto::Server by autoflushing the output. [PREREQUISITES] - Several of the prerequisite modules have been upgraded to newer versions to take advantage of recent improvements, and to support Perl 5.22.0. If you have installed Pinto as a stand-alone application as described in Pinto::Manual::Installing then your environment will be insulated from these upgrades. 0.09996 2014-11-04 10:54:11-08:00 America/Los_Angeles [MISCELLANEOUS] - Upgraded to latest version of Module::CoreList, so we can support latest versions of perl. - Tests will no longer clobber ~/.cpanm (GH #170). Thanks to Karen Etheridge for pointing this out. 0.09995 2014-08-19 18:27:23 America/Los_Angeles [SECURITY] - Fixed critical security hole in Pinto::Server. If you are using pintod, please upgrade now! Thanks to Aran Deltac for reporting this. [ENHANCEMENTS] - Improved error handling in Pinto::Remote so you get pretty colored errors instead of big ugly stack traces, just like you do when using a local repository. [MISCELLANEOUS] - Demoted some warnings to notifications, for less noisy output. Use the --verbose option to see more diagnostic output. 0.09993 2014-05-02 17:43:41 America/Los_Angeles [INCOMPATILBE CHANGES] - The protocol used to communicate with a remote Pinto repository is now versioned with media types via the "Accept" header. So if you upgrade to this version of pinto, you'll also need to upgrade pintod to this same version. Going forward, the protocol will be versioned so that we can potentially support different versions of the client and server at the same time. But for the time being, you'll get an exception telling you whether to upgrade your client (pinto) or the server (pintod). - The PINTO_COLORS and PINTO_COLOURS environment variables are deprecated in favor of PINTO_PALETTE. You can still use the old names for now, but they will be removed in a future release. - When using the --all option with the "list" command, the default format shows the pin status as "?" (i.e. indeterminable) instead of showing the main module status. [BUG FIXES] - Colorization is now disabled by default when the output is being piped or redirected to a file. This improves interoperability with tools like grep, sort, etc. To force colorization, use the --color or --colour option. Fixes GH #155. Thanks @mar-kolya. - The "roots" will now include test and develop prereqs, since Pinto has no way of knowing how those distributions relate to your application. This fixes GH #158. Thanks @mar-kolya. - Fixed timezone.t test which would fail in some cases, ostensibly because the test environment would not allow us to open sockets (probably due to security reasons). Thanks CPAN Testers. [ENHANCEMENTS] - When using the "add" command, the paths to the local archives can now be expressed using file:/// URLs. - The PINTO_PAGER_OPTIONS environment variable can now be used to pass specific options to your pager when using it with pinto. For example, to tell `less` to display colors. [DOCUMENTATION] - Revised the Tutorial and QuickStart documentation. 0.09992_02 2014-04-29 14:22:29 America/Los_Angeles 0.09992_01 2014-04-28 10:31:21 America/Los_Angeles - Changes consolidated above under version 0.09993$ 0.09992 2014-04-23 15:14:50 America/Los_Angeles [BUG FIXES] - Fixed extra newlines that were inserted into large responses from Pinto::Server. Closes GH #154. Thanks @mar-kolya. 0.09991 2014-04-05 06:28:18 America/Denver [BUG FIXES] - Fixed timezone handling for remote users. But it only applies to new revisions. Old ones will probably still be reported in the wrong timezone (unless you happen to be in the right one). 0.0999 2014-04-03 22:53:31 America/Los_Angeles [INCOMPATIBLE CHANGES] - Internal API changes only. Now all the attributes that were named "from_stack" are named "stack". This makes the API more consistent, since the "stack" is almost always the thing that is in play. [OTHER CHANGES] - No new features, enhancements, or bug fixes. 0.0998 2014-03-31 15:27:14 America/Los_Angeles [BUG FIXES] - Fixed behavior and error message when the repository is not writable by the user. Fixes GH #150. Thanks @bkysela. 0.0997 2014-03-23 20:36:48 America/Los_Angeles [BUG FIXES] - Fixed behavior of the --force flag on the new "update" command. It now applies to all packages that might be updated, not just the targets list on the command line. [ENHANCEMENTS] - When generating the title for the log message, only the targets at the top of the dependency graph are listed, and only if they (or one of their prerequisites) were actually affected by the operation. In effect, redundant and prereq targets are therefore excluded from the message. This attempts to fix GH #86. Thanks @akarelas. 0.0996 2014-03-22 21:12:29 America/Los_Angeles [BUG FIXES] - Added a workaround for Net::LibIDN, which was not being properly indexed. If you experienced this problem, just `pull Net::LibIDN` to correct it. This fixed GH #149. Thanks @perlpunk and @malbin. 0.0995 2014-03-18 21:12:56 America/Los_Angeles [INCOMPATIBLE CHANGES] - The argument for the "init" command is now the repository root instead of the stack name. This makes the interface more convenient and more familiar to git users. You can still specify the root using the global --root option if you like. And the initial stack name can be set with the --stack option. [NEW COMMANDS] - All the new command listed below are experimental. The interface and behavior is subject to change. See the POD in each command for details. - The "update" command pulls the latest version of packages. You can ask to update all packages or just specific ones. - The "merge" command joins the history of two stacks together. At the moment, it is only capable of fast-forward merges. - The "reset" command moves the head of the stack to a prior revision, thereby discarding all subsequent revisions. - The "revert" command creates a new revision that matches the state at a prior revision. [ENHANCEMENTS] - The index file for each stack now contains artificial records for each module that is included in the target version of perl. This allows installers to cope with requests to install core modules, which normally aren't present in a Pinto repository. If you pull a dual-life module, it will mask the artifical records. The artifical records never appear in a stack diff or listing. NOTE: This change will take effect the next time you perform any command that modifies the state of the stack. [BUG FIXES] - The "install" command threw an exception with a misleading error message when using the -m option without --do-pull. Now, both the -m and -M options are silently ignored when --do-pull is not used. Fixes GH #145 (thanks, @hartzell) 0.0994_04 2014-03-17 21:33:08 America/Los_Angeles 0.0994_03 2014-03-16 00:38:40 America/Los_Angeles 0.0994_02 2014-03-15 23:07:23 America/Los_Angeles 0.0994_01 2014-03-05 01:04:46 America/Los_Angeles - Changes consolidated above under version 0.0995 0.0994 2014-03-01 16:04:28 America/Los_Angeles [ENHANCEMENTS] - Improved the locking mechanism so concurrent read operations are sometimes possible, especially during the "install" command. This fixes GH #142. 0.0993 2014-02-23 14:03:28 America/Los_Angeles [INCOMPATIBLE CHANGES] - Pinto no longer sets the default port when connecting to a remote repository. So in most cases, you'll have to explicitly add the port number to the URI given as the --root. The default port that "pintod" listens on is 3111. But if you're running "pintod" behind another server (like Apache or Nginx) then you can probably omit the port number and Pinto will use the default port that is appropriate for the scheme. Closes GH #136. Thanks @spacebat. [ENHANCEMENTS] - When the repository is a local directory, it can also be expressed using a file:// URI. This applies to both the --root option and the PINTO_REPOSITORY_ROOT environment variable. Fixes GH #128. 0.0992 2014-02-10 02:01:18 America/Los_Angeles [ENHANCEMENTS] - The "list" command now has a --all option that causes it to list every package in every distribution in the repository, including past releases and distributions that are not currently registered on any stack. When using the --all option, the output includes two extra flags: "m" means that the package is considered to be the main module in the distribution. "x" means that the package can be included in the index. For both of these, the flags will appear as "-" when they are false. - The --packages, --distributions, and --authors filtering options on the "list" command are now treated as regular expressions. Take care to quote them if you use any special shell metacharacters. [BUG FIXES] - Fixed regression in the "pin", "unpin", and "unregister" commands which resulted in a warning from DBIx::Class about returning multiple rows for a find() query. 0.0991 2014-01-31 17:19:17 America/Los_Angeles [INCOMPATIBLE CHANGES] - The --skip-missing-prerequisites option has been replaced with two separate options: 1) --skip-missing-prerequisite (without the final "s") requires you to specify the name of the packages you want to skip. This option can be repeated. 2) --skip-all-missing-prerequisites does not require an argument and causes Pinto to skip all missing prereqs. These options can be abbreviated as -k and -K respectively. 0.099 2014-01-28 12:30:49 America/Los_Angeles [INCOMPATIBLE CHANGES] - The logic that Pinto uses to construct the index has changed. The index will now include packages only if they are contained in a file with a matching name. For example, Foo::Bar must be in a file called Bar.pm. So in effect, Pinto will only index packages that can be use'd or require'd and thus form a dependency. This makes it more of a "module" index rather than a pure "package" index like PAUSE. But Pinto has never promised to index exactly like PAUSE anyway. The benefit is that it also fixes the problem of Pinto indexing packages that it shouldn't. - The aforementioned changes to the index logic will only apply when a distribution is pulled to a stack where it isn't already registered. Existing indexes will not spontaneously change just by upgrading Pinto. If you wish to apply the new index logic to a distribution that already lives in a certain stack, first use the "unregister" command to remove it from the stack and then use the "register" command to bring it back with the new logic. [ENHANCEMENTS] - For repositories that prohibit intermingled distributions in the index (which is the default) the registration process has been optimized because we can assume that all packages in the distribution are in the index. In some cases, this can make the "pull" and "add" commands much faster, especially for distributions that contain a large number of packages. [BUG FIXES] - When deciding if a prequisite is satisfied by the perl core, Pinto now regards a package that is marked as deprecated in the target perl version as if it has already been removed, thus causing Pinto to pull the prereq. This makes Pinto consistent with the behavior of cpanm. 0.098_01 2014-01-28 01:43:19 America/Los_Angeles - Changes consolidated above under version 0.099 0.098 2014-01-27 16:49:14 America/Los_Angeles [IMPORTANT] - This release contains a lot of new features. I strongly recommend reading the manual pages for the "pull", "add", "log", and "diff" commands as well as "pinto" itself for further explanation of the enhancements mentioned below. - Many of the new features in this release were financed by the Perl community through a crowdfunding campaign. Thank you for your support. Go to http://tinyurl.com/gopinto to see how it all happened. [ENHANCEMENTS] - Pinto can now use a web service provided by stratopan.com to locate upstream packages and distributions. This can reduce memory consumption during the "pull" and "add" commands by about 50%. And for distributions with few dependencies, it can increase the speed of those commands by as much as 300%. This feature will be enabled by default for new repositories. For existing repositories it must be enabled manually by adding "http://cpan.stratopan.com" as the (usually first) upstream source in your repository configuration file. - The "pull" command can now fetch a precise version of a package using a version specification string such as "Moose==1.34" or "Plack>=2,!=4". This means you can quickly build a repository with your current depedencies and you only need to know the package name and version. This feature will be enabled by default for new repositories. For existing repositories it must be enabled manually by adding "http://cpan.stratopan.com" as the (usually first) upstream source in your repository configuration file. - The "pull" and "add" commands now have a --skip-missing-prerequisites flag that causes it to skip (but warn about) any prerequisite packages that it cannot satisfy. You can use it to specify precisely which packages to skip, or to skip all unsatisfiable packages. This option only has effect when recursively pulling prerequisites. - When using the --dry-run option, a diff report will be displayed, showing all the changes that would have been made. If there were no changes, nothing is shown. - The diff reports now default to a concise format which only lists the distributions that have changed in the index rather than each package. - All commands that show diff reports now have a --diff-style option that controls whether to display the concise or detailed report. You can also set the default style using the PINTO_DIFF_STYLE environment variable. - The "log" command now has a --with-diffs (or -d) option that causes it to also display the diff from the previous revision. - Pinto can now handle META files that contain prerequisites with version ranges such as ">4, !=5, <=7". These are currently used by a handful of distributions on CPAN, and they are gradually becoming more common. Fixes GH #127. [BUG FIXES] - The "roots" command was returning way too many distributions because it wasn't examining all the indirect dependencies. - Fixed when pulling a precise package target (e.g. Foo::Bar==1.0) that existed in a distribution that you already had. 0.097_04 2014-01-25 15:12:31 America/Los_Angeles 0.097_03 2014-01-23 13:07:22 America/Los_Angeles 0.097_02 2014-01-23 00:37:04 America/Los_Angeles 0.097_01 2014-01-17 12:46:28 America/Los_Angeles - Changes consolidated above under version 0.098 0.097 2014-01-07 20:53:29 America/Los_Angeles [BUG FIXES] - Fixed compatibility with the exception objects thrown by the latest version of Moose. However, Pinto itself does not require the latest version of Moose. 0.096 2014-01-07 10:32:19 America/Los_Angeles [ENHANCEMENTS] - The exit status of the "list" command will now be non-zero if you specify any search criteria and no matches are found. This follows the behavior of the Unix "ls" command. [BUG FIXES] - Now requires Module::CoreList 3.03 or newer. 0.095 2013-12-22 23:38:28 America/Los_Angeles [BUG FIXES] - Fixed bug in the new "roots" command that caused it to report far fewer distributions than it should. [ENHANCEMENTS] - A warning is emitted if you try to pull or add a Bundle distribution. Pinto does not know how to automatically determine prerequisites for a Bundle. - A better error message is given when repository is not writable. Previously, you were (incorrectly) told that the repository was locked. 0.094 2013-12-22 00:36:27 America/Los_Angeles [INCOMPATIBLE CHANGES] - When pulling or adding a distribution which contains packages that partially overlap with an existing distribution on the stack, then all packages from the existing distribution are removed from the stack, not just the overlapping ones. This means it is impossible for the stack to contain only *some* of the packages from any distribution. In nearly all cases, this is what you want because you never want to end up with an installation that has some packages from one distribution and some packages from another. If you really want your stack to contain the packages from both distributions like the PAUSE index does, then Pinto probably isn't the right tool for you. [NEW COMMANDS] - The "roots" command will list all the distributions that are the root ancestors of the dependency graph which includes all distributions in the stack. This command can be used to install every distribution in the stack in one shot. There are some caveats though. See the documentation for details. 0.093 2013-12-21 16:24:39 America/Los_Angeles [INCOMPATIBLE CHANGES] - The "add" and "pull" commands now have both --no-recurse and --recurse options. This allows you to turn recursion off OR on, depending on the default setting for the repository (see more about that under ENHANCEMENTS). However, the -n shortcut for --no-recurse is no longer available. [ENHANCEMENTS] - The pinto.ini configuration file may now contain a "recurse" parameter that determines the default recursion behavior for the "pull" and "add" commands. Setting it to 1 means those commands are recursive by default. Setting it to 0 means those commands are not recursive by default. Either way, commands can always override that parameter using either the --recurse or --no-recurse switches. - pinto now falls back to using nano, pico, or vi if none of the usual environment variables for controlling the editor are set. This fixes #119. Thanks @borisdaeppen for the suggestion. - The distributions listed in the generated title of the commit message will now be sorted and deduplicated. 0.092 2013-11-20 11:07:50 America/Los_Angeles [ENHANCEMENTS] - Periods are now allowed in stack names, user names, and property names. Note that author ids are still limited to uppercase letters and numbers, to be consistent with PAUSE. 0.091 2013-10-25 12:09:52 America/Los_Angeles [BUG FIXES] - pinto now accepts remote repository addresses that use SSL (i.e. those starting with "https://"). This fixes #123. [DOCUMENTATION] - Numerous spelling corrections and documentation improvements. Big thanks to David Steinbrunner and Boris Däppen. 0.090 2013-08-23 14:41:34 America/Los_Angeles [CODE CHANGES] - None. [DEPENDENCY CHANGES] - Now requires version 0.010 Package::Locator, which respects your environment variables for user agent proxy settings. This fixes #111. 0.089 2013-08-19 13:03:26 America/Los_Angeles [CODE CHANGES] - None. [DOCUMENTATION CHANGES] - Added Copyright declarations to files in etc/ so the Debian packagers can avoid legal hassles when redistributing this code. - Added an =encoding command to all POD. This should fix whatever caused MetaCPAN to reject the last release of Pinto. (Thanks rwstauner & oalders). - Reformatted this change log to conform to the CPAN::Changes::Spec (Thanks omega). 0.088 2013-08-15 10:49:36 America/Los_Angeles [INCOMPATIBLE CHANGES] - Both the "pull" and "add" commands will no longer fetch development prerequisites by default. If you want to have them, then add the --with-development-prerequisites (or --wd) option. [NEW FEATURES] - The "add" command now has an experimental --no-index option to exclude certain packages from the index. This is useful when Pinto finds packages in your distribution that it should not. Thanks to Todd Chapman for the great suggestion. - The "diff" command now accepts revision IDs as arguments, so you can compare any two arbitrary revisions. Revision IDs can be truncated to uniqueness. This feature was generously funded by a grant from TPF. - The "new" command now accepts a --target-perl-version option to set the target perl version of the new stack. This affects how Pinto decided if a prerequisite is satisfied by the core. If you do not specify the --target-perl-version, then it defaults the global value that is set in the repository configuration file. [ENHANCEMENTS] - Improved the output from the "manual" command. Thanks to Tommy Stanton. - Optimized some queries to make it faster to register packages on a stack. In the best cases, performance has improved by about 150%. But in the average case, the limiting factor is fetching and unpacking the upstream distribution, so you'll only see a slight improvement there. - If your username contains non-alphanumeric characters, they will be stripped out when used as your author identity. This is because the CPAN toolchain requires author ids to be alphanumeric. Thanks to @chiselwright and @cebjyre. - The "statistics" command now accepts a stack name, so you can see the figures for any stack in the respository, not just the default stack. This was a silly omission. I don't know why I left it out. [BUG FIXES] - You can now edit the commit message when pinto is reading input from a file or pipe, as long as STDOUT is connected to a terminal. You can always just use the -m or -M options if you don't want to edit the message. - You can now change only the letter case when renaming a stack, even on case-insensitive filesystems. So you can change "foo" to "FOO". Previously, you had to change the name entirely, and then rename it again to the desired case. [INTERNAL CHANGES] - Pinto no longers stores the file path and SHA digest of every package it sees in the META, since many distributions on CPAN don't have the right paths in there anyway. This allows Pinto to index some (technically broken) distributions that it otherwise couldn't. Pinto was never really using this information anyway, and it will probably be removed from the schema entirely in the next major upgrade cycle. 0.087_05 2013-07-29 23:03:41 America/Los_Angeles 0.087_04 2013-07-26 20:11:14 America/Los_Angeles 0.087_03 2013-07-21 01:16:50 America/Los_Angeles 0.087_02 2013-07-16 02:12:40 America/Los_Angeles 0.087_01 2013-07-09 01:06:47 America/Los_Angeles [DEVELOPER RELEASES] - Changes consolidated above under version 0.088. 0.087 2013-06-19 14:47:01 America/Los_Angeles [INCOMPATIBLE CHANGES] - When pulling, Pinto now takes the first satisfactory package that it finds among the upstream repositories, rather than taking the latest one. This only matters if you specify multiple upstream repositories. To get the old behavior, use the new --cascade option on the "pull" and "add" commands. Thanks @hesco for helping me sort this out. - The "version" command has been removed. Now that all Pinto components ship together, they all have the same version number. So there is no need for a special version command. If you want to know what version of pinto you have, just use the --version option. - Author IDs must now match /^[A-Z]{2}[-A-Z0-9]*$/. In other words, two ASCII letters followed by zero or more ASCII letters, digits, or hyphens. If you use lowercase letters, they will be automatically forced to uppercase for you. This was done because cpanm relies on author IDs following the PAUSE convention. I had hoped that Pinto could be more liberal about author IDs, but it seems we must conform so that we can cooperate with the rest of the toolchain. - The --no-history and --allow-duplicates repository configuration parameters are no longer supported. I had created those so you could try mirroring CPAN with a Pinto repository. But I have decided that use case is out of scope for Pinto. If you realy want a mirror of CPAN, use CPAN::Mini or rsync. [ENHANCEMENTS] - The names of those kind souls who generously helped finance Pinto through the crowdfunding campaing on Crowdtilt are now listed in Pinto::Manual::Thanks. There is also a related Easter egg among the pinto(1) commands -- see if you can find it! See http://tinyurl.com/gopinto to learn more about the campaign. - Pinto::Server (a.k.a. pintod) will abort the action if it looses the connection with the client. So, for example, you can press Ctrl-C in the middle of pulling a long chain of dependencies into a remote repository and the server will immediately stop and roll back the entire transaction. - The progress meter is now visible when using a remote repository. The progress meter is never shown when --verbose or --quiet is set, or when STDERR is not connected to a terminal. - The "init" command now has a --target-perl-version switch that sets the default target_perl_version property for all new stacks. This is handy if you know that all stacks will be targeting a perl that is different from the one you are using to run pinto. [BUG FIXES] - The "install" command can now be used on a locked stack, but only if the --do-pull option is not given. If you want to pull packges while installing, then you must unlock the stack first. Thanks Jeremy Marshal. - The "install" command can now be used on a remote repository that has basic HTTP authentication enabled. Beware that cpanm does not sanitize passwords from its log messages. I'm working with miyagawa to fix that. - Pinto::Server now cleans up child procs. No more zombies! - Cleaned up some extraneous dependencies. - Fixed several typos in the documentation. 0.086 2013-06-18 02:45:38 America/Los_Angeles 0.085 2013-06-18 02:45:38 America/Los_Angeles [BROKEN RELEASES] - Changes re-consolidated above under version 0.087. 0.084_02 2013-06-16 20:54:06 America/Los_Angeles 0.084_01 2013-06-16 00:53:47 America/Los_Angeles [DEVELOPER RELEASES] - Changes consolidated above under version 0.087. 0.084 2013-05-14 17:24:22 America/Los_Angeles [ENHANCEMENTS] - Revised documentation for pintod. [BUG FIXES] - Now requires verison 0.018 of Test::LWP::UserAgent or newer which resolves some test failures in Pinto seen by CPAN Testers using older versions of T::LWP::UA. 0.083 2013-05-13 14:36:21 America/Los_Angeles [ENHANCEMENTS] - Improved password prompting, so it still works when STDIN and/or STDOUT are not connected to a terninal anymore. - Revised and corrected errors in documentation. - The etc/ directory has a sample init.d script (thanks @hesco). 0.082 2013-04-29 09:42:43 America/Los_Angeles - Just minor changes so Pinto will run on perl 5.8.9 0.081 2013-04-26 13:51:32 America/Los_Angeles - Just a minor change in test code to prevent failure occasionaly seen on Unix boxen. 0.080 2013-04-26 10:41:19 America/Los_Angeles [HEADLINES] - Pinto::Server and Pinto::Remote have been merged into this distribution, so everything ships together. It also means both Pinto::Server and Pinto::Remote are now working again. Woot!! There is one caveat: when using a remote repository, pinto will not display the diff and prompt you to edit the commit message. Instead, it will automatically use the default generated message or the message you specified at the command line. I hope to fix this soon. [BUG FIXES] - pinto(1) and pintod(1) will now be installed with a fixed shebang, so that they will always run with the same version of perl, even if you use perlbrew to switch to a differnt perl (thanks @punter) - pinto(1) will now show the progress meter when reading input from a file. The progress meter will be hidden whenever STDERR is not connected to a tty. Use the --verbose or --quiet option to forcibly hide the progress meter. - Pinto now indexes "inner packages" so distributions like mod_perl will be indexed (more) correctly. I had misunderstood how PAUSE worked. Thanks @miyagawa. 0.068 2013-04-04 22:41:55 America/Los_Angeles - Now using Module::Build::CleanInstall, which removes files from the last installation before installing. This should help prevent build failures for those coming from versions prior to 0.066. Thanks to Joel Berger for creating the wonderful M::B::CleanInstall! - Worked around bizzare bug that caused DateTime::TimZone to blow up with a "locate object method" exception on perl 5.14. Root cause has not been determined. 0.067 2013-03-30 00:23:36 America/Los_Angeles - Only minor refactoring. No functional or interface changes. - Explicitly requires Term::ANSIColor 2.02 or later. Thanks CPAN Testers! - Requires Pinto::Common 0.068, so you'll have better documentation. 0.066 2013-03-26 16:18:06 America/Los_Angeles [HEADLINES] - Your MUST uninstall both Pinto and App::Pinto before installing this. - For local repositories, you'll need to have App::Pinto 0.066 or later. - This release is not (yet) compatible with any Pinto::Server. [IMPORTANT] - Bad news: This version of Pinto is not compatible with *existing* repositories. To migrate, you'll need to create a new repository (using this version of Pinto) and then "pull" all the distributons from your old repository into the new one. Repeat this process for each stack. Unfortunatley, you will loose your revision history. If you bug me about it, I'll write a script to automate this for you. I am thaljef@cpan.org. - Good news: This version of Pinto has hooks to do future migrations automatically. So any repository you create with *this version* of Pinto can be easily migrated to any future versions. I'm also pretty confident that the schema is now stable, so a migration will not be required for a while. [CHANGES] - Switched from using Archive::Tar to Archive::Extract. The latter will attempt to use tar(1) to unpack the archive, which works much better with older archives. This is a bit slower however. If you don't have tar(1), it falls back to using Archive::Tar internally. - Switched from using HTTP::UserAgent to HTTP::Tiny. This cuts out one non-core dependency. But some of Pinto's upstream dependencies probably still use HTTP::UserAgent, so the net effect is moot. - The version control subsystem has been completely redesigned. Pinto now stores full snaphots of the stack at each revision and organizes them in a directed graph, much like Git does. Each revision is now identified by a unique non-sequential identifier. - The interface with the terminal has been completely redesigned. You'll see fewer (but hopefully better) diagnostic messages when running in verbose mode. And if not verbose, then you'll see a progress meter. If you still want to see all the gory details, then set the PINTO_DEBUG environment variable. - The logger has been completely removed, so Pinto no longer records diagnostic messages. Recording them never proved to be useful anyway. All the important changes to the stacks are still recorded in the revision log though. - Several Action classes have been added, removed, renamed, or repurposed. The specifics are not described here because the Pinto API is still private. See the change log for App::Pinto for a description of all the public interface changes. 0.065_06 2013-03-23 00:22:57 America/Los_Angeles 0.065_05 2013-03-20 16:21:57 America/Los_Angeles 0.065_04 2013-03-20 16:06:15 America/Los_Angeles 0.065_03 2013-03-19 15:52:24 America/Los_Angeles 0.065_02 2013-03-15 23:39:27 America/Los_Angeles 0.065_01 2013-03-15 16:19:38 America/Los_Angeles [DEVELOPER RELEASES] - Changes consolidated above under version 0.066. 0.065 2012-11-14 09:55:54 America/Los_Angeles [Interface Changes] - In commit messages, all lines starting with '#' are discarded. Previously, we figured out the start and end of the message based on other landmarks, but that isn't very reliable. - Commit timestamps are now reported in the format that is right for your locale. However, they are reported in UTC, not the local timezone. I will fix this in the next release. [New Features] - Commit messages are now parsed into separate title and body sections. The message prompt will advise you to put the title on the first line, followed by one blank line, followed by the body (just like with Git). We make some attempt to be lenient with the parsing, in case you don't follow the suggetion. 0.064 2012-11-12 13:29:50 America/Los_Angeles [New Features] - If running in an interactive environment and the PINTO_PAGER or PAGER environment variable is set, then Action output will be sent to it. Log messages still go to STDERR and will not be sent to the pager. 0.063 2012-11-12 11:58:29 America/Los_Angeles [Important] - This version of Pinto is not compatible with repositories that were created with prior versions. Please contact thaljef@cpan.org if you need to migrate an old repository. [New Features] - Now has a Rename action, to change the name of an existing stack. You'll need a newer App::Pinto to utilize this action (Schwern). [Bug Fixes] - The Delete action actually works now (Schwern, Holybit). 0.062 2012-11-08 10:52:02 America/Los_Angeles [Interface Changes] - If the commit message for a Committable action is empty (but defined) then we automatically fall back to using the default message. [Interal API Changes] - Actions that take a stack name argument can now accept a stack object as well. - Pinto::Util has been moved from this distribution to Pinto-Common. 0.061 2012-10-30 17:19:10 America/Los_Angeles [Interal Changes] - Some query optimizations, to benefit alpha.stratopan.com - Stack and Revision objects are now sortable. In string context, Stacks sort by name. In numeric context, they sort by Revision. Revisions sort chronologically. 0.060 2012-10-23 10:57:41 America/Los_Angeles [New Features] - You can now set the default stack at the same time that you create or copy a stack. [Other Changes] - The output of the Blame action now has the familiar format of the List action, and records are sorted by package name. 0.059 2012-10-20 00:52:34 America/Los_Angeles [Important] This version of Pinto is not compatible with repositories that were created with prior versions. Please contact thaljef@cpan.org if you need to migrate an old repository. [Interface Changes] - Stack names and property names are no longer forced to lowercase. Instead, we preserve the original case when they are created. But subsequent comparisons or lookups are done irrespective of case. - Author IDs are no longer forced to uppercase. However, the author ID in the canonical path for any distribution that you add will always be uppercase, which is consistent with PAUSE. When listing distributions/packages for a certain author, the comparison is done irrespective of case. [Other Changes] - Made several schema optimizations to help support Stratopan, the upcoming cloud-based service built on Pinto. For a preview, check out http://alpha.stratopan.com 0.058 2012-10-11 22:47:23 America/Los_Angeles [New Features] - Added the Blame action, which reports who last modified each package in the stack. You'll need App::Pinto-0.052 to utilize this action. [Bug Fixes] - When pulling prereqs, Pinto would pull the latest version of the package across the entire repository, rather than taking the version that is already on the stack. If the package that is on the stack does not exist or is too old, *then* you get the latest version in the repository. And if that does not exist or is too old, *then* we get the latest version from an upstream repository. 0.057 2012-10-07 12:28:37 America/Los_Angeles - The Pull action will ignore requests for packages that are in the Perl core, unless you explicitly request a version of the package that is newer than the core. - Removed stray dependency on Pinto::Store::File. That module has been deprecated and no longer ships with Pinto (holybit). 0.056 2012-09-27 13:40:56 America/Los_Angeles [Important] This version of Pinto is not compatible with repositories that were created with prior versions. Please contact thaljef@cpan.org if you need to migrate an old repository. [New Features] - Added the Replace action, which substitues one dist for another on all stacks. You'll need to upgrade App::Pinto to get the corresponding 'replace' command. [Other Changes] - Significantly improved performance, especially for large repositories. Pinto can now hold the *entire* CPAN (not just the tip) and still perform reasonably well. - Changed the way prereqs are discovered. We now trust the dist's own META to tell us the prereqs, rather than configuring the dist directly. This is much faster and usually just as accurate. The only casualties are old dists that don't have a META file, or ones that compute prereqs dynamically during configuration. So it ain't perfect, but it is probably good enough. [Bug Fixes] - Pinto can now cope with distributions that contain no packages. These are relatively rare but they do exist on CPAN, usualy in the form of distributions that contain only scripts. 0.055 2012-09-20 13:33:57 America/Los_Angeles [Interface Changes] - For the List action, the magic stack name is now '%' instead of '@'. This was changed to distinguish it from revision strings that look like stack@1234. - The username attribute is now attached to the Config, not the Action. This makes it available to any object that needs it (particularly when creating a Revision). 0.054 2012-09-19 22:02:57 America/Los_Angeles - Added a workaround so Pinto can cope with the nonsensical common::sense module. 0.053 2012-09-19 20:58:46 America/Los_Angeles [Bug Fixes] - For all committable actions, a commit message is required only if the action actually changed the state of the repository. A commit message is never required for a dryrun action. [Other Changes] - Requires DBIx::Class-0.08200 or newer. In certain earlier versions, prefetching was broken. * The Install action is now committable, but it only matters when it is also pulling packages. 0.052 2012-09-18 16:15:38 America/Los_Angeles [Important] This version of Pinto is not compatible with repositories that were created with prior versions. The way that archives and indexes are stored on the filesystem has been made simpler and faster. If using Pinto::Server, you'll need to upgrade that too. Contact thaljef@cpan.org if you need a migration path for an existing repository. [New Features] - Now supports a Revert action, which restores the stack to a prior revision. This is light-weight form of version control. - Now supports a Log action, which displays the history of changes to a stack. - Each action that changes the state of the repository now requires a commit message. You can pass this into the API, or it will prompt for one via your editor. [Other Changes] - The Index action is no longer supported. Now that each stack has its own index file, I see no need to have this Action. - Orphaned archives are now automatically cleaned whenever you do an Add or Pull action with dryrun enabled. - Now requires Dist-Requires-0.008, which fixes some test failures on some platforms. 0.051 2012-08-15 18:27:34 America/Los_Angeles - More hacking to workaround the broken prefetch feature in DBIx::Class. May result is slightly slower performance now that we have to make more trips to the database. - Added the Clean action to remove orphaned archives from the filesystem. The Pull and Add actions now automatically clean up if doing a dryrun. 0.050 2012-08-15 14:26:13 America/Los_Angeles - I've worked around the bug that required you to use a development version of DBIx::Class (see previous release notes below). So now you don't have to manually install anything. 0.048 2012-08-15 09:05:19 America/Los_Angeles - Prefetch is broken in DBIx::Class-0.08198 (see RT #78456) so Pinto now requires DBIx::Class-0.08198_01 or later. At the moment, this is only available as a dev release, so you may have to install it manually before building Pinto. For example: $ cpan JROBINSON/DBIx-Class-0.08198_01.tar.gz 0.047 2012-08-13 17:21:03 America/Los_Angeles - Added a hook for controling the lockfile timeout via an environment variable. This makes testing for Pinto::Server and Pinto::Remote faster. 0.046 2012-08-13 15:17:18 America/Los_Angeles [Important] - Removed workaround for bug that appeared in DBIx::Class-0.08198. We now require DBIx-Class-0.08198_01, which is only a developer release at the moment. So you may have to fetch that dependency manually. [Bug Fixes] - Partially resolved #14, where Pinto would blow up if you asked it to pull a core-only package. In this case, it really should give you a warning. But for now, it just silently skips it. [Other Changes] - Pinto::Tester now constructs the repository on disk immediately upon constructing the object. Before, you had to access the pinto attribute to trigger it to write anything to disk. 0.045 2012-07-23 23:14:42 America/Los_Angeles [Bug Fixes] - Tests were failing with the latest version of DBIx::Class. I think the root cause is in DBIx::Class itself (see RT #78456) but until that is resolved, I've done a workaround. 0.044 2012-07-15 01:39:18 America/Los_Angeles [Bug Fixes] - The magic stack named '@' (meaning all stacks) did not work. 0.043 2012-06-19 10:47:15 America/Los_Angeles [Bug Fixes] - Prevent writing to closed handle, when running the install action via pinto remotely. - Now requires Dist::Metadata 0.923 or newer, which indexes more like PAUSE does it. [Other Stuff] - Some minor performance optimizations, to reduce the number of trips to the database. 0.042 2012-05-17 21:55:19 America/Los_Angeles - finally{...} doesn't seem to work properly on older perls, and this caused several test failures. According to the perldelta, 5.14 introduced several changes to exception handling. So I've moved the exception handling into the catch{...} block. I don't know why, but this seems to work better. 0.041 2012-05-15 11:13:27 America/Los_Angeles [Important] - There have been major changes to the interface and behavior of Pinto (read more below). Beware this version of Pinto is NOT compatible with repositories created with any previous version of Pinto. If you have an existing repository and you really, really need to preserve it, then contact me and I can work with you to develop a migration plan. Also, many of the internal modules have been moved around, so I strongly suggest that you remove existing versions of all the Pinto libraries and scripts before installing a new one on top of it. [New/Changed/Removed Features] - Pinto now supports multiple indexes called "stacks". So you could have one stack of dependencies for application X and a different stack for application Y (or one for development, one for production, etc). Each stack can contain different modules and/or different versions of those modules. It's like having several repositories in one. - Stacks can be copied and merged, much like a version control system. This allows you to experiment with new dependencies without impacting other stacks. If you have multiple applications with different dependencies (or just different versions of them), this also gives you a way to gradually converge dependencies. Likewise, it allows you to fork dependencies if two applications need to diverge in some way. - The VCS integration has been removed. Most of the people I've talked with did not find this feature particularly useful, since you can't really branch & merge a repository (the database is binary). This was also the most rickety part of the system. - The "pinto-admin" and "pinto-remote" applications have been consolidated into one application called "pinto". It will use the appropriate backend (either Pinto or Pinto::Remote) depending on whether the repository root is a local directory or a remote URL. However the backends ship separately from the application, so you must choose which to install (or you can choose both). - The pinto application also has an "install" command, which functions as a stand-in for cpanm. It is wired to pull distributions only from your repository, using the stack of your choice. - Pinto no longer supports mirroring CPAN. I've found that it is difficult to manage application dependencies in the context of an entire mirror of CPAN. Most people only care about the stuff their application needs, so they don't really need a snapshot of the entire CPAN. If you really want that, then CPAN::Mini does a fine job. - Pinto no longer allows you to remove archives from the repository, so the "clean", "purge", and "remove" commands are gone. Eventually, my goal is to make Pinto behave just like a VCS, where nothing is really deleted and you can always revert back to a previous version. So you'll be able to take a distribution off of a stack, but the .tar.gz file never really goes away. - Pinto no longer enforces any sort of permissions on package namespaces. Previously, Pinto only allowed the original author to update a package (just as PAUSE does). But the restriction was only advisory -- you could just bypass it by changing your author identity. Now, Pinto doesn't even bother with that -- any user can upgrade any package. All the activity is logged to a file so you can see who changed what, but Pinto expects you to be accountable for your actions. - Pinto now tracks dependencies between the distributions within the repository. So it can potentially tell you which distributions need to be tested after upgrading a module, or whether the stack actually contains sufficient modules to satisfy all the prerequisites for all the distributions in the stack. I haven't yet written those commands, but the data is in there. 0.040_003 2012-05-04 21:38:07 America/Los_Angeles - Fixed bug in 35-install.t that would cause the test to fail (instead of skipping) if cpanm was not installed. Thanks Andreas! - Switched to using File::NFSLock instead of Lockfile::Simple. The latter uses some deprecated syntax that causes lots of ugly warnings on newer perls. - Still alpha testing. 0.040_002 2012-05-04 16:19:11 America/Los_Angeles - Added Action::Install. Still alpha testing. 0.040_001 2012-05-01 13:12:34 America/Los_Angeles - This is a developer release for alpha testing the stacks feature. 0.038 2012-04-16 18:14:57 America/Los_Angeles [New Features] - The "import" command will now import a particular distribution if you specify it using the right notation. See POD for details (Steven Leung). [Bug Fixes] - The Git store would fail if you specified the --root as a relative path that contained any "../" updirs (William Wolf). 0.037 2012-04-10 19:57:09 America/Los_Angeles - No code changes. Just fixed dependency declarations. Thanks CPAN Testers! 0.036 2012-04-09 00:14:50 America/Los_Angeles [New Features] - Pinto now logs activity to $root_dir/.pinto/logs/pinto.log (Karen Etheridge). You can set the logging level in the repository's config file. [Other Stuff] - A lot of files have been moved around in this release (and the last couple releases). I suggest removing your current Pinto before installing this one, to avoid accumulating cruft. 0.035 2012-04-04 19:00:35 America/Los_Angeles [New Features] - The value for the --author option now defaults to the 'user' specified in your ~/.pause file. If that file does not exist, then it still defaults to your current login username. [Other Changes] - All diagnostic messages from pinto-admin now go to STDERR rather than STDOUT. So you can cleanly directy the output into a file (like with the `list` command). - Refactored a lot of redundant code into roles that are shared with Pinto::Remote. But if you're not looking at the Pinto internals, you won't notice it. 0.033 2012-03-15 06:55:39 America/Los_Angeles [Bug Fixes] - Corrected documentation about the environment variable controlling the default location of the repository. Thanks fibo. - The index file is now properly updated after doing an import operation. Thanks throughnothing. 0.032 2012-03-01 10:36:25 America/Los_Angeles [Bug Fixes] - Worked around a problem that caused the PAUSE indexer to reject the last release. - Added an accurate line-count to the 02packages file so that cpan(1) doesn't complain about it. 0.031 2012-02-28 05:19:58 America/Los_Angeles [Bug Fixes] - Fixed bug in the create command. Not sure how this ever worked before. [New Features] - The "add" command now recursively imports all the dependencies by default. To disable this behavior use the --norecurse option. 0.030 2012-01-26 22:00:32 America/Los_Angeles - The --repos option for pinto-admin has been officially renamed to --root. This was done to create a symmetrical API between Pinto and Pinto::Admin. The old --repos option will *not* be supported for backward compatibility. 0.029 2011-12-15 00:24:11 America/Los_Angeles - The 'list' command now has --index and --noindex options to filter the output to packages that are in the index, or not in the index, respectively. - The 'list' command now has --pinned and --nopinned options to filter the output to packages that are pinned, or not pinned, respectively. - The default output format for the 'list' command now includes a '+' character to indicate whether a package is pinned. - Some improvements to Pinto::Store::VCS::Git, which allow you to place your Pinto repository anywhere inside a Git repository. 0.028 2011-12-12 01:22:02 America/Los_Angeles - I discovered that Subversion 1.7 changed the working copy layout in a way that caused Pinto to run exponentially slower as the repository got bigger (like when mirroring the CPAN). I've fixed this now. - pinto-admin now has a 'statistics' command that will report some basic stats about your repository. I plan to add more stats in the future. - You can now store your repository with Git using either Pinto::Store::VCS::Git or Pinto::Store::VCS::Git::Remote. These are both experimental, so use with caution. - Mirror actions are now a bit faster, espeically when you already have most of the distributions in the source repository. - The VCS log message used for the commit is now also used as the message for the tag operation. - Pinning a devel package is only allowed if this repository is configured to index devel packages. 0.027 2011-12-08 15:23:00 America/Los_Angeles - The 'list' command now has options to filter the output to either packages or distributions that contain some substring. This is not as powerful as a regex, and you can only filter on the package name or dist path. But this will make things go much faster. - Fixed numerous bugs in the VCS integration. This was totally broken. That's what I get for not writing regression tests in that area. - Fixed compatibility issue with Pinto::Remote. - Added or improved some log messages. - Revised some documentation. 0.026 2011-12-07 11:47:27 America/Los_Angeles =============================================================== IMPORTANT: This version of Pinto is not compatible with repositories built with any prior version. In theory, you can migrate your old repository with the right combination of pinto-admin and VCS commands. If you really want to try migrating your old repository, please contact me for guidance. Otherwise, you'll have to create a new repository and 'add' each of your local distributions again. If you have foreign distributions in your repository then you'll have to 'mirror' them again too, but you might not get exactly the same versions that you used to have (because they are no longer the 'latest' version on CPAN). I know this sucks, but it is definitely worth the upgrade. This version of Pinto is faster, more reliable, and packed with new features. And going forward, I'll be able to maintain backward compatibility or at least provide an automated migration path. ================================================================ * New Features: Pinto now uses a SQLite database to store information. This improves performance, reduces memory consumption, and ensures data integrity. Pinto is single threaded and permits only one database connection at a time, so it is safe for NFS (or so I've been told by SQLite experts). Pinto now behaves more like PAUSE, and will accept distributions with overlapping packages. As always, only the 'latest' version of a package appears in the index file. And just like PAUSE, Pinto tries to figure out the lineage of packages (i.e. which version came first, second, third, etc.) by looking at version numbers and file timestamps. So you can throw a pile of archives at it without having to think about putting them in a certain order (See POD for details). You can also remove a distribution, and the "prior" versions of its packages will automatically become the latest. A Pinto repository can now be used with the cpan[1] utility. It should also work with cpanp[1], but I haven't tried it. And of course it still works with cpanm[1]. However, Pinto does not provide a full 01mailrc.txt.gz or 03modlist.data.gz file. So cpan[1] features that rely on those files may not work. Pinto can now pull foreign distributions from multiple repositories. You can use this to fall back to another repository if one of them is offline (which sometimes happens with CPAN mirrors). Or you can use this to create a network of repositories that may each have different sets of distributions. I'm not sure if this is actually a good idea, but we'll see. Pinto does the-right-thing with development distributions (See POD for details). And each Pinto repository now has a 'devel' configuration parameter. Setting this to a true value instructs Pinto to include development releases in the index. The default is false. The 'create' command for pinto-admin now accepts options that set the parameters in the config file that is generated for the new repository. The 'list' command for pinto-admin now accepts a --format option that can be used to customize what/how information is displayed. The 'remove' command for pinto-admin now works for both foreign and local distributions. However, there is a caveat when removing foreign distributions (See POD for details). The 'rebuild' command for pinto-admin now has a --recompute option that causes Pinto to recompute the 'latest' version of all the packages (See POD for details). pinto-admin now has a 'manual' command for displaying the full manual for a particular command. pinto-admin now has a 'version' command for displaying version information. pinto-admin now has a 'purge' command that removes everything from your repository. pinto-admin now has an experimental 'import' command that fetches a remote package or distribution (and its dependencies, recursively) and puts all of them in your local repository. pinto-admin now has the 'pin' and 'unpin' commands, which can be used to tie the index file to a specific version of a package. This lets you evolve your repository while keeping certain packages fixed. Very cool! See POD for details. Most of the pinto-admin commands now have aliases. Thanks to the awesomeness of App::Cmd, you can say 'pinto-admin rm' instead of 'pinto-admin remove'. The aliases are listed in the manual for each command. * Other Changes: The config files for each Pinto repsoitory are now located in $REPOS/.pinto/config. The 'list' command for pinto-admin has been neutered. You can no longer specify the --type or --indexed options. However, the output does show whether the package is local/foreign and indexed/unindexed, so you can grep on that to narrow the results. I'm thinking of developing a query interface to let you select which packages/distributions you want to list. The VCS tagging mechanism has changed. Instead of making a tag for every commit, a tag is made only when you specify the --tag option. You can still put date/time placeholders in your tag name. The 'noclobber' configuration setting has been removed, since it was never implemented anyway. The 'nocleanup' configuration setting is gone, and we no longer support automatic cleanup. Instead, you have to run the 'clean' action separately. You might want to setup a cron job for this. The 'update' command is now called 'mirror'. I know, I keep flip-flopping on that. But I think I've finally settled now. The --force option on the 'mirror' (formerly 'update') command is no longer supported. I'm thinking of changing the meaning of "force" and might bring it back in a future release. pinto-admin is a little less noisy by default. You can increase the verbosity by repeating the '-v' option up to three times. Now needs newer versions of Dist::Requires and Dist::Metadata. Thanks CPAN Testers for shaking that out. Pinto->new() will now blow up if you specify a root_dir that doesn't actually look like a repository directory. To be valid, it must have a database file, a modules directory, and an authors directory. Changed some log messages to be more helpful and/or less noisy. * Bug Fixes: Fixed bug where Pinto might blow up with 'too many args' error the first time you update from a CPAN mirror using the Svn store. Fixed broken code (e.g. calling undefined methods) in several places. Added more regression testing to catch this stuff. Prevent uninitialized warning when using the 'list' command. 0.025_004 2011-12-06 21:11:00 America/Los_Angeles 0.025_003 2011-12-03 04:12:56 America/Los_Angeles 0.025_002 2011-12-02 04:39:19 America/Los_Angeles 0.025_001 2011-12-02 03:18:26 America/Los_Angeles Net changes aggregated above in 0.026 0.024 2011-09-01 15:23:48 America/Los_Angeles Added a "version" command to pinto-admin General code refactoring No interface changes 0.023 2011-08-31 14:18:49 America/Los_Angeles * Interface Changes: The "remove" operation now works on distribution names, rather than package names. You must specify the full name of the distribution, including version number and extension. * Other Good Stuff: Wrote the manuals for each of the pinto-admin commands. Say `pinto-admin COMMAND --man` to see them. 0.022 2011-08-31 01:31:04 America/Los_Angeles * Interface Changes: You no longer need to specify the Subversion trunk in your pinto.ini (if you were using Pinto::Store::VCS::Svn). The location of your Pinto repository in subversion is implicit in the `svn info` of the working copy. Secondly, the "create" action no longer takes care of making a location in Subversion for you. So you now have to do a little more work to setup Pinto with Subversion. See the POD in Pinto::Store::VCS::Svn for step-by-step instructions. You can no longer specify a VCS tag in your pinto.ini. Making a tag after every commit doesn't make sense. So now, a tag is only made if you explicitly set a --tag on the command line. Likewise, the --notag command line switch has been removed, since the absence of a --tag is equivalent to --notag. * Bug Fixes: The "update" command was broken, following rename from "mirror". Doh! 0.021 2011-08-30 01:16:55 America/Los_Angeles * Interface Changes: The "mirror" command is now called "update". I feel this more accurately reflects what is going on, since a Pinto repository isn't really a "mirror" of anything. * Bug Fixes: Fixed some bugs in the VCS tagging logic. Fixed behavior when running under cron. 0.020 2011-08-28 20:40:43 America/Los_Angeles * Enhancements: Added the "rebuild" command, which reconstructs the master index from the current local and mirrored indexes. This is useful if your master index somehow gets screwed. Note this is not the same as actually re-indexing the distributions (that's a feature I might add later). All commands for pinto-admin[1] now support a --man option, which shows you the full documentation for a command. But at this point, I haven't written the documentation for all the commands. Several of the commands for pinto-admin[1] now support a --tag option that allows you to specify an alternative tag. The semantics of the tag will depend on which type of VCS you are using. Likewise, you can now specify --notag to disable tagging completely. 0.019 2011-08-24 04:09:41 America/Los_Angeles * Bug Fixes: The 'add' and 'remove' commands for pinto-admin were not reading arguments from STDIN properly. All svn commands would fail when running under pinto-server. This was due to some strage behavior in IPC::Run that I can't explain. 0.018 2011-08-24 01:45:21 America/Los_Angeles Now using IPC::Run to handle external commands (like svn). IPC::Run seems to behave better when running in a server environment like pinto-server (via Dancer). 0.017 2011-08-24 00:50:09 America/Los_Angeles * Interface Changes: pinto-admin[1] is now zero-conf (at least, by default). However, you must now specify the --repos for every command. Also, some of the options for pinto-admin have been removed for safety, and are now in the repository-specific configuration file (see below). This helps to deter you from doing things that contradict the usual behavior of your repository. Each Pinto repository now has its own configuration file, which governs its basic behavior. The configuration file is generated with default values when you run the "create" command. This allows you set up multiple repositories, each with a different behavior and VCS store. * Enhancements: The "add" and "remove" commands for pinto-admin[1] can now read arguments from STDIN. When doing so, it filters out things that look like comments and blank lines. This makes it easy to pipe in the output from a find[1] or dzil[1] command. You can also specify arguments to the "add" command as URLs, and Pinto will fetch them for you. (Suggested by Tim Bunce). The "list" command now accepts a --type option, which will show you either all packages, only local packages, only foreign packages, or only local packages that block a foreign package. (suggested by George Hartzell and Meg Green). The "add", "remove", and "mirror" actions now accept a --message option, which will be prepended to the VCS commit log that Pinto generates (suggested by Jan Vogel). Added "nocolor" command line option. 0.016 2011-08-18 02:00:12 America/Los_Angeles Removed bin/pinto-client. That wasn't supposed to be in there, damnit! Look for the Pinto-Remote distribution instead. 0.015 2011-08-18 01:54:39 America/Los_Angeles * No interface changes or bug fixes. * Internal Changes: Improved exception handling. Pinto now uses a lock file to synchronize concurrent actions in the repository. Only one actor is allowed to operate in a given repository at a time. Others have to wait until they can get the lock, or timeout after about 60 seconds. 0.014 2011-08-17 16:09:48 America/Los_Angeles * No interface changes or bug fixes. * Internal Changes: Several modules have been moved out to the Pinto-Common distribution. This is to allow sharing between Pinto, Pinto::Server, and Pinto::Remote without requiring direct dependency on all of Pinto (including it's dependencies). 0.012 2011-08-17 09:10:25 America/Los_Angeles * Bug Fixes: Pinto::TestLogger didn't end with a true value. Thank you, CPAN Testers! * Internal Changes: Switched from IPC::Cmd to Proc::Reliable for running shell commands. IPC::Cmd seems to do funky things with STDIN and STDOUT that don't set well with CGI. You can specify an output filehandle or a buffer (as a scalar reference) where you want the output from Pinto::list() to go. The output from the List action contains the name, version, and location in each package, rather than just the name. This was a regression in the last version. * Other Changes: pinto-server[1], pinto-client[1], and all the Pinto::Server::* modules have been pulled out into a separate distribtuion, which will be released to CPAN shortly. 0.011 2011-08-14 21:11:47 America/Los_Angeles * Bug Fixes: Fixed our call to File::Copy::copy() to accommodate older versions which did not handle Path::Class objects properly. Thank you, CPAN Testers! 0.010 2011-08-14 13:29:23 America/Los_Angeles * Bug Fixes: Fixed test failures that I introduced by renaming some classes in the last release. 0.009 2011-08-12 17:50:28 America/Los_Angeles * Interface changes: pinto[1] is now called pinto-admin[1]. It still has all the same options and arguments. Likewise, App::Pinto is now App::Pinto::Admin. With pinto-admin, the "mirror" parameter is now called "source". This reflects the fact that your dists don't necessarily have to come from a CPAN mirror. They just have to come from some place that conforms to the CPAN structure. Do not confuse this with the "mirror" command, which still does actually mirror the aforementioned "source". * Other changes: Revised documentation. Added some basic functional tests. Created pinto-server and pinto-client, for using Pinto across a nework. These are still very experimental. Once again, a lot of the internals have been rewritten. But the guts of Pinto are all private (for now), so you shouldn't really care. 0.008 2011-08-09 14:47:02 America/Los_Angeles * Interface changes: The 'author' parameter is now entirely optional. It defaults to your shell username, if we can figure that out. If not, then an exception is thrown, and you'll have to set the 'author' parameter explicitly. pinto[1] now has --notag, --nocommit, and --noinit options. All these can also be set in your configuration file. See the pinto[1] documentation for details. * Other changes: The internals of Pinto have been substantially rewritten to improve performance and readability of the code. The Pinto API is still considered alpha, and subject to change. 0.007 2011-08-04 08:04:27 America/Los_Angeles * Interface Changes: A config file for pinto[1] is no longer mandatory. If you do not have one, then you'll have to specify all required parameters on the command line (this is usually just the '--local' and sometimes the '--author' options). If you don't specify these, you'll get a really ugly stack trace from Moose. I'll look into making these error messages prettier in a future release. Thanks to b.jakubski for suggesting this change. * Bug Fixes: RT #70015: Can't create repository. The 'create' command failed because the 02packages file could not be read. This has now been remedied. * Other Changes: Edited documenation for pinto[1] 0.006 2011-08-04 00:52:22 America/Los_Angeles More documentation edits. No code changes. 0.005 2011-08-04 00:43:34 America/Los_Angeles Brought the documentation for pinto[1] up to date with the actual API. 0.004 2011-08-04 00:23:23 America/Los_Angeles Default log level is now 1 (info). pinto[1] now exits with status 0 if successful. Improved some log messages. 0.003 2011-08-03 22:59:10 America/Los_Angeles Major overhaul of internals. But the pinto[1] command line interface is mostly the same. 0.002 2011-07-26 17:20:46 America/Los_Angeles Corrected default path to the Pinto configuration file. Expanded POD for pinto[1] 0.001 2011-07-26 14:17:06 America/Los_Angeles Initial release. Pinto-0.14/dist.ini000644 000766 000024 00000011575 13141540305 014256 0ustar00jeffstaff000000 000000 name = Pinto author = Jeffrey Ryan Thalhammer copyright_holder = Jeffrey Ryan Thalhammer copyright_year = 2015 license = Perl_5 main_module = lib/Pinto.pm version = 0.14 [GatherDir] ; everything under top dir [PruneCruft] ; default stuff to skip [ManifestSkip] ; if -f MANIFEST.SKIP, skip those too ; file modifications [OurPkgVersion] ; add $VERSION = ... to all files [PodWeaver] ; generate Pod ; generated files [License] ; boilerplate license [ReadmeFromPod] ; from Pod (runs after PodWeaver) [ReadmeAnyFromPod / ReadmePodInRoot] type = markdown filename = README.md location = root ; t tests [Test::Compile] ; make sure .pm files all compile fake_home = 1 ; fakes $ENV{HOME} just in case [Test::ReportPrereqs] include = DBIx::Class include = DBD::SQLite ; xt tests [MetaTests] ; xt/release/meta-yaml.t [PodSyntaxTests] ; xt/release/pod-syntax.t [Test::Version] ; xt/release/test-version.t ; metadata [AutoPrereqs] ; find prereqs from code skip = TestClass skip = Pinto::Tester skip = Pinto::Tester::Util skip = Pinto::Server::Tester [Prereqs / TestRequires] Test::More = 0.96 ; for done_testing() Module::Faker::Dist = 0.014 ; works on old perls Apache::Htpasswd = 0 [Prereqs / RuntimeRequires] ; prereqs that aren't findable DBD::SQLite = 1.33 ; not use`d directly DBIx::Class = 0.08200 ; prefetch is fixed App::Cmd = 0.323 ; built-in "version" command Archive::Tar = 0 ; in case they don't have tar(1) Archive::Extract = 0.68 ; older versions generated some suprrious warnings Dist::Metadata = 0.926 ; ignores t, xt, inc, and local dirs JSON::PP = 2.27103 ; wanted by Parse::CPAN::Meta Module::CoreList = 5.20170720 ; latest perl is 5.27.2 Module::Metadata = 1.000031 ; for rt #85961 Throwable::Error = 0.200005 ; fixed memory leak MooseX::ClassAttribute = 0.27 ; compatible with new Moose Authen::Simple::Passwd = 0 ; default authentication backend Starman = 0.3014 ; the default server backend Plack = 1.0028 ; detect disconnects better Term::ANSIColor = 2.02 ; for colorvalid() URI::Escape = 3.31 ; regex warning on 5.22 fixed Variable::Magic = 0.57 ; required for 5.22 ; author prereqs (magic comments) ; authordep Pod::Weaver::Plugin::StopWords ; authordep Pod::Weaver::Plugin::Encoding ; authordep Pod::Weaver::Section::Support ; authordep Pod::Weaver::Section::Contributors [MinimumPerl] ; determine minimum perl version [MetaNoIndex] ; sets 'no_index' in META directory = t directory = xt directory = etc directory = t/lib directory = examples directory = corpus [MetaResources] homepage = https://metacpan.org/module/Pinto bugtracker.web = https://github.com/thaljef/Pinto/issues repository.web = https://github.com/thaljef/Pinto repository.url = git://github.com/thaljef/Pinto.git repository.type = git [MetaProvides::Package] ; add 'provides' to META files meta_noindex = 1 ; respect prior no_index directives [MetaYAML] ; generate META.yml (v1.4) [MetaJSON] ; generate META.json (v2) [Git::Contributors] ; build system [ExecDir] ; include 'bin/*' as executables [ShareDir] ; include 'share/' for File::ShareDir [MakeMaker] ; create Makefile.PL eumm_version = 6.64 ; for test_requires ; manifest (after all generated files) [Manifest] ; create MANIFEST ; before release [Git::Check] ; ensure all files checked in [CheckPrereqsIndexed] ; ensure prereqs are on CPAN [CheckChangesHasContent] ; ensure Changes has been updated [CheckExtraTests] ; ensure xt/ tests pass [TestRelease] ; ensure t/ tests pass [ConfirmRelease] ; prompt before uploading ; releaser [UploadToCPAN] ; uploads to CPAN ; after release [Git::Commit / Commit_Dirty_Files] ; commit Changes (as released) [Git::Tag] ; tag repo with custom tag tag_format = release-%v ; NextRelease acts *during* pre-release to write $VERSION and ; timestamp to Changes and *after* release to add a new {{$NEXT}} ; section, so to act at the right time after release, it must actually ; come after Commit_Dirty_Files but before Commit_Changes in the ; dist.ini. It will still act during pre-release as usual [NextRelease] [Git::Commit / Commit_Changes] ; commit Changes (for new dev) [Git::Push] ; push repo to remote push_to = origin Pinto-0.14/etc/000755 000766 000024 00000000000 13141540305 013354 5ustar00jeffstaff000000 000000 Pinto-0.14/lib/000755 000766 000024 00000000000 13141540305 013347 5ustar00jeffstaff000000 000000 Pinto-0.14/LICENSE000644 000766 000024 00000043716 13141540305 013621 0ustar00jeffstaff000000 000000 This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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) 2015 by Jeffrey Ryan Thalhammer. 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. Copyright (C) 19yy 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. , 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) 2015 by Jeffrey Ryan Thalhammer. 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 MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End Pinto-0.14/Makefile.PL000644 000766 000024 00000015710 13141540305 014557 0ustar00jeffstaff000000 000000 # This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v6.010. use strict; use warnings; use 5.008; use ExtUtils::MakeMaker 6.64; my %WriteMakefileArgs = ( "ABSTRACT" => "Curate a repository of Perl modules", "AUTHOR" => "Jeffrey Ryan Thalhammer ", "CONFIGURE_REQUIRES" => { "ExtUtils::MakeMaker" => "6.64" }, "DISTNAME" => "Pinto", "EXE_FILES" => [ "bin/pinto", "bin/pintod" ], "LICENSE" => "perl", "MIN_PERL_VERSION" => "5.008", "NAME" => "Pinto", "PREREQ_PM" => { "App::Cmd" => "0.323", "App::Cmd::Command::help" => 0, "App::Cmd::Setup" => 0, "Archive::Extract" => "0.68", "Archive::Tar" => 0, "Authen::Simple::Passwd" => 0, "CPAN::Checksums" => 0, "CPAN::DistnameInfo" => 0, "CPAN::Meta" => 0, "CPAN::Meta::Requirements" => 0, "Carp" => 0, "Class::Load" => 0, "Cwd" => 0, "Cwd::Guard" => 0, "DBD::SQLite" => "1.33", "DBIx::Class" => "0.08200", "DBIx::Class::Core" => 0, "DBIx::Class::ResultSet" => 0, "DBIx::Class::Schema" => 0, "DateTime" => 0, "DateTime::TimeZone" => 0, "DateTime::TimeZone::Local::Unix" => 0, "DateTime::TimeZone::OffsetOnly" => 0, "Devel::StackTrace" => 0, "Digest::MD5" => 0, "Digest::SHA" => 0, "Dist::Metadata" => "0.926", "Encode" => 0, "Exporter" => 0, "File::Copy" => 0, "File::Find" => 0, "File::HomeDir" => 0, "File::NFSLock" => 0, "File::Spec" => 0, "File::Temp" => 0, "File::Which" => 0, "Getopt::Long" => 0, "HTTP::Date" => 0, "HTTP::Request::Common" => 0, "HTTP::Status" => 0, "IO::File" => 0, "IO::Handle" => 0, "IO::Interactive" => 0, "IO::Pipe" => 0, "IO::Prompt" => 0, "IO::Select" => 0, "IO::String" => 0, "IO::Zlib" => 0, "JSON" => 0, "JSON::PP" => "2.27103", "LWP::UserAgent" => 0, "List::MoreUtils" => 0, "List::Util" => 0, "Module::CoreList" => "5.20170720", "Module::Metadata" => "1.000031", "Moose" => 0, "Moose::Role" => 0, "MooseX::Aliases" => 0, "MooseX::ClassAttribute" => "0.27", "MooseX::Configuration" => 0, "MooseX::MarkAsMethods" => 0, "MooseX::NonMoose" => 0, "MooseX::SetOnce" => 0, "MooseX::StrictConstructor" => 0, "MooseX::Types" => 0, "MooseX::Types::Moose" => 0, "Path::Class" => 0, "Path::Class::Dir" => 0, "Path::Class::File" => 0, "Plack" => "1.0028", "Plack::MIME" => 0, "Plack::Middleware::Auth::Basic" => 0, "Plack::Request" => 0, "Plack::Response" => 0, "Plack::Runner" => 0, "Pod::Usage" => 0, "Proc::Fork" => 0, "Proc::Terminator" => 0, "Readonly" => 0, "Router::Simple" => 0, "Scalar::Util" => 0, "Starman" => "0.3014", "String::Format" => 0, "Term::ANSIColor" => "2.02", "Throwable::Error" => "0.200005", "Try::Tiny" => 0, "URI" => 0, "URI::Escape" => "3.31", "URI::file" => 0, "UUID::Tiny" => 0, "Variable::Magic" => "0.57", "base" => 0, "overload" => 0, "strict" => 0, "utf8" => 0, "version" => 0, "warnings" => 0 }, "TEST_REQUIRES" => { "Apache::Htpasswd" => 0, "Capture::Tiny" => 0, "ExtUtils::MakeMaker" => 0, "File::Spec" => 0, "File::Temp" => 0, "FindBin" => 0, "HTTP::Body" => 0, "HTTP::Response" => 0, "HTTP::Server::PSGI" => 0, "IO::Handle" => 0, "IPC::Open3" => 0, "Module::Faker::Dist" => "0.014", "Plack::Test" => 0, "Test::Builder::Module" => 0, "Test::Exception" => 0, "Test::File" => 0, "Test::LWP::UserAgent" => "0.018", "Test::More" => "0.96", "Test::TCP" => 0, "blib" => "1.01", "lib" => 0 }, "VERSION" => "0.14", "test" => { "TESTS" => "t/*.t t/01-common/*.t t/02-bowels/*.t t/03-remote/*.t t/04-server/*.t" } ); my %FallbackPrereqs = ( "Apache::Htpasswd" => 0, "App::Cmd" => "0.323", "App::Cmd::Command::help" => 0, "App::Cmd::Setup" => 0, "Archive::Extract" => "0.68", "Archive::Tar" => 0, "Authen::Simple::Passwd" => 0, "CPAN::Checksums" => 0, "CPAN::DistnameInfo" => 0, "CPAN::Meta" => 0, "CPAN::Meta::Requirements" => 0, "Capture::Tiny" => 0, "Carp" => 0, "Class::Load" => 0, "Cwd" => 0, "Cwd::Guard" => 0, "DBD::SQLite" => "1.33", "DBIx::Class" => "0.08200", "DBIx::Class::Core" => 0, "DBIx::Class::ResultSet" => 0, "DBIx::Class::Schema" => 0, "DateTime" => 0, "DateTime::TimeZone" => 0, "DateTime::TimeZone::Local::Unix" => 0, "DateTime::TimeZone::OffsetOnly" => 0, "Devel::StackTrace" => 0, "Digest::MD5" => 0, "Digest::SHA" => 0, "Dist::Metadata" => "0.926", "Encode" => 0, "Exporter" => 0, "ExtUtils::MakeMaker" => 0, "File::Copy" => 0, "File::Find" => 0, "File::HomeDir" => 0, "File::NFSLock" => 0, "File::Spec" => 0, "File::Temp" => 0, "File::Which" => 0, "FindBin" => 0, "Getopt::Long" => 0, "HTTP::Body" => 0, "HTTP::Date" => 0, "HTTP::Request::Common" => 0, "HTTP::Response" => 0, "HTTP::Server::PSGI" => 0, "HTTP::Status" => 0, "IO::File" => 0, "IO::Handle" => 0, "IO::Interactive" => 0, "IO::Pipe" => 0, "IO::Prompt" => 0, "IO::Select" => 0, "IO::String" => 0, "IO::Zlib" => 0, "IPC::Open3" => 0, "JSON" => 0, "JSON::PP" => "2.27103", "LWP::UserAgent" => 0, "List::MoreUtils" => 0, "List::Util" => 0, "Module::CoreList" => "5.20170720", "Module::Faker::Dist" => "0.014", "Module::Metadata" => "1.000031", "Moose" => 0, "Moose::Role" => 0, "MooseX::Aliases" => 0, "MooseX::ClassAttribute" => "0.27", "MooseX::Configuration" => 0, "MooseX::MarkAsMethods" => 0, "MooseX::NonMoose" => 0, "MooseX::SetOnce" => 0, "MooseX::StrictConstructor" => 0, "MooseX::Types" => 0, "MooseX::Types::Moose" => 0, "Path::Class" => 0, "Path::Class::Dir" => 0, "Path::Class::File" => 0, "Plack" => "1.0028", "Plack::MIME" => 0, "Plack::Middleware::Auth::Basic" => 0, "Plack::Request" => 0, "Plack::Response" => 0, "Plack::Runner" => 0, "Plack::Test" => 0, "Pod::Usage" => 0, "Proc::Fork" => 0, "Proc::Terminator" => 0, "Readonly" => 0, "Router::Simple" => 0, "Scalar::Util" => 0, "Starman" => "0.3014", "String::Format" => 0, "Term::ANSIColor" => "2.02", "Test::Builder::Module" => 0, "Test::Exception" => 0, "Test::File" => 0, "Test::LWP::UserAgent" => "0.018", "Test::More" => "0.96", "Test::TCP" => 0, "Throwable::Error" => "0.200005", "Try::Tiny" => 0, "URI" => 0, "URI::Escape" => "3.31", "URI::file" => 0, "UUID::Tiny" => 0, "Variable::Magic" => "0.57", "base" => 0, "blib" => "1.01", "lib" => 0, "overload" => 0, "strict" => 0, "utf8" => 0, "version" => 0, "warnings" => 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); Pinto-0.14/MANIFEST000644 000766 000024 00000013562 13141540305 013741 0ustar00jeffstaff000000 000000 # This file was automatically generated by Dist::Zilla::Plugin::Manifest v6.010. Changes LICENSE MANIFEST MANIFEST.SKIP META.json META.yml Makefile.PL bin/pinto bin/pintod dist.ini etc/TODO.pod etc/benchmark etc/cpanm etc/install.sh etc/mkdbic etc/smoke lib/App/Pinto.pm lib/App/Pinto/Command.pm lib/App/Pinto/Command/add.pm lib/App/Pinto/Command/clean.pm lib/App/Pinto/Command/copy.pm lib/App/Pinto/Command/default.pm lib/App/Pinto/Command/delete.pm lib/App/Pinto/Command/diff.pm lib/App/Pinto/Command/help.pm lib/App/Pinto/Command/init.pm lib/App/Pinto/Command/install.pm lib/App/Pinto/Command/kill.pm lib/App/Pinto/Command/list.pm lib/App/Pinto/Command/lock.pm lib/App/Pinto/Command/log.pm lib/App/Pinto/Command/look.pm lib/App/Pinto/Command/manual.pm lib/App/Pinto/Command/merge.pm lib/App/Pinto/Command/migrate.pm lib/App/Pinto/Command/new.pm lib/App/Pinto/Command/nop.pm lib/App/Pinto/Command/pin.pm lib/App/Pinto/Command/props.pm lib/App/Pinto/Command/pull.pm lib/App/Pinto/Command/register.pm lib/App/Pinto/Command/rename.pm lib/App/Pinto/Command/reset.pm lib/App/Pinto/Command/revert.pm lib/App/Pinto/Command/roots.pm lib/App/Pinto/Command/stacks.pm lib/App/Pinto/Command/statistics.pm lib/App/Pinto/Command/thanks.pm lib/App/Pinto/Command/unlock.pm lib/App/Pinto/Command/unpin.pm lib/App/Pinto/Command/unregister.pm lib/App/Pinto/Command/update.pm lib/App/Pinto/Command/verify.pm lib/Pinto.pm lib/Pinto/Action.pm lib/Pinto/Action/Add.pm lib/Pinto/Action/Clean.pm lib/Pinto/Action/Copy.pm lib/Pinto/Action/Default.pm lib/Pinto/Action/Delete.pm lib/Pinto/Action/Diff.pm lib/Pinto/Action/Install.pm lib/Pinto/Action/Kill.pm lib/Pinto/Action/List.pm lib/Pinto/Action/Lock.pm lib/Pinto/Action/Log.pm lib/Pinto/Action/Look.pm lib/Pinto/Action/Merge.pm lib/Pinto/Action/New.pm lib/Pinto/Action/Nop.pm lib/Pinto/Action/Pin.pm lib/Pinto/Action/Props.pm lib/Pinto/Action/Pull.pm lib/Pinto/Action/Register.pm lib/Pinto/Action/Rename.pm lib/Pinto/Action/Reset.pm lib/Pinto/Action/Revert.pm lib/Pinto/Action/Roots.pm lib/Pinto/Action/Stacks.pm lib/Pinto/Action/Statistics.pm lib/Pinto/Action/Unlock.pm lib/Pinto/Action/Unpin.pm lib/Pinto/Action/Unregister.pm lib/Pinto/Action/Update.pm lib/Pinto/Action/Verify.pm lib/Pinto/ArchiveUnpacker.pm lib/Pinto/Chrome.pm lib/Pinto/Chrome/Net.pm lib/Pinto/Chrome/Term.pm lib/Pinto/Config.pm lib/Pinto/Constants.pm lib/Pinto/Database.pm lib/Pinto/Difference.pm lib/Pinto/DifferenceEntry.pm lib/Pinto/Editor.pm lib/Pinto/Editor/Clip.pm lib/Pinto/Editor/Edit.pm lib/Pinto/Exception.pm lib/Pinto/Globals.pm lib/Pinto/IndexReader.pm lib/Pinto/IndexWriter.pm lib/Pinto/Initializer.pm lib/Pinto/Locator.pm lib/Pinto/Locator/Mirror.pm lib/Pinto/Locator/Multiplex.pm lib/Pinto/Locator/Stratopan.pm lib/Pinto/Locker.pm lib/Pinto/Manual.pod lib/Pinto/Manual/Installing.pod lib/Pinto/Manual/Introduction.pod lib/Pinto/Manual/QuickStart.pod lib/Pinto/Manual/Thanks.pod lib/Pinto/Manual/Tutorial.pod lib/Pinto/Migrator.pm lib/Pinto/ModlistWriter.pm lib/Pinto/PackageExtractor.pm lib/Pinto/PrerequisiteWalker.pm lib/Pinto/Remote.pm lib/Pinto/Remote/Action.pm lib/Pinto/Remote/Action/Add.pm lib/Pinto/Remote/Action/Install.pm lib/Pinto/Remote/Result.pm lib/Pinto/Repository.pm lib/Pinto/Result.pm lib/Pinto/RevisionWalker.pm lib/Pinto/Role/Committable.pm lib/Pinto/Role/Installer.pm lib/Pinto/Role/PauseConfig.pm lib/Pinto/Role/Plated.pm lib/Pinto/Role/Puller.pm lib/Pinto/Role/Schema/Result.pm lib/Pinto/Role/Transactional.pm lib/Pinto/Role/UserAgent.pm lib/Pinto/Schema.pm lib/Pinto/Schema/Result/Ancestry.pm lib/Pinto/Schema/Result/Distribution.pm lib/Pinto/Schema/Result/Package.pm lib/Pinto/Schema/Result/Prerequisite.pm lib/Pinto/Schema/Result/Registration.pm lib/Pinto/Schema/Result/Revision.pm lib/Pinto/Schema/Result/Stack.pm lib/Pinto/Schema/ResultSet/Distribution.pm lib/Pinto/Schema/ResultSet/Package.pm lib/Pinto/Schema/ResultSet/Registration.pm lib/Pinto/Server.pm lib/Pinto/Server/Responder.pm lib/Pinto/Server/Responder/Action.pm lib/Pinto/Server/Responder/File.pm lib/Pinto/Server/Router.pm lib/Pinto/Shell.pm lib/Pinto/Statistics.pm lib/Pinto/Store.pm lib/Pinto/Target.pm lib/Pinto/Target/Distribution.pm lib/Pinto/Target/Package.pm lib/Pinto/Types.pm lib/Pinto/Util.pm t/00-compile.t t/00-report-prereqs.dd t/00-report-prereqs.t t/01-common/01-types.t t/01-common/02-target-package.t t/01-common/03-target-distribution.t t/01-common/04-util.t t/01-common/05-pauseconfig.t t/01-common/lib/TestClass.pm t/02-bowels/01-config.t t/02-bowels/02-chrome.t t/02-bowels/03-package.t t/02-bowels/04-distribution.t t/02-bowels/05-compare.t t/02-bowels/10-init.t t/02-bowels/11-tester.t t/02-bowels/12-locator.t t/02-bowels/19-basic.t t/02-bowels/20-add.t t/02-bowels/21-add-no-index.t t/02-bowels/21-pull-vreq.t t/02-bowels/21-pull.t t/02-bowels/22-add-deep.t t/02-bowels/23-pull-multi.t t/02-bowels/24-skip-prereqs.t t/02-bowels/31-pin.t t/02-bowels/32-pin-rjbs.t t/02-bowels/35-delete.t t/02-bowels/40-list.t t/02-bowels/41-log.t t/02-bowels/42-install.t t/02-bowels/43-install-and-pull.t t/02-bowels/50-diff.t t/02-bowels/51-diff-more.t t/02-bowels/52-intermingle.t t/02-bowels/53-roots.t t/02-bowels/54-revert.t t/02-bowels/60-dryrun.t t/02-bowels/61-nofail.t t/02-bowels/62-commit.t t/02-bowels/63-prereq-circular.t t/02-bowels/63-prereq-core.t t/02-bowels/64-metadata.t t/02-bowels/70-stack-copy.t t/02-bowels/71-stack-kill.t t/02-bowels/72-stack-rename.t t/02-bowels/73-stack-lock.t t/02-bowels/74-stack-default.t t/02-bowels/75-stack-props.t t/02-bowels/80-repo-lock.t t/03-remote/01-requests.t t/03-remote/02-responses.t t/03-remote/03-install.t t/03-remote/04-install-with-auth.t t/03-remote/05-timezone.t t/04-server/01-functional.t t/04-server/02-authentication.t t/04-server/03-security.t t/lib/Pinto/Server/Tester.pm t/lib/Pinto/Tester.pm t/lib/Pinto/Tester/Util.pm weaver.ini xt/author/pod-syntax.t xt/author/test-version.t xt/help/50-manual_cmd.t xt/release/02-workarounds.t xt/release/03-stratopan-live.t xt/release/99-memory-cycle.t xt/release/distmeta.t Pinto-0.14/MANIFEST.SKIP000644 000766 000024 00000000121 13141540305 014471 0ustar00jeffstaff000000 000000 ^profiles ^nytprof ^tmp$ ^[.]tags ^perltidy.LOG ^[.].tidyall.d ^[.]build ^TEST Pinto-0.14/META.json000644 000766 000024 00000056021 13141540305 014226 0ustar00jeffstaff000000 000000 { "abstract" : "Curate a repository of Perl modules", "author" : [ "Jeffrey Ryan Thalhammer " ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 6.010, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Pinto", "no_index" : { "directory" : [ "corpus", "etc", "examples", "t", "t/lib", "xt" ] }, "prereqs" : { "configure" : { "requires" : { "ExtUtils::MakeMaker" : "6.64", "perl" : "5.008" }, "suggests" : { "JSON::PP" : "2.27300" } }, "develop" : { "requires" : { "Test::CPAN::Meta" : "0", "Test::Memory::Cycle" : "0", "Test::More" : "0", "Test::Pod" : "1.41", "Test::Trap" : "0", "Test::Version" : "1", "lib" : "0" } }, "runtime" : { "requires" : { "App::Cmd" : "0.323", "App::Cmd::Command::help" : "0", "App::Cmd::Setup" : "0", "Archive::Extract" : "0.68", "Archive::Tar" : "0", "Authen::Simple::Passwd" : "0", "CPAN::Checksums" : "0", "CPAN::DistnameInfo" : "0", "CPAN::Meta" : "0", "CPAN::Meta::Requirements" : "0", "Carp" : "0", "Class::Load" : "0", "Cwd" : "0", "Cwd::Guard" : "0", "DBD::SQLite" : "1.33", "DBIx::Class" : "0.08200", "DBIx::Class::Core" : "0", "DBIx::Class::ResultSet" : "0", "DBIx::Class::Schema" : "0", "DateTime" : "0", "DateTime::TimeZone" : "0", "DateTime::TimeZone::Local::Unix" : "0", "DateTime::TimeZone::OffsetOnly" : "0", "Devel::StackTrace" : "0", "Digest::MD5" : "0", "Digest::SHA" : "0", "Dist::Metadata" : "0.926", "Encode" : "0", "Exporter" : "0", "File::Copy" : "0", "File::Find" : "0", "File::HomeDir" : "0", "File::NFSLock" : "0", "File::Spec" : "0", "File::Temp" : "0", "File::Which" : "0", "Getopt::Long" : "0", "HTTP::Date" : "0", "HTTP::Request::Common" : "0", "HTTP::Status" : "0", "IO::File" : "0", "IO::Handle" : "0", "IO::Interactive" : "0", "IO::Pipe" : "0", "IO::Prompt" : "0", "IO::Select" : "0", "IO::String" : "0", "IO::Zlib" : "0", "JSON" : "0", "JSON::PP" : "2.27103", "LWP::UserAgent" : "0", "List::MoreUtils" : "0", "List::Util" : "0", "Module::CoreList" : "5.20170720", "Module::Metadata" : "1.000031", "Moose" : "0", "Moose::Role" : "0", "MooseX::Aliases" : "0", "MooseX::ClassAttribute" : "0.27", "MooseX::Configuration" : "0", "MooseX::MarkAsMethods" : "0", "MooseX::NonMoose" : "0", "MooseX::SetOnce" : "0", "MooseX::StrictConstructor" : "0", "MooseX::Types" : "0", "MooseX::Types::Moose" : "0", "Path::Class" : "0", "Path::Class::Dir" : "0", "Path::Class::File" : "0", "Plack" : "1.0028", "Plack::MIME" : "0", "Plack::Middleware::Auth::Basic" : "0", "Plack::Request" : "0", "Plack::Response" : "0", "Plack::Runner" : "0", "Pod::Usage" : "0", "Proc::Fork" : "0", "Proc::Terminator" : "0", "Readonly" : "0", "Router::Simple" : "0", "Scalar::Util" : "0", "Starman" : "0.3014", "String::Format" : "0", "Term::ANSIColor" : "2.02", "Throwable::Error" : "0.200005", "Try::Tiny" : "0", "URI" : "0", "URI::Escape" : "3.31", "URI::file" : "0", "UUID::Tiny" : "0", "Variable::Magic" : "0.57", "base" : "0", "overload" : "0", "perl" : "5.008", "strict" : "0", "utf8" : "0", "version" : "0", "warnings" : "0" } }, "test" : { "recommends" : { "CPAN::Meta" : "2.120900" }, "requires" : { "Apache::Htpasswd" : "0", "Capture::Tiny" : "0", "ExtUtils::MakeMaker" : "0", "File::Spec" : "0", "File::Temp" : "0", "FindBin" : "0", "HTTP::Body" : "0", "HTTP::Response" : "0", "HTTP::Server::PSGI" : "0", "IO::Handle" : "0", "IPC::Open3" : "0", "Module::Faker::Dist" : "0.014", "Plack::Test" : "0", "Test::Builder::Module" : "0", "Test::Exception" : "0", "Test::File" : "0", "Test::LWP::UserAgent" : "0.018", "Test::More" : "0.96", "Test::TCP" : "0", "blib" : "1.01", "lib" : "0", "perl" : "5.008" } } }, "provides" : { "App::Pinto" : { "file" : "lib/App/Pinto.pm", "version" : "0.14" }, "App::Pinto::Command" : { "file" : "lib/App/Pinto/Command.pm", "version" : "0.14" }, "App::Pinto::Command::add" : { "file" : "lib/App/Pinto/Command/add.pm", "version" : "0.14" }, "App::Pinto::Command::clean" : { "file" : "lib/App/Pinto/Command/clean.pm", "version" : "0.14" }, "App::Pinto::Command::copy" : { "file" : "lib/App/Pinto/Command/copy.pm", "version" : "0.14" }, "App::Pinto::Command::default" : { "file" : "lib/App/Pinto/Command/default.pm", "version" : "0.14" }, "App::Pinto::Command::delete" : { "file" : "lib/App/Pinto/Command/delete.pm", "version" : "0.14" }, "App::Pinto::Command::diff" : { "file" : "lib/App/Pinto/Command/diff.pm", "version" : "0.14" }, "App::Pinto::Command::help" : { "file" : "lib/App/Pinto/Command/help.pm", "version" : "0.14" }, "App::Pinto::Command::init" : { "file" : "lib/App/Pinto/Command/init.pm", "version" : "0.14" }, "App::Pinto::Command::install" : { "file" : "lib/App/Pinto/Command/install.pm", "version" : "0.14" }, "App::Pinto::Command::kill" : { "file" : "lib/App/Pinto/Command/kill.pm", "version" : "0.14" }, "App::Pinto::Command::list" : { "file" : "lib/App/Pinto/Command/list.pm", "version" : "0.14" }, "App::Pinto::Command::lock" : { "file" : "lib/App/Pinto/Command/lock.pm", "version" : "0.14" }, "App::Pinto::Command::log" : { "file" : "lib/App/Pinto/Command/log.pm", "version" : "0.14" }, "App::Pinto::Command::look" : { "file" : "lib/App/Pinto/Command/look.pm", "version" : "0.14" }, "App::Pinto::Command::manual" : { "file" : "lib/App/Pinto/Command/manual.pm", "version" : "0.14" }, "App::Pinto::Command::merge" : { "file" : "lib/App/Pinto/Command/merge.pm", "version" : "0.14" }, "App::Pinto::Command::migrate" : { "file" : "lib/App/Pinto/Command/migrate.pm", "version" : "0.14" }, "App::Pinto::Command::new" : { "file" : "lib/App/Pinto/Command/new.pm", "version" : "0.14" }, "App::Pinto::Command::nop" : { "file" : "lib/App/Pinto/Command/nop.pm", "version" : "0.14" }, "App::Pinto::Command::pin" : { "file" : "lib/App/Pinto/Command/pin.pm", "version" : "0.14" }, "App::Pinto::Command::props" : { "file" : "lib/App/Pinto/Command/props.pm", "version" : "0.14" }, "App::Pinto::Command::pull" : { "file" : "lib/App/Pinto/Command/pull.pm", "version" : "0.14" }, "App::Pinto::Command::register" : { "file" : "lib/App/Pinto/Command/register.pm", "version" : "0.14" }, "App::Pinto::Command::rename" : { "file" : "lib/App/Pinto/Command/rename.pm", "version" : "0.14" }, "App::Pinto::Command::reset" : { "file" : "lib/App/Pinto/Command/reset.pm", "version" : "0.14" }, "App::Pinto::Command::revert" : { "file" : "lib/App/Pinto/Command/revert.pm", "version" : "0.14" }, "App::Pinto::Command::roots" : { "file" : "lib/App/Pinto/Command/roots.pm", "version" : "0.14" }, "App::Pinto::Command::stacks" : { "file" : "lib/App/Pinto/Command/stacks.pm", "version" : "0.14" }, "App::Pinto::Command::statistics" : { "file" : "lib/App/Pinto/Command/statistics.pm", "version" : "0.14" }, "App::Pinto::Command::thanks" : { "file" : "lib/App/Pinto/Command/thanks.pm", "version" : "0.14" }, "App::Pinto::Command::unlock" : { "file" : "lib/App/Pinto/Command/unlock.pm", "version" : "0.14" }, "App::Pinto::Command::unpin" : { "file" : "lib/App/Pinto/Command/unpin.pm", "version" : "0.14" }, "App::Pinto::Command::unregister" : { "file" : "lib/App/Pinto/Command/unregister.pm", "version" : "0.14" }, "App::Pinto::Command::update" : { "file" : "lib/App/Pinto/Command/update.pm", "version" : "0.14" }, "App::Pinto::Command::verify" : { "file" : "lib/App/Pinto/Command/verify.pm", "version" : "0.14" }, "Pinto" : { "file" : "lib/Pinto.pm", "version" : "0.14" }, "Pinto::Action" : { "file" : "lib/Pinto/Action.pm", "version" : "0.14" }, "Pinto::Action::Add" : { "file" : "lib/Pinto/Action/Add.pm", "version" : "0.14" }, "Pinto::Action::Clean" : { "file" : "lib/Pinto/Action/Clean.pm", "version" : "0.14" }, "Pinto::Action::Copy" : { "file" : "lib/Pinto/Action/Copy.pm", "version" : "0.14" }, "Pinto::Action::Default" : { "file" : "lib/Pinto/Action/Default.pm", "version" : "0.14" }, "Pinto::Action::Delete" : { "file" : "lib/Pinto/Action/Delete.pm", "version" : "0.14" }, "Pinto::Action::Diff" : { "file" : "lib/Pinto/Action/Diff.pm", "version" : "0.14" }, "Pinto::Action::Install" : { "file" : "lib/Pinto/Action/Install.pm", "version" : "0.14" }, "Pinto::Action::Kill" : { "file" : "lib/Pinto/Action/Kill.pm", "version" : "0.14" }, "Pinto::Action::List" : { "file" : "lib/Pinto/Action/List.pm", "version" : "0.14" }, "Pinto::Action::Lock" : { "file" : "lib/Pinto/Action/Lock.pm", "version" : "0.14" }, "Pinto::Action::Log" : { "file" : "lib/Pinto/Action/Log.pm", "version" : "0.14" }, "Pinto::Action::Look" : { "file" : "lib/Pinto/Action/Look.pm", "version" : "0.14" }, "Pinto::Action::Merge" : { "file" : "lib/Pinto/Action/Merge.pm", "version" : "0.14" }, "Pinto::Action::New" : { "file" : "lib/Pinto/Action/New.pm", "version" : "0.14" }, "Pinto::Action::Nop" : { "file" : "lib/Pinto/Action/Nop.pm", "version" : "0.14" }, "Pinto::Action::Pin" : { "file" : "lib/Pinto/Action/Pin.pm", "version" : "0.14" }, "Pinto::Action::Props" : { "file" : "lib/Pinto/Action/Props.pm", "version" : "0.14" }, "Pinto::Action::Pull" : { "file" : "lib/Pinto/Action/Pull.pm", "version" : "0.14" }, "Pinto::Action::Register" : { "file" : "lib/Pinto/Action/Register.pm", "version" : "0.14" }, "Pinto::Action::Rename" : { "file" : "lib/Pinto/Action/Rename.pm", "version" : "0.14" }, "Pinto::Action::Reset" : { "file" : "lib/Pinto/Action/Reset.pm", "version" : "0.14" }, "Pinto::Action::Revert" : { "file" : "lib/Pinto/Action/Revert.pm", "version" : "0.14" }, "Pinto::Action::Roots" : { "file" : "lib/Pinto/Action/Roots.pm", "version" : "0.14" }, "Pinto::Action::Stacks" : { "file" : "lib/Pinto/Action/Stacks.pm", "version" : "0.14" }, "Pinto::Action::Statistics" : { "file" : "lib/Pinto/Action/Statistics.pm", "version" : "0.14" }, "Pinto::Action::Unlock" : { "file" : "lib/Pinto/Action/Unlock.pm", "version" : "0.14" }, "Pinto::Action::Unpin" : { "file" : "lib/Pinto/Action/Unpin.pm", "version" : "0.14" }, "Pinto::Action::Unregister" : { "file" : "lib/Pinto/Action/Unregister.pm", "version" : "0.14" }, "Pinto::Action::Update" : { "file" : "lib/Pinto/Action/Update.pm", "version" : "0.14" }, "Pinto::Action::Verify" : { "file" : "lib/Pinto/Action/Verify.pm", "version" : "0.14" }, "Pinto::ArchiveUnpacker" : { "file" : "lib/Pinto/ArchiveUnpacker.pm", "version" : "0.14" }, "Pinto::Chrome" : { "file" : "lib/Pinto/Chrome.pm", "version" : "0.14" }, "Pinto::Chrome::Net" : { "file" : "lib/Pinto/Chrome/Net.pm", "version" : "0.14" }, "Pinto::Chrome::Term" : { "file" : "lib/Pinto/Chrome/Term.pm", "version" : "0.14" }, "Pinto::Config" : { "file" : "lib/Pinto/Config.pm", "version" : "0.14" }, "Pinto::Constants" : { "file" : "lib/Pinto/Constants.pm", "version" : "0.14" }, "Pinto::Database" : { "file" : "lib/Pinto/Database.pm", "version" : "0.14" }, "Pinto::Difference" : { "file" : "lib/Pinto/Difference.pm", "version" : "0.14" }, "Pinto::DifferenceEntry" : { "file" : "lib/Pinto/DifferenceEntry.pm", "version" : "0.14" }, "Pinto::Editor" : { "file" : "lib/Pinto/Editor.pm", "version" : "0.14" }, "Pinto::Editor::Clip" : { "file" : "lib/Pinto/Editor/Clip.pm", "version" : "0.14" }, "Pinto::Editor::Edit" : { "file" : "lib/Pinto/Editor/Edit.pm", "version" : "0.14" }, "Pinto::Exception" : { "file" : "lib/Pinto/Exception.pm", "version" : "0.14" }, "Pinto::Globals" : { "file" : "lib/Pinto/Globals.pm", "version" : "0.14" }, "Pinto::IndexReader" : { "file" : "lib/Pinto/IndexReader.pm", "version" : "0.14" }, "Pinto::IndexWriter" : { "file" : "lib/Pinto/IndexWriter.pm", "version" : "0.14" }, "Pinto::Initializer" : { "file" : "lib/Pinto/Initializer.pm", "version" : "0.14" }, "Pinto::Locator" : { "file" : "lib/Pinto/Locator.pm", "version" : "0.14" }, "Pinto::Locator::Mirror" : { "file" : "lib/Pinto/Locator/Mirror.pm", "version" : "0.14" }, "Pinto::Locator::Multiplex" : { "file" : "lib/Pinto/Locator/Multiplex.pm", "version" : "0.14" }, "Pinto::Locator::Stratopan" : { "file" : "lib/Pinto/Locator/Stratopan.pm", "version" : "0.14" }, "Pinto::Locker" : { "file" : "lib/Pinto/Locker.pm", "version" : "0.14" }, "Pinto::Migrator" : { "file" : "lib/Pinto/Migrator.pm", "version" : "0.14" }, "Pinto::ModlistWriter" : { "file" : "lib/Pinto/ModlistWriter.pm", "version" : "0.14" }, "Pinto::PackageExtractor" : { "file" : "lib/Pinto/PackageExtractor.pm", "version" : "0.14" }, "Pinto::PrerequisiteWalker" : { "file" : "lib/Pinto/PrerequisiteWalker.pm", "version" : "0.14" }, "Pinto::Remote" : { "file" : "lib/Pinto/Remote.pm", "version" : "0.14" }, "Pinto::Remote::Action" : { "file" : "lib/Pinto/Remote/Action.pm", "version" : "0.14" }, "Pinto::Remote::Action::Add" : { "file" : "lib/Pinto/Remote/Action/Add.pm", "version" : "0.14" }, "Pinto::Remote::Action::Install" : { "file" : "lib/Pinto/Remote/Action/Install.pm", "version" : "0.14" }, "Pinto::Remote::Result" : { "file" : "lib/Pinto/Remote/Result.pm", "version" : "0.14" }, "Pinto::Repository" : { "file" : "lib/Pinto/Repository.pm", "version" : "0.14" }, "Pinto::Result" : { "file" : "lib/Pinto/Result.pm", "version" : "0.14" }, "Pinto::RevisionWalker" : { "file" : "lib/Pinto/RevisionWalker.pm", "version" : "0.14" }, "Pinto::Role::Committable" : { "file" : "lib/Pinto/Role/Committable.pm", "version" : "0.14" }, "Pinto::Role::Installer" : { "file" : "lib/Pinto/Role/Installer.pm", "version" : "0.14" }, "Pinto::Role::PauseConfig" : { "file" : "lib/Pinto/Role/PauseConfig.pm", "version" : "0.14" }, "Pinto::Role::Plated" : { "file" : "lib/Pinto/Role/Plated.pm", "version" : "0.14" }, "Pinto::Role::Puller" : { "file" : "lib/Pinto/Role/Puller.pm", "version" : "0.14" }, "Pinto::Role::Schema::Result" : { "file" : "lib/Pinto/Role/Schema/Result.pm", "version" : "0.14" }, "Pinto::Role::Transactional" : { "file" : "lib/Pinto/Role/Transactional.pm", "version" : "0.14" }, "Pinto::Role::UserAgent" : { "file" : "lib/Pinto/Role/UserAgent.pm", "version" : "0.14" }, "Pinto::Schema" : { "file" : "lib/Pinto/Schema.pm", "version" : "0.14" }, "Pinto::Schema::Result::Ancestry" : { "file" : "lib/Pinto/Schema/Result/Ancestry.pm", "version" : "0.14" }, "Pinto::Schema::Result::Distribution" : { "file" : "lib/Pinto/Schema/Result/Distribution.pm", "version" : "0.14" }, "Pinto::Schema::Result::Package" : { "file" : "lib/Pinto/Schema/Result/Package.pm", "version" : "0.14" }, "Pinto::Schema::Result::Prerequisite" : { "file" : "lib/Pinto/Schema/Result/Prerequisite.pm", "version" : "0.14" }, "Pinto::Schema::Result::Registration" : { "file" : "lib/Pinto/Schema/Result/Registration.pm", "version" : "0.14" }, "Pinto::Schema::Result::Revision" : { "file" : "lib/Pinto/Schema/Result/Revision.pm", "version" : "0.14" }, "Pinto::Schema::Result::Stack" : { "file" : "lib/Pinto/Schema/Result/Stack.pm", "version" : "0.14" }, "Pinto::Schema::ResultSet::Distribution" : { "file" : "lib/Pinto/Schema/ResultSet/Distribution.pm", "version" : "0.14" }, "Pinto::Schema::ResultSet::Package" : { "file" : "lib/Pinto/Schema/ResultSet/Package.pm", "version" : "0.14" }, "Pinto::Schema::ResultSet::Registration" : { "file" : "lib/Pinto/Schema/ResultSet/Registration.pm", "version" : "0.14" }, "Pinto::Server" : { "file" : "lib/Pinto/Server.pm", "version" : "0.14" }, "Pinto::Server::Responder" : { "file" : "lib/Pinto/Server/Responder.pm", "version" : "0.14" }, "Pinto::Server::Responder::Action" : { "file" : "lib/Pinto/Server/Responder/Action.pm", "version" : "0.14" }, "Pinto::Server::Responder::File" : { "file" : "lib/Pinto/Server/Responder/File.pm", "version" : "0.14" }, "Pinto::Server::Router" : { "file" : "lib/Pinto/Server/Router.pm", "version" : "0.14" }, "Pinto::Shell" : { "file" : "lib/Pinto/Shell.pm", "version" : "0.14" }, "Pinto::Statistics" : { "file" : "lib/Pinto/Statistics.pm", "version" : "0.14" }, "Pinto::Store" : { "file" : "lib/Pinto/Store.pm", "version" : "0.14" }, "Pinto::Target" : { "file" : "lib/Pinto/Target.pm", "version" : "0.14" }, "Pinto::Target::Distribution" : { "file" : "lib/Pinto/Target/Distribution.pm", "version" : "0.14" }, "Pinto::Target::Package" : { "file" : "lib/Pinto/Target/Package.pm", "version" : "0.14" }, "Pinto::Types" : { "file" : "lib/Pinto/Types.pm", "version" : "0.14" }, "Pinto::Util" : { "file" : "lib/Pinto/Util.pm", "version" : "0.14" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/thaljef/Pinto/issues" }, "homepage" : "https://metacpan.org/module/Pinto", "repository" : { "type" : "git", "url" : "git://github.com/thaljef/Pinto.git", "web" : "https://github.com/thaljef/Pinto" } }, "version" : "0.14", "x_contributors" : [ "BenRifkah Bergsten-Buret ", "Boris D\u00e4ppen ", "brian d foy ", "Chris Kirke ", "Cory G Watson ", "David Steinbrunner ", "Ferenc Erki ", "Florian Ragwitz ", "Glenn Fowler ", "hesco ", "Jakob Voss ", "Jeffrey Ryan Thalhammer ", "Kahlil (Kal) Hodgson ", "Karen Etheridge ", "Michael G. Schwern ", "Michael Jemmeson ", "Mike Raynham ", "Nikolay Martynov ", "Oleg Gashev ", "popl ", "Steffen Schwigon ", "Tommy Stanton ", "Wolfgang Kinkeldei ", "Yanick Champoux " ], "x_serialization_backend" : "Cpanel::JSON::XS version 3.0237" } Pinto-0.14/META.yml000644 000766 000024 00000036631 13141540305 014063 0ustar00jeffstaff000000 000000 --- abstract: 'Curate a repository of Perl modules' author: - 'Jeffrey Ryan Thalhammer ' build_requires: Apache::Htpasswd: '0' Capture::Tiny: '0' ExtUtils::MakeMaker: '0' File::Spec: '0' File::Temp: '0' FindBin: '0' HTTP::Body: '0' HTTP::Response: '0' HTTP::Server::PSGI: '0' IO::Handle: '0' IPC::Open3: '0' Module::Faker::Dist: '0.014' Plack::Test: '0' Test::Builder::Module: '0' Test::Exception: '0' Test::File: '0' Test::LWP::UserAgent: '0.018' Test::More: '0.96' Test::TCP: '0' blib: '1.01' lib: '0' perl: '5.008' configure_requires: ExtUtils::MakeMaker: '6.64' perl: '5.008' dynamic_config: 0 generated_by: 'Dist::Zilla version 6.010, 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: Pinto no_index: directory: - corpus - etc - examples - t - t/lib - xt provides: App::Pinto: file: lib/App/Pinto.pm version: '0.14' App::Pinto::Command: file: lib/App/Pinto/Command.pm version: '0.14' App::Pinto::Command::add: file: lib/App/Pinto/Command/add.pm version: '0.14' App::Pinto::Command::clean: file: lib/App/Pinto/Command/clean.pm version: '0.14' App::Pinto::Command::copy: file: lib/App/Pinto/Command/copy.pm version: '0.14' App::Pinto::Command::default: file: lib/App/Pinto/Command/default.pm version: '0.14' App::Pinto::Command::delete: file: lib/App/Pinto/Command/delete.pm version: '0.14' App::Pinto::Command::diff: file: lib/App/Pinto/Command/diff.pm version: '0.14' App::Pinto::Command::help: file: lib/App/Pinto/Command/help.pm version: '0.14' App::Pinto::Command::init: file: lib/App/Pinto/Command/init.pm version: '0.14' App::Pinto::Command::install: file: lib/App/Pinto/Command/install.pm version: '0.14' App::Pinto::Command::kill: file: lib/App/Pinto/Command/kill.pm version: '0.14' App::Pinto::Command::list: file: lib/App/Pinto/Command/list.pm version: '0.14' App::Pinto::Command::lock: file: lib/App/Pinto/Command/lock.pm version: '0.14' App::Pinto::Command::log: file: lib/App/Pinto/Command/log.pm version: '0.14' App::Pinto::Command::look: file: lib/App/Pinto/Command/look.pm version: '0.14' App::Pinto::Command::manual: file: lib/App/Pinto/Command/manual.pm version: '0.14' App::Pinto::Command::merge: file: lib/App/Pinto/Command/merge.pm version: '0.14' App::Pinto::Command::migrate: file: lib/App/Pinto/Command/migrate.pm version: '0.14' App::Pinto::Command::new: file: lib/App/Pinto/Command/new.pm version: '0.14' App::Pinto::Command::nop: file: lib/App/Pinto/Command/nop.pm version: '0.14' App::Pinto::Command::pin: file: lib/App/Pinto/Command/pin.pm version: '0.14' App::Pinto::Command::props: file: lib/App/Pinto/Command/props.pm version: '0.14' App::Pinto::Command::pull: file: lib/App/Pinto/Command/pull.pm version: '0.14' App::Pinto::Command::register: file: lib/App/Pinto/Command/register.pm version: '0.14' App::Pinto::Command::rename: file: lib/App/Pinto/Command/rename.pm version: '0.14' App::Pinto::Command::reset: file: lib/App/Pinto/Command/reset.pm version: '0.14' App::Pinto::Command::revert: file: lib/App/Pinto/Command/revert.pm version: '0.14' App::Pinto::Command::roots: file: lib/App/Pinto/Command/roots.pm version: '0.14' App::Pinto::Command::stacks: file: lib/App/Pinto/Command/stacks.pm version: '0.14' App::Pinto::Command::statistics: file: lib/App/Pinto/Command/statistics.pm version: '0.14' App::Pinto::Command::thanks: file: lib/App/Pinto/Command/thanks.pm version: '0.14' App::Pinto::Command::unlock: file: lib/App/Pinto/Command/unlock.pm version: '0.14' App::Pinto::Command::unpin: file: lib/App/Pinto/Command/unpin.pm version: '0.14' App::Pinto::Command::unregister: file: lib/App/Pinto/Command/unregister.pm version: '0.14' App::Pinto::Command::update: file: lib/App/Pinto/Command/update.pm version: '0.14' App::Pinto::Command::verify: file: lib/App/Pinto/Command/verify.pm version: '0.14' Pinto: file: lib/Pinto.pm version: '0.14' Pinto::Action: file: lib/Pinto/Action.pm version: '0.14' Pinto::Action::Add: file: lib/Pinto/Action/Add.pm version: '0.14' Pinto::Action::Clean: file: lib/Pinto/Action/Clean.pm version: '0.14' Pinto::Action::Copy: file: lib/Pinto/Action/Copy.pm version: '0.14' Pinto::Action::Default: file: lib/Pinto/Action/Default.pm version: '0.14' Pinto::Action::Delete: file: lib/Pinto/Action/Delete.pm version: '0.14' Pinto::Action::Diff: file: lib/Pinto/Action/Diff.pm version: '0.14' Pinto::Action::Install: file: lib/Pinto/Action/Install.pm version: '0.14' Pinto::Action::Kill: file: lib/Pinto/Action/Kill.pm version: '0.14' Pinto::Action::List: file: lib/Pinto/Action/List.pm version: '0.14' Pinto::Action::Lock: file: lib/Pinto/Action/Lock.pm version: '0.14' Pinto::Action::Log: file: lib/Pinto/Action/Log.pm version: '0.14' Pinto::Action::Look: file: lib/Pinto/Action/Look.pm version: '0.14' Pinto::Action::Merge: file: lib/Pinto/Action/Merge.pm version: '0.14' Pinto::Action::New: file: lib/Pinto/Action/New.pm version: '0.14' Pinto::Action::Nop: file: lib/Pinto/Action/Nop.pm version: '0.14' Pinto::Action::Pin: file: lib/Pinto/Action/Pin.pm version: '0.14' Pinto::Action::Props: file: lib/Pinto/Action/Props.pm version: '0.14' Pinto::Action::Pull: file: lib/Pinto/Action/Pull.pm version: '0.14' Pinto::Action::Register: file: lib/Pinto/Action/Register.pm version: '0.14' Pinto::Action::Rename: file: lib/Pinto/Action/Rename.pm version: '0.14' Pinto::Action::Reset: file: lib/Pinto/Action/Reset.pm version: '0.14' Pinto::Action::Revert: file: lib/Pinto/Action/Revert.pm version: '0.14' Pinto::Action::Roots: file: lib/Pinto/Action/Roots.pm version: '0.14' Pinto::Action::Stacks: file: lib/Pinto/Action/Stacks.pm version: '0.14' Pinto::Action::Statistics: file: lib/Pinto/Action/Statistics.pm version: '0.14' Pinto::Action::Unlock: file: lib/Pinto/Action/Unlock.pm version: '0.14' Pinto::Action::Unpin: file: lib/Pinto/Action/Unpin.pm version: '0.14' Pinto::Action::Unregister: file: lib/Pinto/Action/Unregister.pm version: '0.14' Pinto::Action::Update: file: lib/Pinto/Action/Update.pm version: '0.14' Pinto::Action::Verify: file: lib/Pinto/Action/Verify.pm version: '0.14' Pinto::ArchiveUnpacker: file: lib/Pinto/ArchiveUnpacker.pm version: '0.14' Pinto::Chrome: file: lib/Pinto/Chrome.pm version: '0.14' Pinto::Chrome::Net: file: lib/Pinto/Chrome/Net.pm version: '0.14' Pinto::Chrome::Term: file: lib/Pinto/Chrome/Term.pm version: '0.14' Pinto::Config: file: lib/Pinto/Config.pm version: '0.14' Pinto::Constants: file: lib/Pinto/Constants.pm version: '0.14' Pinto::Database: file: lib/Pinto/Database.pm version: '0.14' Pinto::Difference: file: lib/Pinto/Difference.pm version: '0.14' Pinto::DifferenceEntry: file: lib/Pinto/DifferenceEntry.pm version: '0.14' Pinto::Editor: file: lib/Pinto/Editor.pm version: '0.14' Pinto::Editor::Clip: file: lib/Pinto/Editor/Clip.pm version: '0.14' Pinto::Editor::Edit: file: lib/Pinto/Editor/Edit.pm version: '0.14' Pinto::Exception: file: lib/Pinto/Exception.pm version: '0.14' Pinto::Globals: file: lib/Pinto/Globals.pm version: '0.14' Pinto::IndexReader: file: lib/Pinto/IndexReader.pm version: '0.14' Pinto::IndexWriter: file: lib/Pinto/IndexWriter.pm version: '0.14' Pinto::Initializer: file: lib/Pinto/Initializer.pm version: '0.14' Pinto::Locator: file: lib/Pinto/Locator.pm version: '0.14' Pinto::Locator::Mirror: file: lib/Pinto/Locator/Mirror.pm version: '0.14' Pinto::Locator::Multiplex: file: lib/Pinto/Locator/Multiplex.pm version: '0.14' Pinto::Locator::Stratopan: file: lib/Pinto/Locator/Stratopan.pm version: '0.14' Pinto::Locker: file: lib/Pinto/Locker.pm version: '0.14' Pinto::Migrator: file: lib/Pinto/Migrator.pm version: '0.14' Pinto::ModlistWriter: file: lib/Pinto/ModlistWriter.pm version: '0.14' Pinto::PackageExtractor: file: lib/Pinto/PackageExtractor.pm version: '0.14' Pinto::PrerequisiteWalker: file: lib/Pinto/PrerequisiteWalker.pm version: '0.14' Pinto::Remote: file: lib/Pinto/Remote.pm version: '0.14' Pinto::Remote::Action: file: lib/Pinto/Remote/Action.pm version: '0.14' Pinto::Remote::Action::Add: file: lib/Pinto/Remote/Action/Add.pm version: '0.14' Pinto::Remote::Action::Install: file: lib/Pinto/Remote/Action/Install.pm version: '0.14' Pinto::Remote::Result: file: lib/Pinto/Remote/Result.pm version: '0.14' Pinto::Repository: file: lib/Pinto/Repository.pm version: '0.14' Pinto::Result: file: lib/Pinto/Result.pm version: '0.14' Pinto::RevisionWalker: file: lib/Pinto/RevisionWalker.pm version: '0.14' Pinto::Role::Committable: file: lib/Pinto/Role/Committable.pm version: '0.14' Pinto::Role::Installer: file: lib/Pinto/Role/Installer.pm version: '0.14' Pinto::Role::PauseConfig: file: lib/Pinto/Role/PauseConfig.pm version: '0.14' Pinto::Role::Plated: file: lib/Pinto/Role/Plated.pm version: '0.14' Pinto::Role::Puller: file: lib/Pinto/Role/Puller.pm version: '0.14' Pinto::Role::Schema::Result: file: lib/Pinto/Role/Schema/Result.pm version: '0.14' Pinto::Role::Transactional: file: lib/Pinto/Role/Transactional.pm version: '0.14' Pinto::Role::UserAgent: file: lib/Pinto/Role/UserAgent.pm version: '0.14' Pinto::Schema: file: lib/Pinto/Schema.pm version: '0.14' Pinto::Schema::Result::Ancestry: file: lib/Pinto/Schema/Result/Ancestry.pm version: '0.14' Pinto::Schema::Result::Distribution: file: lib/Pinto/Schema/Result/Distribution.pm version: '0.14' Pinto::Schema::Result::Package: file: lib/Pinto/Schema/Result/Package.pm version: '0.14' Pinto::Schema::Result::Prerequisite: file: lib/Pinto/Schema/Result/Prerequisite.pm version: '0.14' Pinto::Schema::Result::Registration: file: lib/Pinto/Schema/Result/Registration.pm version: '0.14' Pinto::Schema::Result::Revision: file: lib/Pinto/Schema/Result/Revision.pm version: '0.14' Pinto::Schema::Result::Stack: file: lib/Pinto/Schema/Result/Stack.pm version: '0.14' Pinto::Schema::ResultSet::Distribution: file: lib/Pinto/Schema/ResultSet/Distribution.pm version: '0.14' Pinto::Schema::ResultSet::Package: file: lib/Pinto/Schema/ResultSet/Package.pm version: '0.14' Pinto::Schema::ResultSet::Registration: file: lib/Pinto/Schema/ResultSet/Registration.pm version: '0.14' Pinto::Server: file: lib/Pinto/Server.pm version: '0.14' Pinto::Server::Responder: file: lib/Pinto/Server/Responder.pm version: '0.14' Pinto::Server::Responder::Action: file: lib/Pinto/Server/Responder/Action.pm version: '0.14' Pinto::Server::Responder::File: file: lib/Pinto/Server/Responder/File.pm version: '0.14' Pinto::Server::Router: file: lib/Pinto/Server/Router.pm version: '0.14' Pinto::Shell: file: lib/Pinto/Shell.pm version: '0.14' Pinto::Statistics: file: lib/Pinto/Statistics.pm version: '0.14' Pinto::Store: file: lib/Pinto/Store.pm version: '0.14' Pinto::Target: file: lib/Pinto/Target.pm version: '0.14' Pinto::Target::Distribution: file: lib/Pinto/Target/Distribution.pm version: '0.14' Pinto::Target::Package: file: lib/Pinto/Target/Package.pm version: '0.14' Pinto::Types: file: lib/Pinto/Types.pm version: '0.14' Pinto::Util: file: lib/Pinto/Util.pm version: '0.14' requires: App::Cmd: '0.323' App::Cmd::Command::help: '0' App::Cmd::Setup: '0' Archive::Extract: '0.68' Archive::Tar: '0' Authen::Simple::Passwd: '0' CPAN::Checksums: '0' CPAN::DistnameInfo: '0' CPAN::Meta: '0' CPAN::Meta::Requirements: '0' Carp: '0' Class::Load: '0' Cwd: '0' Cwd::Guard: '0' DBD::SQLite: '1.33' DBIx::Class: '0.08200' DBIx::Class::Core: '0' DBIx::Class::ResultSet: '0' DBIx::Class::Schema: '0' DateTime: '0' DateTime::TimeZone: '0' DateTime::TimeZone::Local::Unix: '0' DateTime::TimeZone::OffsetOnly: '0' Devel::StackTrace: '0' Digest::MD5: '0' Digest::SHA: '0' Dist::Metadata: '0.926' Encode: '0' Exporter: '0' File::Copy: '0' File::Find: '0' File::HomeDir: '0' File::NFSLock: '0' File::Spec: '0' File::Temp: '0' File::Which: '0' Getopt::Long: '0' HTTP::Date: '0' HTTP::Request::Common: '0' HTTP::Status: '0' IO::File: '0' IO::Handle: '0' IO::Interactive: '0' IO::Pipe: '0' IO::Prompt: '0' IO::Select: '0' IO::String: '0' IO::Zlib: '0' JSON: '0' JSON::PP: '2.27103' LWP::UserAgent: '0' List::MoreUtils: '0' List::Util: '0' Module::CoreList: '5.20170720' Module::Metadata: '1.000031' Moose: '0' Moose::Role: '0' MooseX::Aliases: '0' MooseX::ClassAttribute: '0.27' MooseX::Configuration: '0' MooseX::MarkAsMethods: '0' MooseX::NonMoose: '0' MooseX::SetOnce: '0' MooseX::StrictConstructor: '0' MooseX::Types: '0' MooseX::Types::Moose: '0' Path::Class: '0' Path::Class::Dir: '0' Path::Class::File: '0' Plack: '1.0028' Plack::MIME: '0' Plack::Middleware::Auth::Basic: '0' Plack::Request: '0' Plack::Response: '0' Plack::Runner: '0' Pod::Usage: '0' Proc::Fork: '0' Proc::Terminator: '0' Readonly: '0' Router::Simple: '0' Scalar::Util: '0' Starman: '0.3014' String::Format: '0' Term::ANSIColor: '2.02' Throwable::Error: '0.200005' Try::Tiny: '0' URI: '0' URI::Escape: '3.31' URI::file: '0' UUID::Tiny: '0' Variable::Magic: '0.57' base: '0' overload: '0' perl: '5.008' strict: '0' utf8: '0' version: '0' warnings: '0' resources: bugtracker: https://github.com/thaljef/Pinto/issues homepage: https://metacpan.org/module/Pinto repository: git://github.com/thaljef/Pinto.git version: '0.14' x_contributors: - 'BenRifkah Bergsten-Buret ' - 'Boris Däppen ' - 'brian d foy ' - 'Chris Kirke ' - 'Cory G Watson ' - 'David Steinbrunner ' - 'Ferenc Erki ' - 'Florian Ragwitz ' - 'Glenn Fowler ' - 'hesco ' - 'Jakob Voss ' - 'Jeffrey Ryan Thalhammer ' - 'Kahlil (Kal) Hodgson ' - 'Karen Etheridge ' - 'Michael G. Schwern ' - 'Michael Jemmeson ' - 'Mike Raynham ' - 'Nikolay Martynov ' - 'Oleg Gashev ' - 'popl ' - 'Steffen Schwigon ' - 'Tommy Stanton ' - 'Wolfgang Kinkeldei ' - 'Yanick Champoux ' x_serialization_backend: 'YAML::Tiny version 1.70' Pinto-0.14/t/000755 000766 000024 00000000000 13141540305 013044 5ustar00jeffstaff000000 000000 Pinto-0.14/weaver.ini000644 000766 000024 00000001464 13141540305 014600 0ustar00jeffstaff000000 000000 [@CorePrep] ; [@Default] [-SingleEncoding] ; Assume UTF-8 encoding for all files [-StopWords] ; generate some stopwords and gather them together [Name] ; [@Default] [Version] ; [@Default] [Generic / SYNOPSIS] ; [@Default] [Generic / DESCRIPTION] ; [@Default] [Collect / ATTRIBUTES] ; [@Default] command = attr [Collect / METHODS] ; [@Default] command = method [Collect / FUNCTIONS] ; [@Default] command = func [Leftovers] ; [@Default] [Support] bugs_content = {WEB} bugs = metadata irc = irc.perl.org, #pinto, thaljef websites = metacpan, ratings, kwalitee, testers, testmatrix, deps [Contributors] [Authors] ; [@Default] [Legal] ; [@Default] Pinto-0.14/xt/000755 000766 000024 00000000000 13141540305 013234 5ustar00jeffstaff000000 000000 Pinto-0.14/xt/author/000755 000766 000024 00000000000 13141540305 014536 5ustar00jeffstaff000000 000000 Pinto-0.14/xt/help/000755 000766 000024 00000000000 13141540305 014164 5ustar00jeffstaff000000 000000 Pinto-0.14/xt/release/000755 000766 000024 00000000000 13141540305 014654 5ustar00jeffstaff000000 000000 Pinto-0.14/xt/release/02-workarounds.t000644 000766 000024 00000003472 13141540305 017644 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use lib 't/lib'; use Pinto::Tester; #------------------------------------------------------------------------------ note("This test requires a live internet connection to pull stuff from CPAN"); #------------------------------------------------------------------------------ # FCGI and common::sense both generate the .pm files at build time. So it # appears that they don't have any packages. The PackageExctractor class # has workaround for these for my $pkg (qw(common::sense FCGI Net::LibIDN)) { my $t = Pinto::Tester->new; $t->run_ok( Pull => { targets => $pkg } ); $t->run_ok( List => {} ); $t->stdout_like( qr{$pkg}, "$pkg registered ok" ); } #------------------------------------------------------------------------------ # For inexplicable reasons, pulling DateTime::TimeZone causes Pinto to blow # up on perl 5.14.x (and possibly others). It has something to do with # Class::Load claiming that a module is already loaded when it really isn't. for my $pkg (qw(DateTime::TimeZone)) { my $t = Pinto::Tester->new; $t->run_ok( Pull => { targets => $pkg } ); $t->run_ok( List => {} ); $t->stdout_like( qr{$pkg}, "$pkg registered ok" ); } #------------------------------------------------------------------------------ # Module::Metadata mistakenly thinks that EU::MM has a "version" package. # See https://github.com/thaljef/Pinto/issues/204 for all the gory details #------------------------------------------------------------------------------ { my $t = Pinto::Tester->new; $t->run_ok( Pull => { targets => 'version@0.9912' } ); $t->registration_ok('JPEACOCK/version-0.9912/version~0.9912'); $t->run_ok( Pull => { targets => 'ExtUtils::MakeMaker@7.04' } ); $t->registration_ok('JPEACOCK/version-0.9912/version~0.9912'); } done_testing; Pinto-0.14/xt/release/03-stratopan-live.t000644 000766 000024 00000005171 13141540305 020235 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use URI; use lib 't/lib'; use Pinto::Tester; use Pinto::Constants qw(:stratopan); #------------------------------------------------------------------------------ note("This test requires a live internet connection to contact stratopan"); #------------------------------------------------------------------------------ my $stratopan_host = $PINTO_STRATOPAN_CPAN_URI->host; #------------------------------------------------------------------------------ subtest 'Pull precise version' => sub { my $t = Pinto::Tester->new(init_args => {recurse => 0}); $t->run_ok( Pull => { targets => 'Pinto==0.094'} ); $t->registration_ok('THALJEF/Pinto-0.094/Pinto~0.094'); my $target = Pinto::Target->new('THALJEF/Pinto-0.094.tar.gz'); my $dist = $t->get_distribution(target => $target); my $uri = URI->new($dist->source); is $uri->host, $stratopan_host, 'Dist came from Stratopan'; }; #------------------------------------------------------------------------------ subtest 'Pull version range' => sub { my $t = Pinto::Tester->new(init_args => {recurse => 0}); $t->run_ok( Pull => { targets => 'Pinto>=0.084,!=0.085,<0.087'} ); $t->registration_ok('THALJEF/Pinto-0.086/Pinto~0.086'); my $target = Pinto::Target->new('THALJEF/Pinto-0.086.tar.gz'); my $dist = $t->get_distribution(target => $target); my $uri = URI->new($dist->source); is $uri->host, $stratopan_host, 'Dist came from Stratopan'; }; #------------------------------------------------------------------------------ subtest 'Pull development version' => sub { my $t = Pinto::Tester->new(init_args => {recurse => 0}); $t->run_ok( Pull => { targets => 'Pinto==0.097_01'} ); $t->registration_ok('THALJEF/Pinto-0.097_01/Pinto~0.097_01'); my $target = Pinto::Target->new('THALJEF/Pinto-0.097_01.tar.gz'); my $dist = $t->get_distribution(target => $target); my $uri = URI->new($dist->source); is $uri->host, $stratopan_host, 'Dist came from Stratopan'; }; #------------------------------------------------------------------------------ subtest 'Pull distribution' => sub { my $t = Pinto::Tester->new(init_args => {recurse => 0}); $t->run_ok( Pull => { targets => 'THALJEF/Pinto-0.065'} ); $t->registration_ok('THALJEF/Pinto-0.065/Pinto~0.065'); my $target = Pinto::Target->new('THALJEF/Pinto-0.065.tar.gz'); my $dist = $t->get_distribution(target => $target); my $uri = URI->new($dist->source); is $uri->host, $stratopan_host, 'Dist came from Stratopan'; }; #------------------------------------------------------------------------------ done_testing; Pinto-0.14/xt/release/99-memory-cycle.t000644 000766 000024 00000002145 13141540305 017707 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use Test::Memory::Cycle; use lib 't/lib'; use Pinto::Tester; #------------------------------------------------------------------------------ note("This test requires a live internet connection to pull stuff from CPAN"); #------------------------------------------------------------------------------ { my $t = Pinto::Tester->new; my $result = $t->run_ok( Pull => { targets => 'Perl::Critic' } ); memory_cycle_ok( $t->pinto ); memory_cycle_ok($result); } #------------------------------------------------------------------------------ { # Throwable::Error has a memory leak. I've submitted a patch (and patched # my own installation) but it hasn't been released yet. my $t = Pinto::Tester->new; no warnings qw(once redefine); local *Pinto::ArchiveExtractor::requires = sub { die 'FAKE ERROR' }; my $result = $t->run_ok( Pull => { targets => 'Perl::Critic' } ); memory_cycle_ok( $t->pinto ); memory_cycle_ok($result); } #------------------------------------------------------------------------------ done_testing; Pinto-0.14/xt/release/distmeta.t000644 000766 000024 00000000172 13141540305 016653 0ustar00jeffstaff000000 000000 #!perl # This file was automatically generated by Dist::Zilla::Plugin::MetaTests. use Test::CPAN::Meta; meta_yaml_ok(); Pinto-0.14/xt/help/50-manual_cmd.t000644 000766 000024 00000003015 13141540305 016672 0ustar00jeffstaff000000 000000 #!perl use warnings; use strict; use Test::More; use Test::Trap qw| trap $trap :flow :stderr(systemsafe) :stdout(systemsafe) :warn |; #------------------------------------------------------------------------------- subtest 'manual for valid command' => sub { run_cmd_and_trap( 'manual', 'init' ); like( $trap->stdout, qr/creates a new repository/i, qq['init' manual page returned] ); }; #------------------------------------------------------------------------------- subtest 'manual for invalid command' => sub { run_cmd_and_trap( 'manual', 'foobar' ); like( $trap->stdout, qr/unrecognized command/i, qq['foobar' doesn't exist] ); unlike( $trap->stdout, qr/App::Cmd::Command::commands/, qq[A wrong manpage is not returned] ); TODO: { local $TODO = 'Difficult to subvert App::Cmd here'; unlike( $trap->stdout, qr/Usage:/, qq[Usage is not attempted to be printed] ); }; }; #------------------------------------------------------------------------------- # (App::Cmd::Tester doesn't capture pod2usage() pager output) sub run_cmd_and_trap { my (@args) = @_; my $program_name = 'pinto'; local $ENV{PINTO_HOME} = undef; my @cmd = ( "perl", "-Ilib", "bin/${program_name}" ); diag("\$ $program_name @args"); my @r = trap { system( @cmd, @args ) }; return @r; } #------------------------------------------------------------------------------- done_testing; Pinto-0.14/xt/author/pod-syntax.t000644 000766 000024 00000000252 13141540305 017030 0ustar00jeffstaff000000 000000 #!perl # This file was automatically generated by Dist::Zilla::Plugin::PodSyntaxTests. use strict; use warnings; use Test::More; use Test::Pod 1.41; all_pod_files_ok(); Pinto-0.14/xt/author/test-version.t000644 000766 000024 00000000637 13141540305 017373 0ustar00jeffstaff000000 000000 use strict; use warnings; use Test::More; # generated by Dist::Zilla::Plugin::Test::Version 1.09 use Test::Version; my @imports = qw( version_all_ok ); my $params = { is_strict => 0, has_version => 1, multiple => 0, }; push @imports, $params if version->parse( $Test::Version::VERSION ) >= version->parse('1.002'); Test::Version->import(@imports); version_all_ok; done_testing; Pinto-0.14/t/00-compile.t000644 000766 000024 00000015334 13141540305 015104 0ustar00jeffstaff000000 000000 use 5.006; use strict; use warnings; # this test was generated with Dist::Zilla::Plugin::Test::Compile 2.056 use Test::More; plan tests => 137 + ($ENV{AUTHOR_TESTING} ? 1 : 0); my @module_files = ( 'App/Pinto.pm', 'App/Pinto/Command.pm', 'App/Pinto/Command/add.pm', 'App/Pinto/Command/clean.pm', 'App/Pinto/Command/copy.pm', 'App/Pinto/Command/default.pm', 'App/Pinto/Command/delete.pm', 'App/Pinto/Command/diff.pm', 'App/Pinto/Command/help.pm', 'App/Pinto/Command/init.pm', 'App/Pinto/Command/install.pm', 'App/Pinto/Command/kill.pm', 'App/Pinto/Command/list.pm', 'App/Pinto/Command/lock.pm', 'App/Pinto/Command/log.pm', 'App/Pinto/Command/look.pm', 'App/Pinto/Command/manual.pm', 'App/Pinto/Command/merge.pm', 'App/Pinto/Command/migrate.pm', 'App/Pinto/Command/new.pm', 'App/Pinto/Command/nop.pm', 'App/Pinto/Command/pin.pm', 'App/Pinto/Command/props.pm', 'App/Pinto/Command/pull.pm', 'App/Pinto/Command/register.pm', 'App/Pinto/Command/rename.pm', 'App/Pinto/Command/reset.pm', 'App/Pinto/Command/revert.pm', 'App/Pinto/Command/roots.pm', 'App/Pinto/Command/stacks.pm', 'App/Pinto/Command/statistics.pm', 'App/Pinto/Command/thanks.pm', 'App/Pinto/Command/unlock.pm', 'App/Pinto/Command/unpin.pm', 'App/Pinto/Command/unregister.pm', 'App/Pinto/Command/update.pm', 'App/Pinto/Command/verify.pm', 'Pinto.pm', 'Pinto/Action.pm', 'Pinto/Action/Add.pm', 'Pinto/Action/Clean.pm', 'Pinto/Action/Copy.pm', 'Pinto/Action/Default.pm', 'Pinto/Action/Delete.pm', 'Pinto/Action/Diff.pm', 'Pinto/Action/Install.pm', 'Pinto/Action/Kill.pm', 'Pinto/Action/List.pm', 'Pinto/Action/Lock.pm', 'Pinto/Action/Log.pm', 'Pinto/Action/Look.pm', 'Pinto/Action/Merge.pm', 'Pinto/Action/New.pm', 'Pinto/Action/Nop.pm', 'Pinto/Action/Pin.pm', 'Pinto/Action/Props.pm', 'Pinto/Action/Pull.pm', 'Pinto/Action/Register.pm', 'Pinto/Action/Rename.pm', 'Pinto/Action/Reset.pm', 'Pinto/Action/Revert.pm', 'Pinto/Action/Roots.pm', 'Pinto/Action/Stacks.pm', 'Pinto/Action/Statistics.pm', 'Pinto/Action/Unlock.pm', 'Pinto/Action/Unpin.pm', 'Pinto/Action/Unregister.pm', 'Pinto/Action/Update.pm', 'Pinto/Action/Verify.pm', 'Pinto/ArchiveUnpacker.pm', 'Pinto/Chrome.pm', 'Pinto/Chrome/Net.pm', 'Pinto/Chrome/Term.pm', 'Pinto/Config.pm', 'Pinto/Constants.pm', 'Pinto/Database.pm', 'Pinto/Difference.pm', 'Pinto/DifferenceEntry.pm', 'Pinto/Editor.pm', 'Pinto/Editor/Clip.pm', 'Pinto/Editor/Edit.pm', 'Pinto/Exception.pm', 'Pinto/Globals.pm', 'Pinto/IndexReader.pm', 'Pinto/IndexWriter.pm', 'Pinto/Initializer.pm', 'Pinto/Locator.pm', 'Pinto/Locator/Mirror.pm', 'Pinto/Locator/Multiplex.pm', 'Pinto/Locator/Stratopan.pm', 'Pinto/Locker.pm', 'Pinto/Migrator.pm', 'Pinto/ModlistWriter.pm', 'Pinto/PackageExtractor.pm', 'Pinto/PrerequisiteWalker.pm', 'Pinto/Remote.pm', 'Pinto/Remote/Action.pm', 'Pinto/Remote/Action/Add.pm', 'Pinto/Remote/Action/Install.pm', 'Pinto/Remote/Result.pm', 'Pinto/Repository.pm', 'Pinto/Result.pm', 'Pinto/RevisionWalker.pm', 'Pinto/Role/Committable.pm', 'Pinto/Role/Installer.pm', 'Pinto/Role/PauseConfig.pm', 'Pinto/Role/Plated.pm', 'Pinto/Role/Puller.pm', 'Pinto/Role/Schema/Result.pm', 'Pinto/Role/Transactional.pm', 'Pinto/Role/UserAgent.pm', 'Pinto/Schema.pm', 'Pinto/Schema/Result/Ancestry.pm', 'Pinto/Schema/Result/Distribution.pm', 'Pinto/Schema/Result/Package.pm', 'Pinto/Schema/Result/Prerequisite.pm', 'Pinto/Schema/Result/Registration.pm', 'Pinto/Schema/Result/Revision.pm', 'Pinto/Schema/Result/Stack.pm', 'Pinto/Schema/ResultSet/Distribution.pm', 'Pinto/Schema/ResultSet/Package.pm', 'Pinto/Schema/ResultSet/Registration.pm', 'Pinto/Server.pm', 'Pinto/Server/Responder.pm', 'Pinto/Server/Responder/Action.pm', 'Pinto/Server/Responder/File.pm', 'Pinto/Server/Router.pm', 'Pinto/Shell.pm', 'Pinto/Statistics.pm', 'Pinto/Store.pm', 'Pinto/Target.pm', 'Pinto/Target/Distribution.pm', 'Pinto/Target/Package.pm', 'Pinto/Types.pm', 'Pinto/Util.pm' ); my @scripts = ( 'bin/pinto', 'bin/pintod' ); # fake home for cpan-testers use File::Temp; local $ENV{HOME} = File::Temp::tempdir( CLEANUP => 1 ); my @switches = ( -d 'blib' ? '-Mblib' : '-Ilib', ); use File::Spec; use IPC::Open3; use IO::Handle; open my $stdin, '<', File::Spec->devnull or die "can't open devnull: $!"; my @warnings; for my $lib (@module_files) { # see L my $stderr = IO::Handle->new; diag('Running: ', join(', ', map { my $str = $_; $str =~ s/'/\\'/g; q{'} . $str . q{'} } $^X, @switches, '-e', "require q[$lib]")) if $ENV{PERL_COMPILE_TEST_DEBUG}; my $pid = open3($stdin, '>&STDERR', $stderr, $^X, @switches, '-e', "require q[$lib]"); binmode $stderr, ':crlf' if $^O eq 'MSWin32'; my @_warnings = <$stderr>; waitpid($pid, 0); is($?, 0, "$lib loaded ok"); shift @_warnings if @_warnings and $_warnings[0] =~ /^Using .*\bblib/ and not eval { require blib; blib->VERSION('1.01') }; if (@_warnings) { warn @_warnings; push @warnings, @_warnings; } } foreach my $file (@scripts) { SKIP: { open my $fh, '<', $file or warn("Unable to open $file: $!"), next; my $line = <$fh>; close $fh and skip("$file isn't perl", 1) unless $line =~ /^#!\s*(?:\S*perl\S*)((?:\s+-\w*)*)(?:\s*#.*)?$/; @switches = (@switches, split(' ', $1)) if $1; my $stderr = IO::Handle->new; diag('Running: ', join(', ', map { my $str = $_; $str =~ s/'/\\'/g; q{'} . $str . q{'} } $^X, @switches, '-c', $file)) if $ENV{PERL_COMPILE_TEST_DEBUG}; my $pid = open3($stdin, '>&STDERR', $stderr, $^X, @switches, '-c', $file); binmode $stderr, ':crlf' if $^O eq 'MSWin32'; my @_warnings = <$stderr>; waitpid($pid, 0); is($?, 0, "$file compiled ok"); shift @_warnings if @_warnings and $_warnings[0] =~ /^Using .*\bblib/ and not eval { require blib; blib->VERSION('1.01') }; # in older perls, -c output is simply the file portion of the path being tested if (@_warnings = grep { !/\bsyntax OK$/ } grep { chomp; $_ ne (File::Spec->splitpath($file))[2] } @_warnings) { warn @_warnings; push @warnings, @_warnings; } } } is(scalar(@warnings), 0, 'no warnings found') or diag 'got warnings: ', ( Test::More->can('explain') ? Test::More::explain(\@warnings) : join("\n", '', @warnings) ) if $ENV{AUTHOR_TESTING}; Pinto-0.14/t/00-report-prereqs.dd000644 000766 000024 00000021105 13141540305 016563 0ustar00jeffstaff000000 000000 do { my $x = { 'configure' => { 'requires' => { 'ExtUtils::MakeMaker' => '6.64', 'perl' => '5.008' }, 'suggests' => { 'JSON::PP' => '2.27300' } }, 'develop' => { 'requires' => { 'Test::CPAN::Meta' => '0', 'Test::Memory::Cycle' => '0', 'Test::More' => '0', 'Test::Pod' => '1.41', 'Test::Trap' => '0', 'Test::Version' => '1', 'lib' => '0' } }, 'runtime' => { 'requires' => { 'App::Cmd' => '0.323', 'App::Cmd::Command::help' => '0', 'App::Cmd::Setup' => '0', 'Archive::Extract' => '0.68', 'Archive::Tar' => '0', 'Authen::Simple::Passwd' => '0', 'CPAN::Checksums' => '0', 'CPAN::DistnameInfo' => '0', 'CPAN::Meta' => '0', 'CPAN::Meta::Requirements' => '0', 'Carp' => '0', 'Class::Load' => '0', 'Cwd' => '0', 'Cwd::Guard' => '0', 'DBD::SQLite' => '1.33', 'DBIx::Class' => '0.08200', 'DBIx::Class::Core' => '0', 'DBIx::Class::ResultSet' => '0', 'DBIx::Class::Schema' => '0', 'DateTime' => '0', 'DateTime::TimeZone' => '0', 'DateTime::TimeZone::Local::Unix' => '0', 'DateTime::TimeZone::OffsetOnly' => '0', 'Devel::StackTrace' => '0', 'Digest::MD5' => '0', 'Digest::SHA' => '0', 'Dist::Metadata' => '0.926', 'Encode' => '0', 'Exporter' => '0', 'File::Copy' => '0', 'File::Find' => '0', 'File::HomeDir' => '0', 'File::NFSLock' => '0', 'File::Spec' => '0', 'File::Temp' => '0', 'File::Which' => '0', 'Getopt::Long' => '0', 'HTTP::Date' => '0', 'HTTP::Request::Common' => '0', 'HTTP::Status' => '0', 'IO::File' => '0', 'IO::Handle' => '0', 'IO::Interactive' => '0', 'IO::Pipe' => '0', 'IO::Prompt' => '0', 'IO::Select' => '0', 'IO::String' => '0', 'IO::Zlib' => '0', 'JSON' => '0', 'JSON::PP' => '2.27103', 'LWP::UserAgent' => '0', 'List::MoreUtils' => '0', 'List::Util' => '0', 'Module::CoreList' => '5.20170720', 'Module::Metadata' => '1.000031', 'Moose' => '0', 'Moose::Role' => '0', 'MooseX::Aliases' => '0', 'MooseX::ClassAttribute' => '0.27', 'MooseX::Configuration' => '0', 'MooseX::MarkAsMethods' => '0', 'MooseX::NonMoose' => '0', 'MooseX::SetOnce' => '0', 'MooseX::StrictConstructor' => '0', 'MooseX::Types' => '0', 'MooseX::Types::Moose' => '0', 'Path::Class' => '0', 'Path::Class::Dir' => '0', 'Path::Class::File' => '0', 'Plack' => '1.0028', 'Plack::MIME' => '0', 'Plack::Middleware::Auth::Basic' => '0', 'Plack::Request' => '0', 'Plack::Response' => '0', 'Plack::Runner' => '0', 'Pod::Usage' => '0', 'Proc::Fork' => '0', 'Proc::Terminator' => '0', 'Readonly' => '0', 'Router::Simple' => '0', 'Scalar::Util' => '0', 'Starman' => '0.3014', 'String::Format' => '0', 'Term::ANSIColor' => '2.02', 'Throwable::Error' => '0.200005', 'Try::Tiny' => '0', 'URI' => '0', 'URI::Escape' => '3.31', 'URI::file' => '0', 'UUID::Tiny' => '0', 'Variable::Magic' => '0.57', 'base' => '0', 'overload' => '0', 'perl' => '5.008', 'strict' => '0', 'utf8' => '0', 'version' => '0', 'warnings' => '0' } }, 'test' => { 'recommends' => { 'CPAN::Meta' => '2.120900' }, 'requires' => { 'Apache::Htpasswd' => '0', 'Capture::Tiny' => '0', 'ExtUtils::MakeMaker' => '0', 'File::Spec' => '0', 'File::Temp' => '0', 'FindBin' => '0', 'HTTP::Body' => '0', 'HTTP::Response' => '0', 'HTTP::Server::PSGI' => '0', 'IO::Handle' => '0', 'IPC::Open3' => '0', 'Module::Faker::Dist' => '0.014', 'Plack::Test' => '0', 'Test::Builder::Module' => '0', 'Test::Exception' => '0', 'Test::File' => '0', 'Test::LWP::UserAgent' => '0.018', 'Test::More' => '0.96', 'Test::TCP' => '0', 'blib' => '1.01', 'lib' => '0', 'perl' => '5.008' } } }; $x; }Pinto-0.14/t/00-report-prereqs.t000644 000766 000024 00000013461 13141540305 016445 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; # This test was generated by Dist::Zilla::Plugin::Test::ReportPrereqs 0.027 use Test::More tests => 1; use ExtUtils::MakeMaker; use File::Spec; # from $version::LAX my $lax_version_re = qr/(?: undef | (?: (?:[0-9]+) (?: \. | (?:\.[0-9]+) (?:_[0-9]+)? )? | (?:\.[0-9]+) (?:_[0-9]+)? ) | (?: v (?:[0-9]+) (?: (?:\.[0-9]+)+ (?:_[0-9]+)? )? | (?:[0-9]+)? (?:\.[0-9]+){2,} (?:_[0-9]+)? ) )/x; # hide optional CPAN::Meta modules from prereq scanner # and check if they are available my $cpan_meta = "CPAN::Meta"; my $cpan_meta_pre = "CPAN::Meta::Prereqs"; my $HAS_CPAN_META = eval "require $cpan_meta; $cpan_meta->VERSION('2.120900')" && eval "require $cpan_meta_pre"; ## no critic # Verify requirements? my $DO_VERIFY_PREREQS = 1; sub _max { my $max = shift; $max = ( $_ > $max ) ? $_ : $max for @_; return $max; } sub _merge_prereqs { my ($collector, $prereqs) = @_; # CPAN::Meta::Prereqs object if (ref $collector eq $cpan_meta_pre) { return $collector->with_merged_prereqs( CPAN::Meta::Prereqs->new( $prereqs ) ); } # Raw hashrefs for my $phase ( keys %$prereqs ) { for my $type ( keys %{ $prereqs->{$phase} } ) { for my $module ( keys %{ $prereqs->{$phase}{$type} } ) { $collector->{$phase}{$type}{$module} = $prereqs->{$phase}{$type}{$module}; } } } return $collector; } my @include = qw( DBIx::Class DBD::SQLite ); my @exclude = qw( ); # Add static prereqs to the included modules list my $static_prereqs = do './t/00-report-prereqs.dd'; # Merge all prereqs (either with ::Prereqs or a hashref) my $full_prereqs = _merge_prereqs( ( $HAS_CPAN_META ? $cpan_meta_pre->new : {} ), $static_prereqs ); # Add dynamic prereqs to the included modules list (if we can) my ($source) = grep { -f } 'MYMETA.json', 'MYMETA.yml'; my $cpan_meta_error; if ( $source && $HAS_CPAN_META && (my $meta = eval { CPAN::Meta->load_file($source) } ) ) { $full_prereqs = _merge_prereqs($full_prereqs, $meta->prereqs); } else { $cpan_meta_error = $@; # capture error from CPAN::Meta->load_file($source) $source = 'static metadata'; } my @full_reports; my @dep_errors; my $req_hash = $HAS_CPAN_META ? $full_prereqs->as_string_hash : $full_prereqs; # Add static includes into a fake section for my $mod (@include) { $req_hash->{other}{modules}{$mod} = 0; } for my $phase ( qw(configure build test runtime develop other) ) { next unless $req_hash->{$phase}; next if ($phase eq 'develop' and not $ENV{AUTHOR_TESTING}); for my $type ( qw(requires recommends suggests conflicts modules) ) { next unless $req_hash->{$phase}{$type}; my $title = ucfirst($phase).' '.ucfirst($type); my @reports = [qw/Module Want Have/]; for my $mod ( sort keys %{ $req_hash->{$phase}{$type} } ) { next if $mod eq 'perl'; next if grep { $_ eq $mod } @exclude; my $file = $mod; $file =~ s{::}{/}g; $file .= ".pm"; my ($prefix) = grep { -e File::Spec->catfile($_, $file) } @INC; my $want = $req_hash->{$phase}{$type}{$mod}; $want = "undef" unless defined $want; $want = "any" if !$want && $want == 0; my $req_string = $want eq 'any' ? 'any version required' : "version '$want' required"; if ($prefix) { my $have = MM->parse_version( File::Spec->catfile($prefix, $file) ); $have = "undef" unless defined $have; push @reports, [$mod, $want, $have]; if ( $DO_VERIFY_PREREQS && $HAS_CPAN_META && $type eq 'requires' ) { if ( $have !~ /\A$lax_version_re\z/ ) { push @dep_errors, "$mod version '$have' cannot be parsed ($req_string)"; } elsif ( ! $full_prereqs->requirements_for( $phase, $type )->accepts_module( $mod => $have ) ) { push @dep_errors, "$mod version '$have' is not in required range '$want'"; } } } else { push @reports, [$mod, $want, "missing"]; if ( $DO_VERIFY_PREREQS && $type eq 'requires' ) { push @dep_errors, "$mod is not installed ($req_string)"; } } } if ( @reports ) { push @full_reports, "=== $title ===\n\n"; my $ml = _max( map { length $_->[0] } @reports ); my $wl = _max( map { length $_->[1] } @reports ); my $hl = _max( map { length $_->[2] } @reports ); if ($type eq 'modules') { splice @reports, 1, 0, ["-" x $ml, "", "-" x $hl]; push @full_reports, map { sprintf(" %*s %*s\n", -$ml, $_->[0], $hl, $_->[2]) } @reports; } else { splice @reports, 1, 0, ["-" x $ml, "-" x $wl, "-" x $hl]; push @full_reports, map { sprintf(" %*s %*s %*s\n", -$ml, $_->[0], $wl, $_->[1], $hl, $_->[2]) } @reports; } push @full_reports, "\n"; } } } if ( @full_reports ) { diag "\nVersions for all modules listed in $source (including optional ones):\n\n", @full_reports; } if ( $cpan_meta_error || @dep_errors ) { diag "\n*** WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING ***\n"; } if ( $cpan_meta_error ) { my ($orig_source) = grep { -f } 'MYMETA.json', 'MYMETA.yml'; diag "\nCPAN::Meta->load_file('$orig_source') failed with: $cpan_meta_error\n"; } if ( @dep_errors ) { diag join("\n", "\nThe following REQUIRED prerequisites were not satisfied:\n", @dep_errors, "\n" ); } pass; # vim: ts=4 sts=4 sw=4 et: Pinto-0.14/t/01-common/000755 000766 000024 00000000000 13141540305 014552 5ustar00jeffstaff000000 000000 Pinto-0.14/t/02-bowels/000755 000766 000024 00000000000 13141540305 014556 5ustar00jeffstaff000000 000000 Pinto-0.14/t/03-remote/000755 000766 000024 00000000000 13141540305 014557 5ustar00jeffstaff000000 000000 Pinto-0.14/t/04-server/000755 000766 000024 00000000000 13141540305 014573 5ustar00jeffstaff000000 000000 Pinto-0.14/t/lib/000755 000766 000024 00000000000 13141540305 013612 5ustar00jeffstaff000000 000000 Pinto-0.14/t/lib/Pinto/000755 000766 000024 00000000000 13141540305 014703 5ustar00jeffstaff000000 000000 Pinto-0.14/t/lib/Pinto/Server/000755 000766 000024 00000000000 13141540305 016151 5ustar00jeffstaff000000 000000 Pinto-0.14/t/lib/Pinto/Tester/000755 000766 000024 00000000000 13141540305 016151 5ustar00jeffstaff000000 000000 Pinto-0.14/t/lib/Pinto/Tester.pm000644 000766 000024 00000037475 13141540305 016527 0ustar00jeffstaff000000 000000 # ABSTRACT: A class for testing a Pinto repository package Pinto::Tester; use Moose; use MooseX::NonMoose; use MooseX::StrictConstructor; use MooseX::Types::Moose qw(ScalarRef HashRef); use Test::Exception; use Pinto; use Pinto::Globals; use Pinto::Initializer; use Pinto::Chrome::Term; use Pinto::Constants qw(:all); use Pinto::Tester::Util qw(:all); use Pinto::Types qw(Uri Dir); use Pinto::Util qw(:all); use overload (q{""} => 'to_string'); #------------------------------------------------------------------------------ # VERSION #------------------------------------------------------------------------------ extends qw(Test::Builder::Module); #------------------------------------------------------------------------------ BEGIN { # Clear any user settings delete @ENV{@PINTO_ENVIRONMENT_VARIABLES}; # So we don't prompt for commit messages $Pinto::Globals::is_interactive = 0; # So the username/author is constant $Pinto::Globals::current_author_id = 'AUTHOR'; $Pinto::Globals::current_username = 'USERNAME'; } #------------------------------------------------------------------------------ has pinto_args => ( isa => HashRef, default => sub { {} }, traits => ['Hash'], handles => { pinto_args => 'elements' }, lazy => 1, ); has init_args => ( isa => HashRef, default => sub { {} }, traits => ['Hash'], handles => { init_args => 'elements' }, lazy => 1, ); has root => ( is => 'ro', isa => Dir, default => sub { tempdir }, lazy => 1, ); has pinto => ( is => 'ro', isa => 'Pinto', builder => '_build_pinto', lazy => 1, ); has repo => ( is => 'ro', isa => 'Pinto::Repository', handles => [ qw(get_stack get_stack_maybe get_distribution) ], default => sub { $_[0]->pinto->repo }, init_arg => undef, lazy => 1, ); has outstr => ( is => 'rw', isa => ScalarRef, default => sub { my $str = ''; return \$str }, ); has errstr => ( is => 'rw', isa => ScalarRef, default => sub { my $str = ''; return \$str }, ); has tb => ( is => 'ro', isa => 'Test::Builder', handles => [qw(ok is_eq isnt_eq diag like unlike)], default => sub { my $tb = __PACKAGE__->builder; $tb->level(2); return $tb }, init_arg => undef, ); #------------------------------------------------------------------------------ # This force the repository to be constructed immediately. Just # making the 'pinto' attribute non-lazy didn't work, probably due to # dependencies on other attributes. sub BUILD { $_[0]->pinto } #------------------------------------------------------------------------------ sub _build_pinto { my ($self) = @_; my $chrome = Pinto::Chrome::Term->new( verbose => 2, color => 0, stdout => $self->outstr, stderr => $self->errstr, ); my %defaults = ( root => $self->root ); Pinto::Initializer->new->init( %defaults, $self->init_args ) unless $self->root->children; # Skip init if repo exists return Pinto->new( %defaults, chrome => $chrome, $self->pinto_args ); } #------------------------------------------------------------------------------ sub path_exists_ok { my ( $self, $path, $name ) = @_; $path = ref $path eq 'ARRAY' ? $self->root->file( @{$path} ) : $path; $name ||= "Path $path should exist"; $self->ok( -e $path, $name ); return; } #------------------------------------------------------------------------------ sub path_not_exists_ok { my ( $self, $path, $name ) = @_; $path = ref $path eq 'ARRAY' ? $self->root->file( @{$path} ) : $path; $name ||= "Path $path should not exist"; $self->ok( !-e $path, $name ); return; } #------------------------------------------------------------------------------ sub run_ok { my ( $self, $action_name, $args, $test_name ) = @_; local $Pinto::Globals::is_interactive = 0; local $Test::Builder::Level = $Test::Builder::Level + 1; $self->clear_buffers; my $result = $self->pinto->run( $action_name, %{$args} ); $self->result_ok( $result, $test_name ); return $result; } #------------------------------------------------------------------------------ sub run_throws_ok { my ( $self, $action_name, $args, $error_regex, $test_name ) = @_; local $Pinto::Globals::is_interactive = 0; local $Test::Builder::Level = $Test::Builder::Level + 1; $self->clear_buffers; my $result = $self->pinto->run( $action_name, %{$args} ); $self->result_not_ok( $result, $test_name ); my $ok = $self->like( $result->to_string, $error_regex, $test_name ); $self->diag_stderr if not $ok; return $ok; } #------------------------------------------------------------------------------ sub registration_ok { my ( $self, $reg_spec ) = @_; my ( $author, $dist_archive, $pkg_name, $pkg_ver, $stack_name, $is_pinned ) = parse_reg_spec($reg_spec); my $author_dir = Pinto::Util::author_dir($author); my $dist_path = $author_dir->file($dist_archive)->as_foreign('Unix'); my $stack = $self->get_stack($stack_name); my $where = { revision => $stack->head->id, 'package.name' => $pkg_name }; my $attrs = { prefetch => { package => 'distribution' } }; my $reg = $self->pinto->repo->db->schema->find_registration( $where, $attrs ); return $self->ok( 0, "Package $pkg_name is not on stack $stack_name" ) if not $reg; #------------------------------------- # Test package object... my $pkg = $reg->package; $self->is_eq( $pkg->name, $pkg_name, "Package has correct name" ); $self->is_eq( $pkg->version, $pkg_ver, "Package has correct version" ); # Test distribution object... my $dist = $reg->distribution; $self->is_eq( $dist->path, $dist_path, "Distribution has correct dist path" ); # Test pins... $self->ok( $reg->is_pinned, "Registration $reg should be pinned" ) if $is_pinned; $self->ok( !$reg->is_pinned, "Registration $reg should not be pinned" ) if not $is_pinned; #------------------------------------- # Test file paths... local $Test::Builder::Level = $Test::Builder::Level + 1; $self->path_exists_ok( [ qw(authors id), $author_dir, 'CHECKSUMS' ] ); # Reach file through the stack's authors/id directory $self->path_exists_ok( $dist->native_path( $stack->authors_dir->subdir('id') ) ); # Reach file through the top authors/id directory $self->path_exists_ok( $dist->native_path ); return; } #------------------------------------------------------------------------------ sub registration_not_ok { my ( $self, $reg_spec ) = @_; my ( $author, $archive, $pkg_name, $pkg_ver, $stack_name, $is_pinned ) = parse_reg_spec($reg_spec); my $author_dir = Pinto::Util::author_dir($author); my $dist_path = $author_dir->file($archive)->as_foreign('Unix'); my $stack = $self->get_stack($stack_name); my $where = { stack => $stack->id, 'package.name' => $pkg_name, 'distribution.author' => $author, 'distribution.archive' => $archive }; my $reg = $self->pinto->repo->db->schema->search_registration($where); return $self->ok( 1, "Registration $reg_spec should not exist" ) if not $reg; } #------------------------------------------------------------------------------ sub result_ok { my ( $self, $result ) = @_; my $test_name = 'Result indicates action was succesful'; my $ok = $self->ok( $result->was_successful, $test_name ); $self->diag_stderr if not $ok; return; } #------------------------------------------------------------------------------ sub result_not_ok { my ( $self, $result ) = @_; my $test_name = 'Result indicates action was not succesful'; my $ok = $self->ok( !$result->was_successful, $test_name ); $self->diag_stderr if not $ok; return; } #------------------------------------------------------------------------------ sub result_changed_ok { my ( $self, $result ) = @_; my $test_name = 'Result indicates changes were made'; my $ok = $self->ok( $result->made_changes, $test_name ); $self->diag_stderr if not $ok; return; } #------------------------------------------------------------------------------ sub result_not_changed_ok { my ( $self, $result ) = @_; my $test_name = 'Result indicates changes were not made'; my $ok = $self->ok( !$result->made_changes, $test_name ); $self->diag_stderr if not $ok; return; } #------------------------------------------------------------------------------ sub repository_clean_ok { my ($self) = @_; my $dists = $self->pinto->repo->distribution_count; $self->is_eq( $dists, 0, 'Repo has no distributions' ); my $pkgs = $self->pinto->repo->package_count; $self->is_eq( $pkgs, 0, 'Repo has no packages' ); my @stacks = $self->pinto->repo->get_all_stacks; $self->is_eq( scalar @stacks, 1, 'Repo has only one stack' ); my $stack = $stacks[0]; $self->is_eq( $stack->name, 'master', 'The stack is called "master"' ); $self->is_eq( $stack->is_default, 1, 'The stack is marked as default' ); my $authors_id_dir = $self->pinto->repo->config->authors_id_dir; $self->ok( !-e $authors_id_dir, 'The authors/id dir should be gone' ); return; } #------------------------------------------------------------------------------ sub diag_stderr { my ($self) = @_; my $errs = ${ $self->errstr }; $self->diag('Log messages are...'); $self->diag($errs); } #------------------------------------------------------------------------------ sub stdout_like { my ( $self, $rx, $name ) = @_; $name ||= 'stdout output matches'; $self->like( ${ $self->outstr }, $rx, $name ); return; } #------------------------------------------------------------------------------ sub stdout_unlike { my ( $self, $rx, $name ) = @_; $name ||= 'stdout does not match'; $self->unlike( ${ $self->outstr }, $rx, $name ); return; } #------------------------------------------------------------------------------ sub stderr_like { my ( $self, $rx, $name ) = @_; $name ||= 'stderr output matches'; $self->like( ${ $self->errstr }, $rx, $name ); return; } #------------------------------------------------------------------------------ sub stderr_unlike { my ( $self, $rx, $name ) = @_; $name ||= 'stderr does not match'; $self->unlike( ${ $self->errstr }, $rx, $name ); return; } #------------------------------------------------------------------------------ sub stack_is_default_ok { my ( $self, $stack_name, $test_name ) = @_; $test_name ||= ''; local $Test::Builder::Level = $Test::Builder::Level + 1; my $stack = $self->get_stack($stack_name); $self->ok( $stack->is_default, "Stack $stack is marked as default $test_name" ); my $stack_modules_dir = $stack->modules_dir; my $repo_modules_dir = $self->pinto->repo->config->modules_dir; $self->ok( -e $repo_modules_dir, "The modules dir exists $test_name" ) or return; my $inode1 = $repo_modules_dir->stat->ino; my $inode2 = $stack_modules_dir->stat->ino; $self->is_eq( $inode1, $inode2, "The modules dir is linked to $stack $test_name" ); return $stack; } #------------------------------------------------------------------------------ sub stack_is_not_default_ok { my ( $self, $stack_name, $test_name ) = @_; my $stack = $self->get_stack($stack_name); $self->ok( !$stack->is_default, "Stack $stack not marked as default" ); my $stack_modules_dir = $stack->modules_dir; my $repo_modules_dir = $self->pinto->repo->config->modules_dir; -l $repo_modules_dir or return; # Might not be any default my $inode1 = $repo_modules_dir->stat->ino; my $inode2 = $stack_modules_dir->stat->ino; $test_name ||= "The modules dir is not linked to stack $stack"; $self->isnt_eq( $inode1, $inode2, $test_name ); return $stack; } #------------------------------------------------------------------------------ sub no_default_stack_ok { my ($self) = @_; my $stack = eval { $self->get_stack }; $self->ok( !$stack, "No stack should be marked as default" ); my $modules_dir = $self->pinto->repo->config->modules_dir; $self->ok( !-l $modules_dir, "The modules dir is not linked anywhere" ); return; } #------------------------------------------------------------------------------ sub stack_exists_ok { my ( $self, $stack_name ) = @_; my $stack = $self->get_stack($stack_name); $self->ok( $stack, "Stack $stack_name should exist in DB" ); my $stack_dir = $self->pinto->repo->config->stacks_dir->subdir($stack_name); $self->ok( -e $stack_dir, "Directory for $stack_name should exist" ); return $stack; } #------------------------------------------------------------------------------ sub stack_not_exists_ok { my ( $self, $stack_name ) = @_; my $stack = $self->get_stack_maybe($stack_name); $self->ok( !$stack, "Stack $stack_name should not exist in DB" ); my $stack_dir = $self->pinto->repo->config->stacks_dir->subdir($stack_name); $self->ok( !-e $stack_dir, "Directory for $stack_name should not exist" ); return; } #------------------------------------------------------------------------------ sub stack_is_locked_ok { my ( $self, $stack_name ) = @_; my $stack = $self->get_stack_maybe($stack_name); $self->ok( $stack, "Stack $stack_name should exist in DB" ) or return; $self->ok( $stack->is_locked, "Stack $stack_name should be locked" ); return; } #------------------------------------------------------------------------------ sub stack_is_not_locked_ok { my ( $self, $stack_name ) = @_; my $stack = $self->get_stack_maybe($stack_name); $self->ok( $stack, "Stack $stack_name should exist in DB" ) or return; $self->ok( !$stack->is_locked, "Stack $stack_name should not be locked" ); return; } #------------------------------------------------------------------------------ sub stack_is_empty_ok { my ($self, $stack_name ) = @_; my $stack = $self->get_stack_maybe($stack_name); $self->ok( $stack, "Stack $stack_name should exist in DB" ) or return; $self->is_eq($stack->head->registrations->count, 0, "Stack $stack_name should be empty" ); return; } #------------------------------------------------------------------------------ sub populate { my ( $self, @specs ) = @_; for my $spec (@specs) { my $struct = make_dist_struct($spec); my $archive = make_dist_archive($struct); my $message = "Populated repository with $spec"; my $args = { recurse => 0, archives => $archive, author => $struct->{cpan_author}, message => $message }; my $r = $self->run_ok( 'Add', $args, $message ); throw 'Population failed. Aborting test' unless $r->was_successful; } return $self; } #------------------------------------------------------------------------------ sub clear_cache { my ($self) = @_; $self->pinto->repo->clear_cache; return $self; } #------------------------------------------------------------------------------ sub clear_buffers { my ($self) = @_; $self->pinto->chrome->stderr->truncate; $self->pinto->chrome->stdout->truncate; return $self; } #------------------------------------------------------------------------------ sub stack_url { my ( $self, $stack_name ) = @_; $stack_name ||= 'master'; return URI->new( 'file://' . $self->root->resolve->absolute . "/stacks/$stack_name" ); } #------------------------------------------------------------------------------- sub to_string { my ($self) = @_; return $self->stack_url->as_string; } #------------------------------------------------------------------------------ 1; __END__ Pinto-0.14/t/lib/Pinto/Tester/Util.pm000644 000766 000024 00000013022 13141540305 017422 0ustar00jeffstaff000000 000000 # ABSTRACT: Static helper functions for testing package Pinto::Tester::Util; use strict; use warnings; use Readonly; use Path::Class; use Apache::Htpasswd; use File::Temp qw(tempdir); use Module::Faker::Dist; use Pinto::Schema; use Pinto::Util qw(throw); use base 'Exporter'; #------------------------------------------------------------------------------- # VERSION #------------------------------------------------------------------------------- Readonly our @EXPORT_OK => qw( make_dist_obj make_pkg_obj make_dist_struct make_dist_archive make_htpasswd_file parse_pkg_spec parse_dist_spec parse_reg_spec has_cpanm ); Readonly our %EXPORT_TAGS => ( all => \@EXPORT_OK ); #------------------------------------------------------------------------------- sub make_pkg_obj { my %attrs = @_; return Pinto::Schema->resultset('Package')->new_result( \%attrs ); } #------------------------------------------------------------------------------ sub make_dist_obj { my %attrs = @_; return Pinto::Schema->resultset('Distribution')->new_result( \%attrs ); } #------------------------------------------------------------------------------ sub make_dist_archive { my ($spec_or_struct) = @_; my $struct = ref $spec_or_struct eq 'HASH' ? $spec_or_struct : make_dist_struct($spec_or_struct); my $temp_dir = tempdir( CLEANUP => 1 ); my $fake_dist = Module::Faker::Dist->new($struct); my $fake_archive = $fake_dist->make_archive( { dir => $temp_dir } ); return file($fake_archive); } #------------------------------------------------------------------------------ sub make_dist_struct { my ($spec) = @_; my ( $dist, $provides, $requires ) = parse_dist_spec($spec); for my $provision ( @{$provides} ) { my $version = $provision->{version}; my $name = $provision->{name}; my $file = "lib/$name.pm"; $dist->{provides}->{$name} = { file => $file, version => $version }; } for my $requirement ( @{$requires} ) { my $version = $requirement->{version}; my $name = $requirement->{name}; $dist->{requires}->{$name} = $version; } return $dist; } #------------------------------------------------------------------------------ sub parse_dist_spec { my ($spec) = @_; # AUTHOR / Foo-1.2 .tar.gz = Foo~1.0;Bar~2 & Baz~1.1;Nuts~2.3 # -------- ------- ------- ------------- ------------------ # | | | | | # auth dist ext provides requires # # author: optional, defaults to 'LOCAL' # extension: optional, discarded # requires: optional # All whitespace is ignored $spec =~ s{\s+}{}g; # Remove any whitespace $spec =~ m{ ^ (?: ([^/]+) /)? (.+?) (?: .tar.gz)? = ([^&]+) (?: & (.+) )? $ }mx or throw "Could not parse distribution spec: $spec"; my ( $author, $dist, $provides, $requires ) = ( $1, $2, $3, $4 ); $dist = parse_pkg_spec($dist); $dist->{cpan_author} = $author || 'LOCAL'; my @provides = map { parse_pkg_spec($_) } split /;/, $provides || ''; my @requires = map { parse_pkg_spec($_) } split /;/, $requires || ''; return ( $dist, \@provides, \@requires ); } #------------------------------------------------------------------------------ sub parse_pkg_spec { my ($spec) = @_; # Looks like: "Foo" or "Foo-1" or "Foo-Bar-2.3.4_1" $spec =~ m/^ ( .+? ) (?: [~-] ( [\d\._]+ ) )? $/x or throw "Could not parse spec: $spec"; # In older perls, capture vers are read-only my ($name, $version) = ($1, $2); # Permit '@' as alternative to '=='' $version =~ s/^ @ / == /x if $version; return { name => $name, version => $version || 0 }; } #------------------------------------------------------------------------------ sub parse_reg_spec { my ($spec) = @_; # Remove all whitespace from spec $spec =~ s{\s+}{}g; # Spec looks like "AUTHOR/Foo-Bar-1.2/Foo::Bar-1.2/stack/+" my ( $author, $dist_archive, $pkg, $stack_name, $is_pinned ) = split m{/}x, $spec; # Spec must at least have these throw "Could not parse pkg spec: $spec" if not( $author and $dist_archive and $pkg ); # Append the usual suffix to the archive $dist_archive .= '.tar.gz' unless $dist_archive =~ m{\.tar\.gz$}x; # Normalize the is_pinned flag $is_pinned = ( $is_pinned eq '*' ? 1 : 0 ) if defined $is_pinned; # Parse package name/version my ( $pkg_name, $pkg_version ) = split m{~}x, $pkg; # Set defaults $stack_name ||= 'master'; $pkg_version ||= 0; return ( $author, $dist_archive, $pkg_name, $pkg_version, $stack_name, $is_pinned ); } #------------------------------------------------------------------------------ sub make_htpasswd_file { my ( $username, $password, $file ) = @_; $file ||= file( tempdir( CLEANUP => 1 ), 'htpasswd' ); $file->touch; # Apache::Htpasswd requires the file to exist Apache::Htpasswd->new($file)->htpasswd( $username, $password ); return $file; } #------------------------------------------------------------------------------ sub has_cpanm { my $min_version = shift || 0; require File::Which; my $cpanm_exe = File::Which::which('cpanm') or return 0; my ($cpanm_ver) = qx{$cpanm_exe --version} =~ m{version ([\d._]+)}; throw "Failed to determine the version of $cpanm_exe" if $? >> 8; return $cpanm_ver >= $min_version; } #------------------------------------------------------------------------------ 1; __END__ Pinto-0.14/t/lib/Pinto/Server/Tester.pm000644 000766 000024 00000015427 13141540305 017766 0ustar00jeffstaff000000 000000 # ABSTRACT: A class for testing a Pinto server package Pinto::Server::Tester; use Moose; use MooseX::Types::Moose qw(Str Int ArrayRef); use Carp; use Test::TCP; use File::Which; use Proc::Fork; use LWP::UserAgent; use Path::Class qw(dir); use Pinto::Types qw(File Uri); use HTTP::Server::PSGI; # just to make sure we have it #------------------------------------------------------------------------------- # VERSION #------------------------------------------------------------------------------- extends 'Pinto::Tester'; #------------------------------------------------------------------------------- =attr pintod_opts( \@args ) Passes additional C<@args> to the F command line. Default is empty. =cut has pintod_opts => ( is => 'ro', isa => ArrayRef, default => sub { [] }, lazy => 1, ); =attr server_port( $integer ) Sets the port that the server will listen on. If not specified during construction, defaults to a randomly generated but open port. =cut has server_port => ( is => 'ro', isa => Int, default => sub { empty_port() }, lazy => 1, ); =attr server_host( $hostname ) Sets the hostname that the server will bind to. Defaults to C. =cut has server_host => ( is => 'ro', isa => Str, init_arg => undef, default => 'localhost', lazy => 1, ); =attr server_pid Returns the process id for the server (if it has been started). Read-only. =cut has server_pid => ( is => 'rw', isa => Int, init_arg => undef, default => 0, ); =attr server_url Returns the full URL that the server will listen on. Read-only. =cut has server_url => ( is => 'ro', isa => Uri, init_arg => undef, default => sub { URI->new( 'http://' . $_[0]->server_host . ':' . $_[0]->server_port ) }, ); =attr pintod_exe Sets the path to the C executable. If not specified, we will search in F<./blib/script>, F<./bin>, C, and finally your C An exception is thrown if C cannot be found. =cut has pintod_exe => ( is => 'ro', isa => File, builder => '_build_pintod_exe', coerce => 1, lazy => 1, ); #------------------------------------------------------------------------------- sub _build_pintod_exe { my ($self) = @_; # Look inside the dist directory for my $dir ( [qw(blib script)], [qw(bin)] ) { my $pintod = dir( @{$dir} )->file('pintod'); return $pintod if -e $pintod; } # Look at PINTO_HOME return dir( $ENV{PINTO_HOME} )->file(qw(bin pintod)) if $ENV{PINTO_HOME}; # Look anywhere in PATH return which('pintod') || croak 'Unable to find pintod anywhere'; } #------------------------------------------------------------------------------- =method start_server() Starts the L server. Emits a warning if the server is already started. =cut sub start_server { my ($self) = @_; carp 'Server already started' and return if $self->server_pid; local $ENV{PLACK_ENV} = 'testing'; # Suppresses startup message local $ENV{PLACK_SERVER} = 'HTTP::Server::PSGI'; # Basic non-forking server local $ENV{PINTO_LOCKFILE_TIMEOUT} = 2; # Don't make tests wait! local $ENV{PINTO_STALE_LOCKFILE_TIMEOUT} = 0; # Don't expire stale locks run_fork { child { my $xtra_lib = $self->_extra_lib; my $xtra_opts = $self->pintod_opts; my %opts = ( '--port' => $self->server_port, '--root' => $self->root ); my @cmd = ( $^X, $xtra_lib, $self->pintod_exe, %opts, @{$xtra_opts} ); $self->tb->note( sprintf 'exec(%s)', join ' ', @cmd ); exec @cmd; } parent { my $server_pid = shift; $self->server_pid($server_pid); sleep 15; # Let the server warm up } error { croak "Failed to fork: $!"; } }; return $self; } #------------------------------------------------------------------------------- =method stop_server() Stops the L server. Emits a warning if the server is not currently running. =cut sub stop_server { my ($self) = @_; my $server_pid = $self->server_pid; carp 'Server was never started' and return if not $server_pid; carp "Server $server_pid not running" and return if not kill 0, $server_pid; # TODO: Consider using Proc::Terminator instead kill 'TERM', $server_pid; sleep 5 and waitpid $server_pid, 0; return $self; } #------------------------------------------------------------------------------- =method server_running_ok() Asserts that the server is running. =cut sub server_running_ok { my ($self) = @_; my $server_pid = $self->server_pid; my $server_port = $self->server_port; my $ok = kill 0, $server_pid; # Is this portable? return $self->tb->ok( $ok, "Server $server_pid is running on port $server_port" ); } #------------------------------------------------------------------------------- =method server_not_running_ok Asserts that the server is not running. =cut sub server_not_running_ok { my ($self) = @_; my $server_pid = $self->server_pid; my $ok = not kill 0, $server_pid; # Is this portable? return $self->tb->ok( $ok, "Server is not running with pid $server_pid" ); } #------------------------------------------------------------------------------- =method can_connect Returns true if the server is able to receive and respond to a connection request. =cut sub can_connect { my ($self) = @_; # LWP uses a 500 error when the connection is refused. I'm not # sure if this will be portable to otehr user agents. Might be # better to open a raw socket. See IO::Socket::INET for that. return LWP::UserAgent->new->get($self->server_url)->code != 500; } #------------------------------------------------------------------------------- sub to_string { my $self = shift; return $self->server_url->as_string; } #------------------------------------------------------------------------------- sub _extra_lib { my ($self) = @_; my $blib = dir(qw(blib lib)); my $lib = dir(qw( lib)); return "-I$blib" if -e $blib; return "-I$lib" if -e $lib; return ''; } #------------------------------------------------------------------------------- sub DEMOLISH { my ($self) = @_; $self->stop_server if $self->server_pid; return; } #------------------------------------------------------------------------------- __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------- 1; __END__ =pod =for stopwords responder =for Pod::Coverage DEMOLISH =cut Pinto-0.14/t/04-server/01-functional.t000644 000766 000024 00000027663 13141540305 017356 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use Plack::Test; use JSON; use IO::Zlib; use Path::Class; use HTTP::Date; use HTTP::Request::Common; use Pinto::Server; use Pinto::Constants qw(:server :protocol); use lib 't/lib'; use Pinto::Tester; use Pinto::Tester::Util qw(make_dist_archive); #------------------------------------------------------------------------------ # Setup... my $t = Pinto::Tester->new; my %opts = ( root => $t->pinto->root ); my $app = Pinto::Server->new(%opts)->to_app; my @headers = (Accept => $PINTO_PROTOCOL_ACCEPT); #------------------------------------------------------------------------------ # Fetching an index... test_psgi app => $app, client => sub { my $cb = shift; my $req = GET('modules/02packages.details.txt.gz'); my $res = $cb->($req); is $res->code, 200, 'Correct status code'; is $res->header('Content-Type'), 'application/x-gzip', 'Correct Type header'; cmp_ok $res->header('Content-Length'), '>', 4000, 'Reasonable Length header'; # Actual length may vary cmp_ok $res->header('Content-Length'), '<', 7000, 'Reasonable Length header'; # Actual length may vary is $res->header('Content-Length'), length $res->content, 'Length header matches actual length'; is $res->header('Cache-Control'), 'no-cache', 'Got a "Cache-Control: no-cache" header'; isnt str2time( $res->header('Last-Modified') ), undef, 'Last-Modified header contains a proper HTTP::Date string'; }; #------------------------------------------------------------------------------ # Test fetching legacy indexes (used by the cpan[1] client) test_psgi app => $app, client => sub { my $cb = shift; my @paths = qw(authors/01mailrc.txt.gz modules/03modlist.data.gz); for my $path (@paths) { for my $prefix ( 'stacks/master/', '' ) { my $url = $prefix . $path; my $req = GET($url); my $res = $cb->($req); is $res->code, 200, "Got response for $url"; is $res->header('Cache-Control'), "no-cache", "$url got a 'Cache-Control: no-cache' header"; } } }; #------------------------------------------------------------------------------ # Add an archive, then fetch it back. Finally, check that all packages in the # archive are present in the listing subtest 'validate archive' => sub { my $archive = make_dist_archive('TestDist-1.0=Foo~0.7; Bar~0.8')->stringify; test_psgi app => $app, client => sub { my $cb = shift; my $params = { author => 'THEBARD', recurse => 0, message => 'test', archives => [$archive] }; my $req = POST( 'action/add', @headers, Content => { action => encode_json($params) } ); my $res = $cb->($req); action_response_ok($res); }; test_psgi app => $app, client => sub { my $cb = shift; my $params = { stack => 'master' }; my $req = POST( 'action/lock', @headers, Content => { action => encode_json($params) } ); my $res = $cb->($req); action_response_ok($res); }; test_psgi app => $app, client => sub { my $cb = shift; my $params = { author => 'THEBARD', recurse => 0, message => 'test', archives => [$archive] }; my $req = POST( 'action/add', @headers, Content => { action => encode_json($params) } ); my $res = $cb->($req); action_response_not_ok( $res, qr{is locked} ); }; test_psgi app => $app, client => sub { my $cb = shift; my $url = 'stacks/master/authors/id/T/TH/THEBARD/TestDist-1.0.tar.gz'; my $req = GET($url); my $res = $cb->($req); is $res->code, 200, "Correct status code for GET $url"; is $res->header('Content-Type'), 'application/x-gzip', "Correct Type header for GET $url"; is $res->header('Content-Length'), -s $archive, "Length header matches actual archive size for GET $url"; is $res->header('Content-Length'), length $res->content, "Length header matches actual content length for GET $url"; }; my $last_modified; test_psgi app => $app, client => sub { my $cb = shift; my $url = 'stacks/master/authors/id/T/TH/THEBARD/TestDist-1.0.tar.gz'; my $req = HEAD($url); my $res = $cb->($req); $last_modified = $res->header('Last-Modified'); isnt str2time($last_modified), undef, "Last-Modified header contains a proper HTTP::Date string for HEAD $url"; is $res->code, 200, "Correct status code for HEAD $url"; is $res->header('Content-Type'), 'application/x-gzip', "Correct Type header for HEAD $url"; is $res->header('Content-Length'), -s $archive, "Length header matches actual archive size for HEAD $url"; is length $res->content, 0, "No content returned for HEAD $url"; }; test_psgi app => $app, client => sub { my $cb = shift; my $url = 'stacks/master/authors/id/T/TH/THEBARD/TestDist-1.0.tar.gz'; my $req = GET( $url, 'If-Modified-Since' => $last_modified ); my $res = $cb->($req); is $res->code, 304, "Correct status code for unmodified $url"; is $res->header('Content-Type'), undef, "No Content-Type header for 304 response"; is $res->header('Content-Length'), undef, "No Content-Length header for 304 response"; is length $res->content, 0, "No content returned for 304 response"; }; test_psgi app => $app, client => sub { my $cb = shift; my $params = {}; my $req = POST( 'action/list', @headers, Content => { action_args => encode_json($params) } ); my $res = $cb->($req); is $res->code, 200, 'Correct status code'; # Note that the lines of the listing itself should NOT contain # the $PINTO_PROTOCOL_DIAG_PREFIX in front of each line. like $res->content, qr{\s Foo \s+ 0.7 \s+ \S+ \n}mx, 'Listing contains the Foo package'; like $res->content, qr{\s Bar \s+ 0.8 \s+ \S+ \n}mx, 'Listing contains the Bar package'; }; }; #------------------------------------------------------------------------------ # Make two stacks, add a different version of a dist to each stack, then fetch # the index for each stack. The indexes should contain different dists. for my $v ( 1, 2 ) { my $stack = "stack_$v"; my $archive = make_dist_archive("Fruit-$v=Apple~$v; Orange~$v")->stringify; test_psgi app => $app, client => sub { my $cb = shift; my $params = { stack => $stack }; my $req = POST( 'action/new', @headers, Content => { action => encode_json($params) } ); my $res = $cb->($req); action_response_ok($res); }; test_psgi app => $app, client => sub { my $cb = shift; my $params = { author => 'JOHN', recurse => 0, stack => $stack, message => 'test', archives => [$archive] }; my $req = POST( 'action/add', @headers, Content => { action => encode_json($params) } ); my $res = $cb->($req); action_response_ok($res); }; test_psgi app => $app, client => sub { my $cb = shift; my $req = GET("stacks/$stack/modules/02packages.details.txt.gz"); my $res = $cb->($req); is $res->code, 200, 'Correct status code'; # Write the index to a file my $temp = File::Temp->new; print {$temp} $res->content; close $temp; # Slurp index contents into memory my $fh = IO::Zlib->new( $temp->filename, "rb" ) or die $!; my $index = join '', <$fh>; close $fh; # Test index contents for (qw(Apple Orange)) { like $index, qr{^ $_ \s+ $v \s+ J/JO/JOHN/Fruit-$v.tar.gz $}mx, "index contains package $_-$v"; } }; } #------------------------------------------------------------------------------ # GET invalid path... test_psgi app => $app, client => sub { my $cb = shift; my $req = GET('bogus/path'); my $res = $cb->($req); is $res->code, 404, 'Correct status code'; is $res->header('Content-Type'), 'text/plain'; is $res->header('Content-Length'), length $res->content; like $res->content, qr{not found}i, 'File not found message'; }; #------------------------------------------------------------------------------ # POST invalid action test_psgi app => $app, client => sub { my $cb = shift; my $params = {}; my $req = POST( 'action/bogus', @headers, Content => { action => encode_json($params) } ); my $res = $cb->($req); action_response_not_ok( $res, qr{Can't locate Pinto/Action/Bogus.pm}i ); }; #------------------------------------------------------------------------------ # Unversioned client (no Accept header) test_psgi app => $app, client => sub { my $cb = shift; my $req = POST( 'action/nop', Content => { action => encode_json({}) } ); my $res = $cb->($req); is $res->code, 415, 'Unsupported media type status'; like $res->content, qr/too old/; like $res->content, qr/upgrade pinto/; }; #------------------------------------------------------------------------------ # Client version is too old (i.e. server is too new) test_psgi app => $app, client => sub { my $cb = shift; my @headers = (Accept => 'application/vnd.pinto.v0+text'); my $req = POST( 'action/nop', Content => { action => encode_json({}) } ); my $res = $cb->($req); is $res->code, 415, 'Unsupported media type status'; like $res->content, qr/too old/; like $res->content, qr/upgrade pinto/; }; #------------------------------------------------------------------------------ # # Client version is too new (i.e. server is too old) test_psgi app => $app, client => sub { my $cb = shift; my @headers = (Accept => 'application/vnd.pinto.v99+text'); my $req = POST( 'action/nop', @headers, Content => { action => encode_json({}) } ); my $res = $cb->($req); is $res->code, 415, 'Unsupported media type status'; like $res->content, qr/too new/; like $res->content, qr/upgrade pintod/; }; #------------------------------------------------------------------------------ sub action_response_ok { my ( $response, $pattern, $test_name ) = @_; $test_name ||= sprintf '%s %s', $response->request->method, $response->request->uri; # Report failues from caller's perspective local $Test::Builder::Level = $Test::Builder::Level + 3; my $type = $response->header('Content-Type'); is $type, 'text/plain', "Content-Type response header from $test_name"; my $status = $response->code; is $status, 200, "Succesful status code for $test_name"; my $content = $response->content; like $content, qr{$PINTO_PROTOCOL_STATUS_OK\n$}, "Response ends with status-ok for $test_name"; like $content, $pattern, "Response content matches for $test_name" if $pattern; } #------------------------------------------------------------------------------ sub action_response_not_ok { my ( $response, $pattern, $test_name ) = @_; $test_name ||= sprintf '%s %s', $response->request->method, $response->request->uri; # Report failues from caller's perspective local $Test::Builder::Level = $Test::Builder::Level + 3; my $type = $response->header('Content-Type'); is $type, 'text/plain', "Content-Type response header from $test_name"; my $status = $response->code; is $status, 200, "Succesful status code for $test_name"; my $content = $response->content; unlike $content, qr{$PINTO_PROTOCOL_STATUS_OK\n$}, "Response does not end with status-ok for $test_name"; like $content, $pattern, "Response content matches for $test_name" if $pattern; } #------------------------------------------------------------------------------ done_testing; Pinto-0.14/t/04-server/02-authentication.t000644 000766 000024 00000006012 13141540305 020215 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use Plack::Test; use JSON; use HTTP::Request::Common; use Pinto::Server; use Pinto::Constants qw(:protocol); use lib 't/lib'; use Pinto::Tester; use Pinto::Tester::Util qw(make_htpasswd_file); #------------------------------------------------------------------------------ # Create a repository and configure server my $t = Pinto::Tester->new; my @credentials = qw(my_login my_password); my $htpasswd_file = make_htpasswd_file(@credentials); my $auth = { backend => 'Passwd', path => $htpasswd_file->stringify }; my %opts = ( root => $t->pinto->root, auth => $auth ); my $app = Pinto::Server->new(%opts)->to_app; my $auth_required_rx = qr/authorization required/i; my @headers = (Accept => $PINTO_PROTOCOL_ACCEPT); #------------------------------------------------------------------------------ test_psgi app => $app, client => sub { my $cb = shift; my $post_req = POST("/action/list", @headers); my $post_res = $cb->($post_req); ok !$post_res->is_success, 'POST request without authentication failed'; like $post_res->content, $auth_required_rx, 'Expected content'; my $get_req = GET("/init/modules/02packages.details.txt.gz"); my $get_res = $cb->($get_req); ok !$get_res->is_success, 'GET request without authentication failed'; like $get_res->content, $auth_required_rx, 'Expected content'; }; #------------------------------------------------------------------------------ test_psgi app => $app, client => sub { my $cb = shift; my $post_req = POST("/action/list", @headers); $post_req->authorization_basic(@credentials); my $post_res = $cb->($post_req); ok $post_res->is_success, 'POST request with correct password succeeded'; like $post_res->content, qr{$PINTO_PROTOCOL_STATUS_OK\n$}, 'Got status-ok'; my $get_req = GET("modules/02packages.details.txt.gz"); $get_req->authorization_basic(@credentials); my $get_res = $cb->($get_req); ok $get_res->is_success, 'POST request with correct password succeeded'; # TODO: maybe test headers, body. }; #------------------------------------------------------------------------------ test_psgi app => $app, client => sub { my $cb = shift; my @bad_credentials = qw(my_login my_bogus_password); my $post_req = POST("/action/list", @headers); $post_req->authorization_basic(@bad_credentials); my $post_res = $cb->($post_req); ok !$post_res->is_success, 'POST request with invalid password failed'; like $post_res->content, $auth_required_rx, 'Expected content'; my $get_req = GET("/init/modules/02packages.details.txt.gz"); $get_req->authorization_basic(@bad_credentials); my $get_res = $cb->($get_req); ok !$get_res->is_success, 'GET request without authentication failed'; like $get_res->content, $auth_required_rx, 'Expected content'; }; #------------------------------------------------------------------------------ done_testing; Pinto-0.14/t/04-server/03-security.t000644 000766 000024 00000002001 13141540305 017040 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use Plack::Test; use HTTP::Request::Common; use Pinto::Server; use lib 't/lib'; use Pinto::Tester; #------------------------------------------------------------------------------ # Setup... my $t = Pinto::Tester->new; my %opts = ( root => $t->pinto->root ); my $app = Pinto::Server->new(%opts)->to_app; #------------------------------------------------------------------------------ # GET a path outside the repository test_psgi app => $app, client => sub { my $cb = shift; my $base = 'foobar.txt'; my $file = $t->pinto->root->parent->file("$base"); unless ($file->open('w')) { pass && diag 'Cannot create test file, skipping test'; return; } my $req = GET("../$base"); is $cb->($req)->code, 404, 'Status of files outside repo'; $file->remove if -e $file; }; #------------------------------------------------------------------------------ done_testing; Pinto-0.14/t/03-remote/01-requests.t000644 000766 000024 00000004666 13141540305 017051 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use Test::LWP::UserAgent; use JSON; use HTTP::Body; use HTTP::Response; use File::Temp; use Pinto::Remote; use Pinto::Globals; use Pinto::Constants qw($PINTO_DEFAULT_PALETTE $PINTO_PROTOCOL_ACCEPT); #----------------------------------------------------------------------------- subtest 'request dialog' => sub { local $ENV{PINTO_PALETTE} = undef; my $ua = local $Pinto::Globals::UA = Test::LWP::UserAgent->new; my $res = HTTP::Response->new(200); $ua->map_response( qr{.*} => $res ); my $action = 'Add'; my $temp = File::Temp->new; my %pinto_args = ( username => 'myname' ); my %chrome_args = ( verbose => 2, color => 0, quiet => 0, palette => $PINTO_DEFAULT_PALETTE ); my %action_args = ( archives => [ $temp->filename ], author => 'ME', stack => 'mystack' ); my $chrome = Pinto::Chrome::Term->new(%chrome_args); my $pinto = Pinto::Remote->new( root => 'http://myhost:3111', chrome => $chrome, %pinto_args ); $pinto->run( $action, %action_args ); my $req = $ua->last_http_request_sent; is $req->method, 'POST', "Correct HTTP method in request for action $action"; is $req->uri, 'http://myhost:3111/action/add', "Correct uri in request for action $action"; is $req->header('Accept'), $PINTO_PROTOCOL_ACCEPT, 'Accept header'; my $req_params = parse_req_params($req); my $got_chrome_args = decode_json( $req_params->{chrome} ); my $got_pinto_args = decode_json( $req_params->{pinto} ); my $got_action_args = decode_json( $req_params->{action} ); my $got_time_offset = delete $got_pinto_args->{time_offset}; is $got_time_offset, DateTime->now(time_zone => 'local')->offset, 'Correct time_offset'; is_deeply $got_chrome_args, \%chrome_args, "Correct chrome args in request for action $action"; is_deeply $got_pinto_args, \%pinto_args, "Correct pinto args in request for action $action"; is_deeply $got_action_args, \%action_args, "Correct action args in request for action $action"; }; #----------------------------------------------------------------------------- sub parse_req_params { my ($req) = @_; my $type = $req->header('Content-Type'); my $length = $req->header('Content-Length'); my $hb = HTTP::Body->new( $type, $length ); $hb->add( $req->content ); return $hb->param; } #----------------------------------------------------------------------------- done_testing; Pinto-0.14/t/03-remote/02-responses.t000644 000766 000024 00000002446 13141540305 017212 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use Test::LWP::UserAgent 0.018; # Older versions caused this test to fail use IO::String; use HTTP::Response; use Pinto::Remote; use Pinto::Globals; use Pinto::Chrome::Term; use Pinto::Constants qw(:server :protocol); #----------------------------------------------------------------------------- subtest 'response dialog' => sub { my $ua = local $Pinto::Globals::UA = Test::LWP::UserAgent->new; my $res = HTTP::Response->new(200); $res->content("DATA-GOES-HERE\n## DIAG-MSG-HERE\n$PINTO_PROTOCOL_STATUS_OK\n"); $ua->map_response( qr{.*}, $res ); my $out_buffer = ''; my $out_fh = IO::String->new( \$out_buffer ); my $err_buffer = ''; my $err_fh = IO::String->new( \$err_buffer ); my $chrome = Pinto::Chrome::Term->new( stdout => $out_fh, stderr => $err_fh ); my $pinto = Pinto::Remote->new( chrome => $chrome, root => $PINTO_SERVER_DEFAULT_ROOT ); my $result = $pinto->run('List'); is $result->was_successful, 1, 'Got successful result' or diag $err_buffer; is $out_buffer, "DATA-GOES-HERE\n", 'Got correct data output'; is $err_buffer, "DIAG-MSG-HERE\n", 'Got correct diagnostic output'; }; #----------------------------------------------------------------------------- done_testing; Pinto-0.14/t/03-remote/03-install.t000644 000766 000024 00000010550 13141540305 016633 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use Test::File; use Test::Exception; use File::Temp; use Path::Class qw(dir); use Capture::Tiny qw(capture_stderr); use Pinto::Remote; use lib 't/lib'; use Pinto::Server::Tester; use Pinto::Constants qw($PINTO_MINIMUM_CPANM_VERSION); use Pinto::Tester::Util qw(has_cpanm); use Pinto::Util qw(tempdir); #------------------------------------------------------------------------------ # To prevent mucking with user's ~/.cpanm. See GH #170. local $ENV{PERL_CPANM_HOME} = tempdir->stringify(); # To prevent failures due to a proxy. See GH #202. local $ENV{no_proxy} = "localhost"; #------------------------------------------------------------------------------ plan skip_all => "Need cpanm $PINTO_MINIMUM_CPANM_VERSION or newer" unless has_cpanm($PINTO_MINIMUM_CPANM_VERSION); #------------------------------------------------------------------------------ my $t = Pinto::Server::Tester->new->start_server; plan skip_all => "Can't open connection to $t" unless $t->can_connect; $t->populate('JOHN/DistA-1 = PkgA~1 & PkgB~1'); $t->populate('PAUL/DistB-1 = PkgB~1 & PkgC~1'); $t->populate('MARK/DistC-1 = PkgC~1'); #------------------------------------------------------------------------------ subtest 'Install from default stack' => sub { my $sandbox = File::Temp->newdir; my $p5_dir = dir( $sandbox, qw(lib perl5) ); my %cpanm_opts = ( cpanm_options => { q => undef, L => $sandbox->dirname } ); my $remote = Pinto::Remote->new( root => $t->server_url ); my $result; capture_stderr { $result = $remote->run( Install => ( targets => ['PkgA'], %cpanm_opts ) ); }; is $result->was_successful, 1; file_exists_ok( $p5_dir->file('PkgA.pm') ); file_exists_ok( $p5_dir->file('PkgB.pm') ); file_exists_ok( $p5_dir->file('PkgC.pm') ); }; #------------------------------------------------------------------------------ subtest 'Install from named stack' => sub { $t->run_ok( 'New' => { stack => 'dev' } ); $t->run_ok( 'Pull' => { targets => 'PkgA', stack => 'dev' } ); my $sandbox = File::Temp->newdir; my $p5_dir = dir( $sandbox, qw(lib perl5) ); my %cpanm_opts = ( cpanm_options => { q => undef, L => $sandbox->dirname } ); my $remote = Pinto::Remote->new( root => $t->server_url ); my $result; capture_stderr { $result = $remote->run( Install => ( targets => ['PkgA'], stack => 'dev', %cpanm_opts ) ); }; is $result->was_successful, 1; file_exists_ok( $p5_dir->file('PkgA.pm') ); file_exists_ok( $p5_dir->file('PkgB.pm') ); file_exists_ok( $p5_dir->file('PkgC.pm') ); }; #------------------------------------------------------------------------------ subtest 'Install a missing target' => sub { diag "You will see an error message here. Do not be alarmed."; my $sandbox = File::Temp->newdir; my $p5_dir = dir( $sandbox, qw(lib perl5) ); my %cpanm_opts = ( cpanm_options => { q => undef, L => $sandbox->dirname } ); my $remote = Pinto::Remote->new( root => $t->server_url ); my $result; capture_stderr { $result = $remote->run( Install => { targets => ['PkgZ'], %cpanm_opts } ); }; is $result->was_successful, 0; like $result, qr/Installation failed/; }; #------------------------------------------------------------------------------ subtest 'Install a dist with an unusual author id' => sub { # Versions of cpanm before 1.6916 could not handle short author ids or those # that contained numbers and hyphens. But miyagawa agreed to support them # since they are allowed by CPAN::DistnameInfo. my $t = Pinto::Server::Tester->new->start_server; $t->populate('FOO-22/DistA-1 = PkgA~1'); $t->populate('FO/DistB-1 = PkgB~1'); my $sandbox = File::Temp->newdir; my $p5_dir = dir( $sandbox, qw(lib perl5) ); my %cpanm_opts = ( cpanm_options => { q => undef, L => $sandbox->dirname } ); my $remote = Pinto::Remote->new( root => $t->server_url ); capture_stderr { $remote->run( Install => ( targets => ['FOO-22/DistA-1.tar.gz'], %cpanm_opts ) ); $remote->run( Install => ( targets => ['FO/DistB-1.tar.gz'], %cpanm_opts ) ); }; file_exists_ok( $p5_dir->file('PkgA.pm') ); file_exists_ok( $p5_dir->file('PkgB.pm') ); }; #------------------------------------------------------------------------------ done_testing; Pinto-0.14/t/03-remote/04-install-with-auth.t000644 000766 000024 00000007212 13141540305 020545 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use Test::File; use Test::Exception; use Plack::Test; use File::Temp; use Path::Class; use Capture::Tiny qw(capture_stderr); use Pinto::Remote; use lib 't/lib'; use Pinto::Server::Tester; use Pinto::Tester::Util qw(make_htpasswd_file has_cpanm); use Pinto::Constants qw($PINTO_MINIMUM_CPANM_VERSION); use Pinto::Util qw(tempdir); #------------------------------------------------------------------------------ # To prevent mucking with user's ~/.cpanm. See GH #170. local $ENV{PERL_CPANM_HOME} = tempdir->stringify(); # To prevent failures due to a proxy. See GH #202. local $ENV{no_proxy} = "localhost"; #------------------------------------------------------------------------------ plan skip_all => "Need cpanm $PINTO_MINIMUM_CPANM_VERSION or newer" unless has_cpanm($PINTO_MINIMUM_CPANM_VERSION); #------------------------------------------------------------------------------ # Setup the server my $htpasswd = make_htpasswd_file(qw(my_login my_password)); my @auth = ( qw(--auth backend=Passwd --auth), "path=$htpasswd" ); my $t = Pinto::Server::Tester->new( pintod_opts => \@auth )->start_server; plan skip_all => "Can't open connection to $t" unless $t->can_connect; $t->populate('JOHN/DistA-1 = PkgA~1 & PkgB~1; PkgC~1'); $t->populate('PAUL/DistB-1 = PkgB~1 & PkgD~2'); $t->populate('MARK/DistC-1 = PkgC~1'); $t->populate('MARK/DistC-2 = PkgC~2; PkgD~2'); #------------------------------------------------------------------------------ subtest 'Remote install succeeds with valid credentials' => sub { my %creds = ( username => 'my_login', password => 'my_password' ); my $remote = Pinto::Remote->new( root => $t->server_url, %creds ); my $sandbox = File::Temp->newdir; my $p5_dir = dir( $sandbox, qw(lib perl5) ); my %cpanm_opts = ( cpanm_options => { q => undef, L => $sandbox->dirname } ); my $result; capture_stderr { $result = $remote->run( Install => ( targets => ['PkgA'], %cpanm_opts ) ); }; is $result->was_successful, 1; file_exists_ok( $p5_dir->file('PkgA.pm') ); file_exists_ok( $p5_dir->file('PkgB.pm') ); file_exists_ok( $p5_dir->file('PkgC.pm') ); file_exists_ok( $p5_dir->file('PkgD.pm') ); }; #------------------------------------------------------------------------------ subtest 'Remote install fails with invalid credentials' => sub { my %creds = ( username => 'my_login', password => 'bogus' ); my $remote = Pinto::Remote->new( root => $t->server_url, %creds ); my $sandbox = File::Temp->newdir; my $p5_dir = dir( $sandbox, qw(lib perl5) ); my %cpanm_opts = ( cpanm_options => { q => undef, L => $sandbox->dirname } ); my $result; capture_stderr { $result = $remote->run( Install => ( targets => ['PkgA'], %cpanm_opts ) ); }; is $result->was_successful, 0; like $result, qr/Installation failed/; }; #------------------------------------------------------------------------------ subtest 'Remote install fails with no credentials' => sub { diag "You will see an error message here. Do not be alarmed."; my %creds = (); my $remote = Pinto::Remote->new( root => $t->server_url, %creds ); my $sandbox = File::Temp->newdir; my $p5_dir = dir( $sandbox, qw(lib perl5) ); my %cpanm_opts = ( cpanm_options => { q => undef, L => $sandbox->dirname } ); my $result; capture_stderr { $result = $remote->run( Install => ( targets => ['PkgA'], %cpanm_opts ) ); }; is $result->was_successful, 0; like $result, qr/Installation failed/; }; #------------------------------------------------------------------------------ done_testing; Pinto-0.14/t/03-remote/05-timezone.t000644 000766 000024 00000003356 13141540305 017027 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use DateTime; use Pinto::Remote; use lib 't/lib'; use Pinto::Server::Tester; use Pinto::Tester::Util qw(make_dist_archive); #------------------------------------------------------------------------------ my $t = Pinto::Server::Tester->new->start_server; plan skip_all => "Can't open connection to $t" unless $t->can_connect; #------------------------------------------------------------------------------ subtest 'User vs Local vs UTC time' => sub { $Pinto::Globals::UA->no_proxy("localhost"); # See GH #202 my $remote = Pinto::Remote->new( root => $t->server_url ); my $archive = make_dist_archive('AUTHOR/DistA-1 = PkgA~1'); my $offset = 10; { local $Pinto::Globals::current_time_offset = $offset; my $result = $remote->run( Add => ( archives => [$archive->stringify] ) ); ok $result->was_successful, 'Add action was successful'; } my $rev = $t->get_stack->head; my $utc_time = $rev->utc_time; is $rev->time_offset, $offset, 'Time offset'; is $rev->datetime->epoch, $utc_time, 'UTC datetime'; is $rev->datetime_user->epoch, $utc_time, 'User datetime utc'; is $rev->datetime_local->epoch, $utc_time, 'Local datetime utc'; my $local_offset = DateTime->now( time_zone => 'local' )->offset; is $rev->datetime->offset, 0, 'UTC datetime offset'; is $rev->datetime_user->offset, $offset, 'User datetime offset'; is $rev->datetime_local->offset, $local_offset, 'Local datetime offset'; is $rev->to_string('%u'), $rev->datetime_local->strftime('%c'), 'Stringify to local time'; }; #------------------------------------------------------------------------------ done_testing; Pinto-0.14/t/02-bowels/01-config.t000644 000766 000024 00000003176 13141540305 016435 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use Test::Exception; use Path::Class; use File::Temp; use URI; use Pinto::Config; #------------------------------------------------------------------------------ subtest 'Default config' => sub { my %cases = ( root => 'nowhere', sources => 'http://cpan.stratopan.com http://www.cpan.org http://backpan.perl.org', ); my $cfg = Pinto::Config->new( root => 'nowhere' ); while ( my ( $method, $expect ) = each %cases ) { my $msg = "Got default value for '$method'"; is( $cfg->$method(), $expect, $msg ); } }; #------------------------------------------------------------------------------ subtest 'Custom config' => sub { my %cases = ( root => 'nowhere', sources => 'http://cpan.pair.com http://metacpan.org', ); my $cfg = Pinto::Config->new(%cases); while ( my ( $method, $expect ) = each %cases ) { my $msg = "Got custom value for '$method'"; is( $cfg->$method(), $expect, $msg ); } }; #------------------------------------------------------------------------------ subtest 'Multiple sources' => sub { my $expect = [ map { URI->new($_) } qw(here there) ]; my $cfg1 = Pinto::Config->new( root => 'anywhere', sources => 'here there' ); is_deeply( [ $cfg1->sources_list ], $expect, 'Parsed sources list' ); my $cfg2 = Pinto::Config->new( root => 'anywhere', sources => q{"here there"} ); is_deeply( [ $cfg2->sources_list ], $expect, 'Parsed sources list, with quotes' ); }; #------------------------------------------------------------------------------ done_testing; Pinto-0.14/t/02-bowels/02-chrome.t000644 000766 000024 00000007120 13141540305 016437 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use Test::Exception; use Pinto::Chrome::Term; #----------------------------------------------------------------------------- subtest 'verbosity 0' => sub { my $chrome = Pinto::Chrome::Term->new; is $chrome->should_render_diag(0), 1, 'Diag level 0 at default vebosity'; is $chrome->should_render_diag(1), 1, 'Diag level 1 at default vebosity'; is $chrome->should_render_diag(2), 0, 'Diag level 2 at default vebosity'; is $chrome->should_render_diag(3), 0, 'Diag level 3 at default vebosity'; # local $Pinto::Globals::is_interactive = 1; # is $chrome->should_render_progress, 1, 'Show progress at default verbosity, when interactive'; local $Pinto::Globals::is_interactive = 0; is $chrome->should_render_progress, 0, 'Hide progress at default verbosity, when not interactive'; }; #----------------------------------------------------------------------------- subtest 'verbosity 1' => sub { my $chrome = Pinto::Chrome::Term->new( verbose => 1 ); is $chrome->should_render_diag(0), 1, 'Diag level 0 at verbose = 1'; is $chrome->should_render_diag(1), 1, 'Diag level 1 at verbose = 1'; is $chrome->should_render_diag(2), 1, 'Diag level 2 at verbose = 1'; is $chrome->should_render_diag(3), 0, 'Diag level 3 at verbose = 1'; is $chrome->should_render_progress, 0, 'Hide progress at verbose = 1'; }; #----------------------------------------------------------------------------- subtest 'quiet 1' => sub { my $chrome = Pinto::Chrome::Term->new( quiet => 1 ); is $chrome->should_render_diag(0), 1, 'Diag level when quiet'; is $chrome->should_render_diag(1), 0, 'Diag level when quiet'; is $chrome->should_render_diag(2), 0, 'Diag level when quiet'; is $chrome->should_render_diag(3), 0, 'Diag level when quiet'; is $chrome->should_render_progress, 0, 'Hide progress when quiet'; }; #----------------------------------------------------------------------------- subtest 'color palette' => sub { local $ENV{PINTO_PALETTE} = 'dark blue, white on_red,green'; my $chrome = Pinto::Chrome::Term->new; is_deeply $chrome->palette, [ 'dark blue', 'white on_red', 'green' ], 'Parsed color list'; }; #----------------------------------------------------------------------------- subtest 'no color' => sub { local $ENV{PINTO_NO_COLOR} = 1; my ( $out, $err ) = ( '', '' ); my $chrome = Pinto::Chrome::Term->new( stdout => \$out, stderr => \$err ); $chrome->error('This is diagnostic'); $chrome->show('This is output'); is $out, "This is output\n", 'Got stuff on output handle'; is $err, "This is diagnostic\n", 'Got stuff on error handle'; }; #----------------------------------------------------------------------------- subtest 'derive editor' => sub { my $chrome = Pinto::Chrome::Term->new; local $ENV{VISUAL} = ''; local $ENV{EDITOR} = ''; local $ENV{PINTO_EDITOR} = 'emacs'; is $chrome->find_editor, $ENV{PINTO_EDITOR}, 'Editor from PINTO_EDITOR'; local $ENV{VISUAL} = ''; local $ENV{EDITOR} = 'emacs'; local $ENV{PINTO_EDITOR} = ''; is $chrome->find_editor, $ENV{EDITOR}, 'Editor from EDITOR'; local $ENV{VISUAL} = 'emacs'; local $ENV{EDITOR} = ''; local $ENV{PINTO_EDITOR} = ''; is $chrome->find_editor, $ENV{VISUAL}, 'Editor from VISUAL'; local $ENV{PATH} = ''; local $ENV{VISUAL} = ''; local $ENV{EDITOR} = ''; local $ENV{PINTO_EDITOR} = ''; is $chrome->find_editor, undef, 'No editor is avaiable'; }; #----------------------------------------------------------------------------- done_testing; Pinto-0.14/t/02-bowels/03-package.t000644 000766 000024 00000003563 13141540305 016565 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use Path::Class; use lib 't/lib'; use Pinto::Tester::Util qw(make_dist_obj make_pkg_obj); #------------------------------------------------------------------------------ my $dist = make_dist_obj( author => 'AUTHOR', archive => 'Foo-2.001_02.tar.gz' ); my $pkg = make_pkg_obj( name => 'Foo', version => '2.001_02', distribution => $dist ); is( $pkg->name(), 'Foo', 'name attribute' ); is( $pkg->vname(), 'Foo~2.001_02', 'vname attribute' ); is( $pkg->version(), '2.001_02', 'version attribute' ); isa_ok( $pkg->version(), 'version', 'version attribute isa version object' ); is( "$pkg", 'AUTHOR/Foo-2.001_02/Foo~2.001_02', 'default strigification' ); #------------------------------------------------------------------------------ $dist = make_dist_obj( author => 'AUTHOR', archive => 'Foo-2.0.tar.gz', source => 'http://remote' ); $pkg = make_pkg_obj( name => 'Foo', distribution => $dist ); is( $pkg->vname(), 'Foo~0', 'vname with undef version' ); #------------------------------------------------------------------------------ $dist = make_dist_obj( author => 'AUTHOR', archive => 'Foo-2.0-TRIAL.tar.gz', source => 'http://remote' ); $pkg = make_pkg_obj( name => 'Foo', distribution => $dist, version => 1.2 ); my %formats = ( 'p' => 'Foo', 'P' => 'Foo~1.2', 'v' => '1.2', 'm' => 'd', 'h' => 'A/AU/AUTHOR/Foo-2.0-TRIAL.tar.gz', 's' => 'f', 'S' => 'http://remote', 'a' => 'AUTHOR', 'd' => 'Foo', 'D' => 'Foo-2.0-TRIAL', 'V' => '2.0-TRIAL', 'u' => 'http://remote/authors/id/A/AU/AUTHOR/Foo-2.0-TRIAL.tar.gz', ); while ( my ( $placeholder, $expected ) = each %formats ) { my $got = $pkg->to_string("%$placeholder"); is( $got, $expected, "Placeholder: %$placeholder" ); } #------------------------------------------------------------------------------ done_testing(); Pinto-0.14/t/02-bowels/04-distribution.t000644 000766 000024 00000005312 13141540305 017704 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use Path::Class; use lib 't/lib'; use Pinto::Tester::Util qw(make_dist_obj); #----------------------------------------------------------------------------- subtest 'author/archive' => sub { my $dist = make_dist_obj( author => 'FOO', archive => 'Bar-1.2.tar.gz' ); is( $dist->author, 'FOO', 'dist author' ); is( $dist->archive, 'Bar-1.2.tar.gz', 'dist archive' ); is( $dist->source, 'LOCAL', 'Source defaults to q{LOCAL}' ); is( $dist->name, 'Bar', 'dist name' ); is( $dist->vname, 'Bar-1.2', 'dist name' ); is( $dist->version, '1.2', 'dist version' ); is( $dist->is_local, 1, 'is_local is true when origin eq q{LOCAL}' ); is( $dist->is_devel, q{}, 'this is not a devel dist' ); is( $dist->path, 'F/FO/FOO/Bar-1.2.tar.gz', 'Logical archive path' ); is( $dist->native_path('here'), file(qw(here F FO FOO Bar-1.2.tar.gz)), 'Physical archive path, with base' ); is( "$dist", 'FOO/Bar-1.2.tar.gz', 'Stringifies to author/archive' ); }; #----------------------------------------------------------------------------- subtest 'author/archive/source' => sub { my $dist = make_dist_obj( author => 'FOO', archive => 'Bar-4.3_34.tgz', source => 'http://remote/Bar-4.3_34.tgz' ); is( $dist->source(), 'http://remote/Bar-4.3_34.tgz', 'Non-local source' ); is( $dist->name(), 'Bar', 'dist name' ); is( $dist->vname(), 'Bar-4.3_34', 'dist vname' ); is( $dist->version(), '4.3_34', 'dist version' ); is( $dist->is_local(), q{}, 'is_local is false when dist is remote' ); is( $dist->is_devel(), 1, 'this is a devel dist' ); }; #------------------------------------------------------------------------------ subtest 'author/archive/formats' => sub { my $dist = make_dist_obj( author => 'AUTHOR', archive => 'Foo-2.0.tar.gz' ); my %formats = ( 'm' => 'r', 'h' => 'A/AU/AUTHOR/Foo-2.0.tar.gz', 's' => 'l', 'S' => 'LOCAL', 'a' => 'AUTHOR', 'd' => 'Foo', 'D' => 'Foo-2.0', 'V' => '2.0', 'u' => 'UNKNOWN', ); while ( my ( $placeholder, $expected ) = each %formats ) { my $got = $dist->to_string("%$placeholder"); is( $got, $expected, "Placeholder: %$placeholder" ); } }; #------------------------------------------------------------------------------ done_testing; Pinto-0.14/t/02-bowels/05-compare.t000644 000766 000024 00000004561 13141540305 016621 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use Test::Exception; use lib 't/lib'; use Pinto::Tester::Util qw(make_dist_obj make_pkg_obj); #------------------------------------------------------------------------------ # Test package specification is as follows: # # dist_name-dist_mtime/pkg_name-pkg_version # # For example: # # Foo-1/Bar-0.3 # # Means pacakge Bar version 0.3 in dist Foo with mtime 1 #------------------------------------------------------------------------------ package_compare_ok( 'Dist-1/Pkg-undef', 'Dist-1/Pkg-1' ); package_compare_ok( 'Dist-1/Pkg-0', 'Dist-1/Pkg-1' ); package_compare_ok( 'Dist-1/Pkg-1', 'Dist-1/Pkg-2' ); package_compare_ok( 'Dist-1/Pkg-1', 'Dist-2/Pkg-1' ); package_compare_ok( 'Dist-1/Pkg-1.1.1', 'Dist-1/Pkg-1.1.2' ); package_compare_ok( 'Dist-1/Pkg-1.1.1', 'Dist-2/Pkg-1.1.1' ); # Exceptions throws_ok { package_compare_ok( 'Dist-1/Foo-1-0', 'Dist-1/Bar-1-1' ) } qr/packages with different names/; throws_ok { package_compare_ok( 'Dist-1/Foo-1-1', 'Dist-1/Foo-1-1' ) } qr/Unable to determine ordering/; throws_ok { package_compare_ok( 'Dist-1/Foo-1-0', 'Dist-1/Foo-1-0' ) } qr/Unable to determine ordering/; #=============================================================================== sub package_compare_ok { my ( $spec_A, $spec_B, $test_name ) = @_; $test_name = "Package A sorts before package B"; my ( $pkg_A, $pkg_B ) = map { _make_pkg($_) } ( $spec_A, $spec_B ); local $Test::Builder::Level = $Test::Builder::Level + 1; my $ok = is( $pkg_A <=> $pkg_B, -1, $test_name ); diag(" A: $spec_A \n B: $spec_B") if not $ok; return $ok; } #------------------------------------------------------------------------------ my $id = 0; sub _make_pkg { my ($spec) = @_; my ( $dist_spec, $pkg_spec ) = split '/', $spec; my ( $dist_name, $mtime ) = split '-', $dist_spec; my ( $pkg_name, $pkg_version, $is_local ) = split '-', $pkg_spec; my $dist = make_dist_obj( author => 'AUTHOR', archive => "$dist_name-0.00.tar.gz", mtime => $mtime || 0, id => $id++, ); my $pkg = make_pkg_obj( name => $pkg_name, version => $pkg_version, distribution => $dist, id => $id++, ); return $pkg; } #------------------------------------------------------------------------------ done_testing; Pinto-0.14/t/02-bowels/10-init.t000644 000766 000024 00000005310 13141540305 016123 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use Test::Exception; use lib 't/lib'; use Pinto::Tester; #------------------------------------------------------------------------------ # Test repository with master stack as default subtest 'default master stack' => sub { my $t = Pinto::Tester->new; $t->path_exists_ok( [qw(.pinto version)] ); $t->path_exists_ok( [qw(.pinto cache)] ); $t->path_exists_ok( [qw(.pinto log)] ); $t->path_exists_ok( [qw(.pinto config pinto.ini)] ); $t->path_exists_ok( [qw(.pinto db pinto.db)] ); $t->path_exists_ok( [qw(modules 02packages.details.txt.gz)] ); $t->path_exists_ok( [qw(modules 03modlist.data.gz)] ); $t->path_exists_ok( [qw(authors 01mailrc.txt.gz)] ); $t->path_exists_ok( [qw(stacks master modules 02packages.details.txt.gz)] ); $t->path_exists_ok( [qw(stacks master modules 03modlist.data.gz)] ); $t->path_exists_ok( [qw(stacks master authors 01mailrc.txt.gz)] ); my $stack = $t->pinto->repo->get_stack('master'); ok defined $stack, 'master stack exists'; is $stack->name, 'master', 'stack has correct name'; is $stack->is_default, 1, 'stack is the default stack'; is $stack->head->is_root, 1, 'stack is at root revision'; is $stack->head->is_committed, 1, 'root revision is committed'; my $repo = $t->pinto->repo; is $repo->get_version, $Pinto::Repository::REPOSITORY_VERSION, 'Repo version matches'; }; #------------------------------------------------------------------------------ # Test repository created without default stack subtest 'no default stack' => sub { my $t = Pinto::Tester->new( init_args => { no_default => 1 } ); $t->no_default_stack_ok; }; #------------------------------------------------------------------------------ # Test repository created with custom stack name subtest 'custom stack' => sub { my $t = Pinto::Tester->new( init_args => { stack => 'custom' } ); $t->stack_is_default_ok('custom'); }; #------------------------------------------------------------------------------ # Test custom config subtest 'custom config' => sub { my $config = { sources => 'MySource' }; my $t = Pinto::Tester->new( init_args => $config ); is $t->pinto->repo->config->sources, 'MySource', 'Got custom source'; }; #------------------------------------------------------------------------------ # Test schema version subtest 'check schema version' => sub { my $t = Pinto::Tester->new; my $schema_version = $t->pinto->repo->db->schema->schema_version; is $schema_version, $Pinto::Schema::SCHEMA_VERSION, 'Schema version matches'; }; #------------------------------------------------------------------------------ done_testing; Pinto-0.14/t/02-bowels/11-tester.t000644 000766 000024 00000003614 13141540305 016474 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use lib 't/lib'; use Pinto::Tester; use Pinto::Tester::Util qw(make_dist_struct parse_reg_spec); #------------------------------------------------------------------------------- subtest 'make_dist_struct' => sub { my $spec = 'AUTHOR/FooAndBar-1.2 = Foo~1.2; Bar~0.0 & Baz~3.1; Nuts~2.4'; my $struct = make_dist_struct($spec); is $struct->{cpan_author}, 'AUTHOR', 'Got author'; is $struct->{name}, 'FooAndBar', 'Got name'; is_deeply $struct->{provides}->{Foo}, { file => 'lib/Foo.pm', version => '1.2' }; is_deeply $struct->{provides}->{Bar}, { file => 'lib/Bar.pm', version => '0.0' }; is_deeply $struct->{requires}, { Baz => '3.1', Nuts => '2.4' }; is $struct->{version}, '1.2'; }; #------------------------------------------------------------------------------- subtest 'parse_reg_spec' => sub { my ( $author, $dist_archive, $pkg_name, $pkg_ver, $stack_name, $is_pinned ) = parse_reg_spec('AUTHOR/Foo-1.2/Foo~2.0/my_stack/*'); is $author, 'AUTHOR'; is $dist_archive, 'Foo-1.2.tar.gz'; is $pkg_name, 'Foo'; is $pkg_ver, '2.0'; is $stack_name, 'my_stack'; is $is_pinned, 1; }; #------------------------------------------------------------------------------- subtest 'populate' => sub { my $t = Pinto::Tester->new; $t->populate('AUTHOR/FooAndBar-1.2=Foo~1.2;Bar~0.0'); # Without .tar.gz extension $t->registration_ok('AUTHOR/FooAndBar-1.2/Foo~1.2/master'); # With .tar.gz extension $t->registration_ok('AUTHOR/FooAndBar-1.2.tar.gz/Foo~1.2/master'); # With explicit stack $t->registration_ok('AUTHOR/FooAndBar-1.2/Bar~0.0/master'); # Without explicit stack $t->registration_ok('AUTHOR/FooAndBar-1.2/Bar~0.0'); }; #------------------------------------------------------------------------------- done_testing; Pinto-0.14/t/02-bowels/12-locator.t000644 000766 000024 00000014727 13141540305 016641 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use Test::LWP::UserAgent; use JSON; use HTTP::Response; use Pinto::Target; use Pinto::Locator::Multiplex; use Pinto::Constants qw(:stratopan); use lib 't/lib'; use Pinto::Tester; #----------------------------------------------------------------------------- # We create a multiplex locator that uses stratopan and a local repository as # the upstream sources. But we will intercept requests to the stratopan # locator service and supply our own response. Then we test if the locator # returns the right location for the target (either stratopan or the mirror). #----------------------------------------------------------------------------- my $stratopan = $PINTO_STRATOPAN_CPAN_URI; my $mirror = Pinto::Tester->new->populate('AUTHOR/Dist-2 = PkgA~2'); my @sources = map { URI->new($_) } ($stratopan, $mirror); #----------------------------------------------------------------------------- my $last_warning; local $SIG{__WARN__} = sub { $last_warning = shift }; #----------------------------------------------------------------------------- subtest 'Stratopan has package' => sub { my $stratopan_location = { package => 'PkgA', version => '1', uri => "$stratopan/authors/id/A/AU/AUTHOR/Dist-1.tar.gz", }; my $target = Pinto::Target->new('PkgA'); my $ua = build_ua($target, 200, [$stratopan_location]); my $mux = build_mux(@sources); my $got = $mux->locate(target => $target); is_deeply $got, $stratopan_location, 'Located on Stratopan'; }; #----------------------------------------------------------------------------- subtest 'Mirror has package' => sub { my $mirror_location = { package => 'PkgA', version => '2', uri => "$mirror/authors/id/A/AU/AUTHOR/Dist-2.tar.gz", }; my $target = Pinto::Target->new('PkgA'); my $ua = build_ua($target, 200, []); my $mux = build_mux(@sources); my $got = $mux->locate(target => $target); is_deeply $got, $mirror_location, 'Located on mirror'; }; #----------------------------------------------------------------------------- subtest 'Nobody has package' => sub { my $target = Pinto::Target->new('PkgA==3'); my $ua = build_ua($target, 200, []); my $mux = build_mux(@sources); my $got = $mux->locate(target => $target); is $got, undef, 'Not located anywhere'; }; #----------------------------------------------------------------------------- subtest 'Want latest package (cascade)' => sub { my $stratopan_location = { package => 'PkgA', version => '1', uri => "$stratopan/authors/id/A/AU/AUTHOR/Dist-1.tar.gz", }; my $mirror_location = { package => 'PkgA', version => '2', uri => "$mirror/authors/id/A/AU/AUTHOR/Dist-2.tar.gz", }; my $target = Pinto::Target->new('PkgA'); my $ua = build_ua($target, 200, [$stratopan_location]); my $mux = build_mux(@sources); my $got = $mux->locate(target => $target, cascade => 1); is_deeply $got, $mirror_location, 'Located on mirror'; }; #----------------------------------------------------------------------------- subtest 'Stratopan not responding' => sub { my $mirror_location = { package => 'PkgA', version => '2', uri => "$mirror/authors/id/A/AU/AUTHOR/Dist-2.tar.gz", }; my $target = Pinto::Target->new('PkgA~2'); my $ua = build_ua($target, 500); my $mux = build_mux(@sources); my $got = $mux->locate(target => $target); is_deeply $got, $mirror_location, 'Located on mirror'; like $last_warning, qr/Stratopan is not responding/, 'Got warning'; }; #----------------------------------------------------------------------------- subtest 'Invalid response from Stratopan' => sub { my $mirror_location = { package => 'PkgA', version => '2', uri => "$mirror/authors/id/A/AU/AUTHOR/Dist-2.tar.gz", }; my $target = Pinto::Target->new('PkgA~2'); my $ua = build_ua($target, 200, '[this is not json}'); my $mux = build_mux(@sources); my $got = $mux->locate(target => $target); is_deeply $got, $mirror_location, 'Located on mirror'; like $last_warning, qr/Invalid response from Stratopan/, 'Got warning'; }; #----------------------------------------------------------------------------- subtest 'Stratopan has distribution' => sub { my $stratopan_location = { uri => "$stratopan/authors/id/A/AU/AUTHOR/Dist-1.tar.gz" }; my $target = Pinto::Target->new('AUTHOR/Dist-1.tar.gz'); my $ua = build_ua($target, 200, [$stratopan_location]); my $mux = build_mux(@sources); my $got = $mux->locate(target => $target); is_deeply $got, $stratopan_location, 'Located on Stratopan'; }; #----------------------------------------------------------------------------- subtest 'Mirror has distribution' => sub { my $mirror_location = { uri => "$mirror/authors/id/A/AU/AUTHOR/Dist-2.tar.gz" }; my $target = Pinto::Target->new('AUTHOR/Dist-2.tar.gz'); my $ua = build_ua($target, 200, []); my $mux = build_mux(@sources); my $got = $mux->locate(target => $target); is_deeply $got, $mirror_location, 'Located on mirror'; }; #----------------------------------------------------------------------------- subtest 'Locate distribution without extension' => sub { my $mirror_location = { uri => "$mirror/authors/id/A/AU/AUTHOR/Dist-2.tar.gz" }; my $target = Pinto::Target->new('AUTHOR/Dist-2'); my $ua = build_ua($target, 200, []); my $mux = build_mux(@sources); my $got = $mux->locate(target => $target); is_deeply $got, $mirror_location, 'Located on mirror'; }; #----------------------------------------------------------------------------- sub build_mux { my (@sources) = @_; return Pinto::Locator::Multiplex->new->assemble(@sources); } #----------------------------------------------------------------------------- sub build_ua { my ($target, $status, $content) = @_; $content = encode_json($content) if ref $content; my $uri = $PINTO_STRATOPAN_LOCATOR_URI->clone; $uri->query_form(q => $target); my $ua = $Pinto::Globals::UA = Test::LWP::UserAgent->new; my $response = HTTP::Response->new($status, undef, undef, $content); $ua->map_response(qr/\Q$uri\E/, $response); $ua->map_network_response(qr/^file:/); return $ua; } #----------------------------------------------------------------------------- done_testing; Pinto-0.14/t/02-bowels/19-basic.t000644 000766 000024 00000003014 13141540305 016251 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use lib 't/lib'; use Pinto::Tester; use Pinto::Tester::Util qw(make_dist_archive); use Pinto::Util qw(sha256); #------------------------------------------------------------------------------ subtest 'make_dist_archive' => sub { my $t = Pinto::Tester->new; my $archive = make_dist_archive('AUTHOR/Dist-1 = PkgA~1 & PkgB~1'); $t->run_ok( Add => { archives => $archive, author => 'AUTHOR', recurse => 0 } ); my $dist = $t->get_distribution(author => 'AUTHOR', archive => 'Dist-1.tar.gz'); is $dist->sha256, sha256($archive), 'SHA digest'; is $dist->source, 'LOCAL', 'Dist source'; is $dist->author, 'AUTHOR', 'Dist author'; is $dist->name, 'Dist', 'Dist name'; is $dist->vname, 'Dist-1', 'Dist vname'; is $dist->version, '1', 'Dist version'; is $dist->is_devel, '', 'Dist maturity'; my @packages = $dist->packages; is scalar @packages, 1, 'Package count'; my $pkg = $packages[0]; is $pkg->name, 'PkgA', 'Package name'; is $pkg->vname, 'PkgA~1', 'Package vname'; is $pkg->version, '1', 'Package version'; is $pkg->file, 'lib/PkgA.pm', 'Package file'; is $pkg->is_simile, 1, 'Package is simile'; my @prereqs = $dist->prerequisites; is scalar @prereqs, 1, 'Prereq count'; my $prereq = $prereqs[0]; is $prereq->package_name, 'PkgB', 'Prereq name'; is $prereq->package_version, '1', 'Prereq version'; }; #----------------------------------------------------------------------------- done_testing; Pinto-0.14/t/02-bowels/20-add.t000644 000766 000024 00000015151 13141540305 015715 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use File::Copy; use Path::Class; use Test::More; use lib 't/lib'; use Pinto::Tester; use Pinto::Tester::Util qw(make_dist_archive); use Pinto::Util qw(sha256); #------------------------------------------------------------------------------ my $pkg1 = 'Foo~0.01'; my $pkg2 = 'Bar~0.01'; my $dist = 'Foo-Bar-0.01'; my $archive = make_dist_archive("$dist=$pkg1;$pkg2"); #------------------------------------------------------------------------------ # Adding a local dist... subtest 'add local distribution' => sub { my $t = Pinto::Tester->new; $t->run_ok( 'Add', { archives => $archive } ); $t->registration_ok("AUTHOR/$dist/$pkg1/master"); $t->registration_ok("AUTHOR/$dist/$pkg2/master"); }; #------------------------------------------------------------------------------ # Adding a local dist using custom author identity subtest 'add local distribution with custom author identity' => sub { my $t = Pinto::Tester->new; $t->run_ok( 'Add', { archives => $archive, author => 'ME'} ); $t->registration_ok("ME/$dist/$pkg1/master"); $t->registration_ok("ME/$dist/$pkg2/master"); }; #----------------------------------------------------------------------------- # Adding to alternative stack... subtest 'add to alternative stack' => sub { my $t = Pinto::Tester->new; $t->run_ok( 'New', { stack => 'dev' } ); $t->run_ok( 'Add', { archives => $archive, stack => 'dev' } ); $t->registration_ok("AUTHOR/$dist/$pkg1/dev"); $t->registration_ok("AUTHOR/$dist/$pkg2/dev"); }; #----------------------------------------------------------------------------- # Adding identical dist twice on same stack subtest 'add identical distribution to same stack more than once' => sub { my $t = Pinto::Tester->new; $t->run_ok( 'Add', { archives => $archive } ); $t->registration_ok("AUTHOR/$dist/$pkg1/master"); $t->registration_ok("AUTHOR/$dist/$pkg2/master"); $t->run_ok( 'Add', { archives => $archive } ); $t->registration_ok("AUTHOR/$dist/$pkg1/master"); $t->registration_ok("AUTHOR/$dist/$pkg2/master"); $t->stderr_like( qr/\Q$archive\E is the same/, 'Got warning about identical dist' ); # This time, with a pin $t->run_ok( 'Add', { archives => $archive, pin => 1 } ); $t->registration_ok("AUTHOR/$dist/$pkg1/master/*"); $t->registration_ok("AUTHOR/$dist/$pkg2/master/*"); }; #----------------------------------------------------------------------------- # Adding identical dist twice on different stacks subtest 'add identical distribution to different stack more than once' => sub { my $t = Pinto::Tester->new; $t->run_ok( 'Add', { archives => $archive } ); $t->registration_ok("AUTHOR/$dist/$pkg1/master"); $t->registration_ok("AUTHOR/$dist/$pkg2/master"); $t->run_ok( 'New', { stack => 'dev' } ); $t->run_ok( 'Add', { archives => $archive, stack => 'dev' } ); $t->registration_ok("AUTHOR/$dist/$pkg1/dev"); $t->registration_ok("AUTHOR/$dist/$pkg2/dev"); $t->stderr_like( qr/\Q$archive\E is the same/, 'Got warning about identical dist' ); }; #----------------------------------------------------------------------------- # Adding identical dist twice but with a pin the second time subtest 'add identical distribution twice with pin on second try' => sub { my $t = Pinto::Tester->new; $t->run_ok( 'Add', { archives => $archive } ); $t->registration_ok("AUTHOR/$dist/$pkg1/master"); $t->registration_ok("AUTHOR/$dist/$pkg2/master"); $t->run_ok( 'Add', { archives => $archive, pin => 1 } ); $t->registration_ok("AUTHOR/$dist/$pkg1/master/*"); $t->registration_ok("AUTHOR/$dist/$pkg2/master/*"); $t->stderr_like( qr/\Q$archive\E is the same/, 'Got warning about identical dist' ); }; #----------------------------------------------------------------------------- # Adding identical dists with different names subtest 'add identical distributions with different names' => sub { my $archive1 = make_dist_archive("Dist-1=A~1"); my $archive2 = file( $archive1->dir, 'MY-' . $archive1->basename ); copy( $archive1, $archive2 ) or die "Copy failed: $!"; is( sha256($archive1), sha256($archive2), 'Archives are identical' ); isnt( $archive1->basename, $archive2->basename, 'Archives have different names' ); my $t = Pinto::Tester->new; $t->run_ok( 'Add', { archives => $archive1 } ); $t->run_throws_ok( 'Add', { archives => $archive2 }, qr/\Q$archive2\E is the same .* but with different name/ ); }; #----------------------------------------------------------------------------- # Adding multiple dists to the same path subtest 'add multiple distributions to the same path' => sub { my $t = Pinto::Tester->new; # Two different dists with identical names... my $archive1 = make_dist_archive("Dist-1=A~1"); my $archive2 = make_dist_archive("Dist-1=B~2"); $t->run_ok( 'Add', { archives => $archive1 } ); $t->run_throws_ok( 'Add', { archives => $archive2 }, qr/already exists/, 'Cannot add dist to same path twice' ); $t->run_throws_ok( 'Add', { archives => $archive2 }, qr/already exists/, 'Cannot add dist to same path twice' ); $t->run_throws_ok( 'Add', { archives => 'bogus' }, qr/Some archives are missing/, 'Cannot add nonexistant archive' ); }; #----------------------------------------------------------------------------- # Adding something that requires a perl (the perl prereq should be ignored) subtest 'add something that requries a perl' => sub { my $t = Pinto::Tester->new; my $archive = make_dist_archive("Foo-1.0 = Foo~1.0 & perl~5.10"); $t->run_ok( 'Add', { archives => $archive } ); $t->registration_ok("AUTHOR/Foo-1.0/Foo~1.0"); }; #----------------------------------------------------------------------------- # Adding something that requires a core-only module (the prereq should be ignored) subtest 'add something that requires a core-only module' => sub { my $t = Pinto::Tester->new; my $archive = make_dist_archive("Foo-1.0 = Foo~1.0 & IPC::Open3~1.0"); $t->run_ok( 'Add', { archives => $archive } ); $t->registration_ok("AUTHOR/Foo-1.0/Foo~1.0"); }; #----------------------------------------------------------------------------- subtest 'Allow dry run add on locked repo' => sub { my $t = Pinto::Tester->new; $t->run_ok( 'Lock' => {} ); $t->stack_is_locked_ok('master'); $t->run_ok( 'Add', { archives => $archive, dry_run => 1 } ); $t->registration_not_ok("AUTHOR/$dist/$pkg1/master"); $t->repository_clean_ok; }; done_testing; Pinto-0.14/t/02-bowels/21-add-no-index.t000644 000766 000024 00000004151 13141540305 017433 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use File::Copy; use Path::Class; use Test::More; use lib 't/lib'; use Pinto::Tester; use Pinto::Tester::Util qw(make_dist_archive); use Pinto::Util qw(sha256); #------------------------------------------------------------------------------ subtest 'Excluding with exact match' => sub { my $t = Pinto::Tester->new; my $archive = make_dist_archive('Foo-Bar-0.01 = Foo~0.01; Bar~0.01'); $t->run_ok( Add => { archives => $archive, no_index => ['Foo'] } ); $t->registration_not_ok("AUTHOR/Foo-Bar-0.01/Foo~0.01/master"); $t->registration_ok("AUTHOR/Foo-Bar-0.01/Bar~0.01/master"); my $dist = $t->get_distribution( path => 'A/AU/AUTHOR/Foo-Bar-0.01.tar.gz' ); my @pkgs = $dist->packages; is( scalar @pkgs, 1, "Dist $dist has only one package" ); is( $pkgs[0]->name, 'Bar', "Remaining package is Bar" ); }; #----------------------------------------------------------------------------- subtest 'Excluding with regexes' => sub { my $t = Pinto::Tester->new; my $archive = make_dist_archive('Foo-Bar-0.01 = Foo~0.01; Bar~0.01; Baz~0.01'); $t->run_ok( Add => { archives => $archive, no_index => [ '/F', '/r' ] } ); $t->registration_not_ok("AUTHOR/Foo-Bar-0.01/Foo~0.01/master"); $t->registration_not_ok("AUTHOR/Foo-Bar-0.01/Bar~0.01/master"); $t->registration_ok("AUTHOR/Foo-Bar-0.01/Baz~0.01/master"); my $dist = $t->get_distribution( path => 'A/AU/AUTHOR/Foo-Bar-0.01.tar.gz' ); my @pkgs = $dist->packages; is( scalar @pkgs, 1, "Dist $dist has only one package" ); is( $pkgs[0]->name, 'Baz', "Remaining package is Baz" ); }; #----------------------------------------------------------------------------- subtest 'Excluding all packages in the dist' => sub { my $t = Pinto::Tester->new; my $archive = make_dist_archive('Foo-0.01 = Foo~0.01'); $t->run_throws_ok( Add => { archives => $archive, no_index => ['/o'] }, qr/has no packages left/, 'Cannot exclude all packages' ); }; #----------------------------------------------------------------------------- done_testing; Pinto-0.14/t/02-bowels/21-pull-vreq.t000644 000766 000024 00000003214 13141540305 017112 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use lib 't/lib'; use Pinto::Tester; use Pinto::Tester::Util qw(make_dist_archive); #------------------------------------------------------------------------------ my $source = Pinto::Tester->new; $source->populate('AUTHOR/Dist-1 = PkgA~1'); $source->populate('AUTHOR/Dist-2 = PkgB~2'); #------------------------------------------------------------------------------ subtest 'exact version' => sub { my $local = Pinto::Tester->new( init_args => { sources => $source->stack_url } ); $local->run_ok( Pull => {targets => 'PkgA@1'} ); $local->registration_ok('AUTHOR/Dist-1/PkgA~1'); $local->run_ok( Pull => {targets => 'PkgB==2'} ); $local->registration_ok('AUTHOR/Dist-2/PkgB~2'); }; #------------------------------------------------------------------------------ subtest 'not version' => sub { my $local = Pinto::Tester->new( init_args => { sources => $source->stack_url } ); $local->run_ok( Pull => {targets => 'PkgA!=2'} ); $local->registration_ok('AUTHOR/Dist-1/PkgA~1'); $local->run_throws_ok( Pull => {targets => 'PkgB!=2'}, qr/Cannot find PkgB!=2/ ); }; #------------------------------------------------------------------------------ subtest 'complex' => sub { my $local = Pinto::Tester->new( init_args => { sources => $source->stack_url } ); $local->run_ok( Pull => {targets => 'PkgA>0.5,!=2,<=4'} ); $local->registration_ok('AUTHOR/Dist-1/PkgA~1'); $local->run_throws_ok( Pull => {targets => 'PkgB>=1,<5,!=2,!=3'}, qr/Cannot find PkgB>=1,<5,!=2,!=3/ ); }; #------------------------------------------------------------------------------ done_testing; Pinto-0.14/t/02-bowels/21-pull.t000644 000766 000024 00000010715 13141540305 016143 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use lib 't/lib'; use Pinto::Tester; use Pinto::Tester::Util qw(make_dist_archive); #------------------------------------------------------------------------------ my $source = Pinto::Tester->new; $source->populate('JOHN/Baz-1.2 = Baz~1.2 & Nuts-2.3'); $source->populate('PAUL/Nuts-2.3 = Nuts~2.3'); #------------------------------------------------------------------------------ subtest 'non-recursive pull' => sub { # Non-recursive pull my $local = Pinto::Tester->new( init_args => { sources => $source->stack_url } ); $local->run_ok( 'Pull', { targets => 'Baz~1.2', recurse => 0 } ); $local->registration_ok('JOHN/Baz-1.2/Baz~1.2'); $local->registration_not_ok('PAUL/Nuts-2.3/Nuts~2.3'); }; #------------------------------------------------------------------------------ subtest 'recursive pull by package' => sub { # Recursive pull by package my $local = Pinto::Tester->new( init_args => { sources => $source->stack_url } ); my $result = $local->run_ok( 'Pull', { targets => 'Baz~1.2' } ); $local->result_changed_ok($result); $local->registration_ok('JOHN/Baz-1.2/Baz~1.2'); $local->registration_ok('PAUL/Nuts-2.3/Nuts~2.3'); # Re-pulling $result = $local->run_ok( 'Pull', { targets => 'Baz~1.2' } ); $local->result_not_changed_ok($result); }; #------------------------------------------------------------------------------ subtest 'recursive pull by distribution' => sub { # Recursive pull by distribution my $local = Pinto::Tester->new( init_args => { sources => $source->stack_url } ); my $result = $local->run_ok( 'Pull', { targets => 'JOHN/Baz-1.2.tar.gz' } ); $local->result_changed_ok($result); $local->registration_ok('JOHN/Baz-1.2/Baz~1.2'); $local->registration_ok('PAUL/Nuts-2.3/Nuts~2.3'); # Re-pulling $result = $local->run_ok( 'Pull', { targets => 'JOHN/Baz-1.2.tar.gz' } ); $local->result_not_changed_ok($result); }; #------------------------------------------------------------------------------ subtest 'pull non-existant package' => sub { # Pull non-existant package my $local = Pinto::Tester->new( init_args => { sources => $source->stack_url } ); $local->run_throws_ok( 'Pull', { targets => 'Nowhere~1.2' }, qr/Cannot find Nowhere~1.2 anywhere/ ); }; #------------------------------------------------------------------------------ subtest 'pull non-existant distribution' => sub { # Pull non-existant dist my $local = Pinto::Tester->new( init_args => { sources => $source->stack_url } ); $local->run_throws_ok( 'Pull', { targets => 'JOHN/Nowhere-1.2.tar.gz' }, qr{Cannot find JOHN/Nowhere-1.2.tar.gz anywhere} ); }; #------------------------------------------------------------------------------ subtest 'pull core-only module' => sub { # Pull a core-only module (should be ignored) my $local = Pinto::Tester->new( init_args => { sources => $source->stack_url } ); $local->run_ok( Pull => { targets => 'IPC::Open3' } ); $local->stderr_like(qr/Skipping IPC::Open3~0: included in perl/); $local->repository_clean_ok; }; #------------------------------------------------------------------------------ subtest 'pull new distribution with overlapping packages' => sub { # When pulling a new dist, any overlapping packages from an existing # distribution with the same packages should be removed. In this case # it is PkgA and PkgC my $t = Pinto::Tester->new; $t->populate('AUTHOR/Dist-1 = PkgA~1; PkgB~1'); $t->populate('AUTHOR/Dist-2 = PkgC~1'); $t->registration_ok('AUTHOR/Dist-1/PkgA~1'); $t->registration_ok('AUTHOR/Dist-1/PkgB~1'); $t->registration_ok('AUTHOR/Dist-2/PkgC~1'); $t->populate('AUTHOR/Dist-3 = PkgB~3; PkgC~3'); $t->registration_not_ok('AUTHOR/Dist-1/PkgA~1'); $t->registration_not_ok('AUTHOR/Dist-1/PkgB~1'); $t->registration_not_ok('AUTHOR/Dist-2/PkgC~2'); $t->registration_ok('AUTHOR/Dist-3/PkgB~3'); $t->registration_ok('AUTHOR/Dist-3/PkgC~3'); }; #------------------------------------------------------------------------------ subtest 'Allow dry run pull on locked repo' => sub { # Non-recursive pull my $local = Pinto::Tester->new( init_args => { sources => $source->stack_url } ); $local->run_ok( 'Lock' => {} ); $local->stack_is_locked_ok('master'); $local->run_ok( 'Pull', { dry_run => 1, targets => 'Baz~1.2', recurse => 0 } ); $local->repository_clean_ok; }; done_testing; Pinto-0.14/t/02-bowels/22-add-deep.t000644 000766 000024 00000010204 13141540305 016624 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use lib 't/lib'; use Pinto::Tester; use Pinto::Tester::Util qw(make_dist_archive); #------------------------------------------------------------------------------ my $source = Pinto::Tester->new; $source->populate('JOHN/Baz-1.2 = Baz~1.2 & Nuts~2.3'); $source->populate('PAUL/Nuts-2.3 = Nuts~2.3'); #------------------------------------------------------------------------------ # Adding an archive with deep dependencies... subtest 'add archive with deep dependencies' => sub { my $archive = make_dist_archive("ME/Foo-Bar-0.01 = Foo~0.01; Bar~0.01 & Baz~1.2"); my $local = Pinto::Tester->new( init_args => { sources => $source->stack_url } ); $local->run_ok( 'Add', { archives => $archive, author => 'ME' } ); $local->registration_ok('ME/Foo-Bar-0.01/Foo~0.01'); $local->registration_ok('ME/Foo-Bar-0.01/Bar~0.01'); $local->registration_ok('JOHN/Baz-1.2/Baz~1.2'); $local->registration_ok('PAUL/Nuts-2.3/Nuts~2.3'); }; #------------------------------------------------------------------------------ # Adding an archive that has deep unsatisfiable dependencies... subtest 'add archive with deep unsatisfiable dependencies' => sub { my $archive = make_dist_archive("ME/Foo-Bar-0.01 = Foo~0.01; Bar~0.01 & Baz~2.4"); my $local = Pinto::Tester->new( init_args => { sources => $source->stack_url } ); $local->run_throws_ok( 'Add', { archives => $archive, author => 'ME' }, qr/Cannot find Baz~2.4 anywhere/ ); }; #----------------------------------------------------------------------------- # Adding an archive that depends on a perl subtest 'add archive that depends on a perl' => sub { my $archive = make_dist_archive("ME/Foo-0.01 = Foo~0.01 & perl~5.10.1"); my $local = Pinto::Tester->new( init_args => { sources => $source->stack_url } ); $local->run_ok( 'Add', { archives => $archive, author => 'ME' } ); $local->registration_ok('ME/Foo-0.01/Foo~0.01'); }; #----------------------------------------------------------------------------- # Adding an archive that depends on a core module subtest 'add archive that depends on a core module' => sub { my $archive = make_dist_archive("ME/Foo-0.01 = Foo~0.01 & Scalar::Util~1.13"); my $local = Pinto::Tester->new( init_args => { sources => $source->stack_url } ); $local->run_ok( 'Add', { archives => $archive, author => 'ME' } ); $local->registration_ok('ME/Foo-0.01/Foo~0.01'); }; #------------------------------------------------------------------------------ subtest 'add archive that causes downgrade' => sub { my $local = Pinto::Tester->new; my $foo2 = make_dist_archive('Foo-2 = Foo~2'); my $foo1 = make_dist_archive('Foo-1 = Foo~1'); $local->run_ok( Add => { author => 'ME', archives => $foo2 } ); $local->run_ok( Add => { author => 'ME', archives => $foo1 } ); # Notice we added Foo~1 and *then* Foo~1. So we are downgrading $local->stderr_like(qr{Downgrading package ME/Foo-2/Foo~2 to ME/Foo-1/Foo~1}); # Repository now contains both Foo~1 and Foo~2, but only the # older Foo~1 is actually registered on the stack. $local->registration_ok('ME/Foo-1.tar.gz/Foo~1'); $local->registration_not_ok('ME/Foo-2.tar.gz/Foo~2'); # When we add Bar-1, the stack should still only have Foo~1, even though the # newer Foo~2 is available in the repository. Because Bar only requires Foo~1. my $bar1 = make_dist_archive('Bar-1 = Bar~1 & Foo~1'); $local->run_ok( Add => { author => 'ME', archives => $bar1 } ); $local->registration_ok('ME/Foo-1.tar.gz/Foo~1'); $local->registration_ok('ME/Bar-1.tar.gz/Bar~1'); # Now add Bar-2, which requires newer Foo~2 my $bar2 = make_dist_archive('Bar-2 = Bar~2 & Foo~2'); $local->run_ok( Add => { author => 'ME', archives => $bar2 } ); # The stack should upgrade to Foo~2 to satisfy prereqs $local->registration_ok('ME/Foo-2.tar.gz/Foo~2'); $local->registration_ok('ME/Bar-2.tar.gz/Bar~2'); $local->registration_not_ok('ME/Foo-1.tar.gz/Foo~1'); $local->registration_not_ok('ME/Bar-1.tar.gz/Bar~1'); }; #----------------------------------------------------------------------------- done_testing; Pinto-0.14/t/02-bowels/23-pull-multi.t000644 000766 000024 00000004201 13141540305 017266 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use lib 't/lib'; use Pinto::Tester; #------------------------------------------------------------------------------ my $source_1 = Pinto::Tester->new; $source_1->populate( 'JOHN/DistA-1 = PkgA~1 & PkgB~1', 'JOHN/DistB-1 = PkgB~1 & PkgC~2', 'JOHN/DistC-1 = PkgC~1', 'JOHN/DistD-1 = PkgD~1 & PkgC~1' ); my $source_2 = Pinto::Tester->new; $source_2->populate( 'FRED/DistB-1 = PkgB~1', 'FRED/DistC-2 = PkgC~2' ); my $sources = sprintf '%s %s', $source_1->stack_url, $source_2->stack_url; #------------------------------------------------------------------------------ subtest 'simple multi' => sub { # DistB-1 requires PkgC-2. Source 1 only has PkgC-1, but source 2 has PkgC-2 my $local = Pinto::Tester->new( init_args => { sources => $sources } ); $local->run_ok( 'Pull', { targets => 'PkgA~1' } ); $local->registration_ok('JOHN/DistA-1/PkgA~1'); $local->registration_ok('JOHN/DistB-1/PkgB~1'); $local->registration_ok('FRED/DistC-2/PkgC~2'); }; #------------------------------------------------------------------------------ subtest 'complex multi' => sub { # DistD-1 requires PkgC-1. Source 1 has PkgC-1, but source 2 has even # newer PkgC-2. Since Source 1 is the first source, we should only get PkgC~1. my $local = Pinto::Tester->new( init_args => { sources => $sources } ); $local->run_ok( 'Pull', { targets => 'PkgD~1' } ); $local->registration_ok('JOHN/DistD-1/PkgD~1'); $local->registration_ok('JOHN/DistC-1/PkgC~1'); }; #------------------------------------------------------------------------------ subtest 'complex multi cascade' => sub { # Same as last test but with cascade => 1, we should get newer PkgC~2 # from Source 2, because it is the latest amongst all upstream repos. my $local = Pinto::Tester->new( init_args => { sources => $sources } ); $local->run_ok( 'Pull', { targets => 'PkgD~1', cascade => 1 } ); $local->registration_ok('JOHN/DistD-1/PkgD~1'); $local->registration_ok('FRED/DistC-2/PkgC~2'); }; #------------------------------------------------------------------------------ done_testing; Pinto-0.14/t/02-bowels/24-skip-prereqs.t000644 000766 000024 00000004361 13141540305 017617 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use lib 't/lib'; use Pinto::Tester; use Pinto::Tester::Util qw(make_dist_archive); #------------------------------------------------------------------------------ my $t1 = Pinto::Tester->new; # Empty upstream repository my $t2 = Pinto::Tester->new(init_args => {sources => $t1->stack_url}); my $archive = make_dist_archive('AUTHOR/DistA-1 = PkgA~1 & PkgB~1; PkgC~1'); my $expected_registration = 'AUTHOR/DistA-1/PkgA~1'; #------------------------------------------------------------------------------ subtest 'Skip all missing prereqs when adding' => sub { $t2->run_ok( Add => { archives => $archive, skip_all_missing_prerequisites => 1 } ); $t2->stderr_like(qr/Cannot find PkgB~1 anywhere. Skipping it/); $t2->registration_ok($expected_registration); }; #------------------------------------------------------------------------------ subtest 'Skip all missing prereqs when pulling' => sub { my $stack = 'foo'; $t2->run_ok( New => {stack => $stack}); $t2->stack_is_empty_ok($stack); $t2->run_ok( Pull => {targets => 'PkgA', stack => $stack, skip_all_missing_prerequisites => 1 }); $t2->stderr_like(qr/Cannot find PkgB~1 anywhere. Skipping it/); $t2->registration_ok("$expected_registration/$stack"); }; #------------------------------------------------------------------------------ subtest 'Skip all named missing prereqs when pulling' => sub { my $stack = 'bar'; $t2->run_ok( New => {stack => $stack}); $t2->stack_is_empty_ok($stack); $t2->run_ok( Pull => {targets => 'PkgA', stack => $stack, skip_missing_prerequisite => [qw(PkgB PkgC)] }); $t2->stderr_like(qr/Cannot find PkgB~1 anywhere. Skipping it/); $t2->registration_ok("AUTHOR/DistA-1/PkgA~1/bar/$stack"); }; #------------------------------------------------------------------------------ subtest 'Skip just some named missing prereqs when pulling' => sub { my $stack = 'baz'; $t2->run_ok( New => {stack => $stack}); $t2->stack_is_empty_ok($stack); $t2->run_throws_ok( Pull => {targets => 'PkgA', stack => $stack, skip_missing_prerequisite => [qw(PkgC)] }, qr/Cannot find PkgB~1 anywhere/ ); }; #------------------------------------------------------------------------------ done_testing; Pinto-0.14/t/02-bowels/31-pin.t000644 000766 000024 00000003466 13141540305 015763 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use lib 't/lib'; use Pinto::Tester; use Pinto::Tester::Util qw(make_dist_archive); #------------------------------------------------------------------------------ my $t = Pinto::Tester->new; #------------------------------------------------------------------------------ # Add a dist and pin it... my $foo_and_bar = make_dist_archive('FooAndBar-1 = Foo~1; Bar~1'); $t->run_ok( 'Add', { author => 'ME', archives => $foo_and_bar } ); $t->run_ok( 'Pin', { targets => 'Foo' } ); $t->registration_ok('ME/FooAndBar-1/Foo~1/master/*'); $t->registration_ok('ME/FooAndBar-1/Bar~1/master/*'); # Now try and add a newer dist with an overlapping package... my $bar_and_baz = make_dist_archive('BarAndBaz-2 = Bar~2; Baz~2'); $t->run_throws_ok( 'Add', { author => 'ME', archives => $bar_and_baz }, qr{Unable to register}, 'Cannot upgrade pinned package' ); $t->stderr_like(qr{Bar is pinned}); # Now unpin the FooAndBar dist... $t->run_ok( 'Unpin', { targets => 'Foo' } ); $t->registration_ok('ME/FooAndBar-1/Foo~1/master/-'); $t->registration_ok('ME/FooAndBar-1/Bar~1/master/-'); # Try adding the newer BarAndBaz dist again... $t->run_ok( 'Add', { author => 'ME', archives => $bar_and_baz } ); $t->registration_ok('ME/BarAndBaz-2/Bar~2/master/-'); $t->registration_ok('ME/BarAndBaz-2/Baz~2/master/-'); # The older Foo and Bar packages should now be gone... $t->registration_not_ok('ME/FooAndBar-1/Foo~1/master/-'); $t->registration_not_ok('ME/FooAndBar-1/Bar~1/master/-'); # Now pin Bar... $t->run_ok( 'Pin', { targets => 'Bar' } ); # Foo-2 and Bar-2 should now be pinned... $t->registration_ok('ME/BarAndBaz-2/Bar~2/master/*'); $t->registration_ok('ME/BarAndBaz-2/Baz~2/master/*'); #------------------------------------------------------------------------------ done_testing; Pinto-0.14/t/02-bowels/32-pin-rjbs.t000644 000766 000024 00000005162 13141540305 016715 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use lib 't/lib'; use Pinto::Tester; use Pinto::Tester::Util qw(make_dist_archive); #------------------------------------------------------------------------------ # This test follows RJBS' use case.... #------------------------------------------------------------------------------ my $cpan = Pinto::Tester->new; $cpan->populate( 'JOHN/DistA-1 = PkgA~1 & PkgB~1', 'FRED/DistB-1 = PkgB~1', ); #------------------------------------------------------------------------------ my $local = Pinto::Tester->new( init_args => { sources => $cpan->stack_url } ); # PkgA requires PkgB (above). MyDist requires both PkgA and PkgB... my $archive = make_dist_archive('MyDist-1=MyPkg-1 & PkgA~1; PkgB~1'); $local->run_ok( 'Add', { archives => $archive, author => 'ME' } ); # So we should have pulled in PkgA and PkgB... $local->registration_ok('JOHN/DistA-1/PkgA~1'); $local->registration_ok('FRED/DistB-1/PkgB~1'); # Now, suppose that PkgA and PkgB both are upgraded on CPAN $cpan->populate( 'JOHN/DistA-2 = PkgA~2 & PkgB~2', 'FRED/DistB-2 = PkgB~2', ); $local->clear_cache; # Make sure we get new index from CPAN # We would like to try and upgrade to PkgA-2. So create a new stack $local->run_ok( 'Copy', { stack => 'master', to_stack => 'xxx' } ); # Now upgrade to PkgA-2 on the xxx stack $local->run_ok( 'Pull', { targets => 'PkgA~2', stack => 'xxx' } ); # We should now have the new versions of both PkgA and PkgB on stack xxx $local->registration_ok('JOHN/DistA-2/PkgA~2/xxx'); $local->registration_ok('FRED/DistB-2/PkgB~2/xxx'); # But wait! We learn that PkgB-2 breaks our app. We want to be sure # we don't upgrade that. So pin it on the master (prod) stack $local->run_ok( 'Pin', { targets => 'PkgB' } ); # Make sure PkgB-1 is now pinned on master stack $local->registration_ok('FRED/DistB-1/PkgB~1/master/*'); # Ooo! Super cool DistC-1 is released to CPAN $cpan->populate('MARK/DistC-1 = PkgC~2 & PkgB~2'); $local->clear_cache; # Make sure we get new index from CPAN # We've gotta start using DistC-1 in production! But... $local->run_throws_ok( 'Pull', { targets => 'MARK/DistC-1.tar.gz' }, qr{Unable to register} ); # DistC-1 requires PkgB-2, but were are still pinned at PkgB-1... $local->stderr_like(qr{Unable to register .* PkgB is pinned to FRED/DistB-1/PkgB~1}); # After a while, we fix our code to work with PkgB-2, so we unpin... $local->run_ok( 'Unpin', { targets => 'PkgB' } ); # Make sure PkgB-1 is not pinned on the master stack... $local->registration_ok('FRED/DistB-1/PkgB~1/master/-'); #------------------------------------------------------------------------------ done_testing; Pinto-0.14/t/02-bowels/35-delete.t000644 000766 000024 00000004175 13141540305 016441 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use lib 't/lib'; use Pinto::Tester; #------------------------------------------------------------------------------ my $t = Pinto::Tester->new; #------------------------------------------------------------------------------ my $dist_auth = 'AUTHOR'; my $dist_name = 'Dist-1.0.tar.gz'; my $dist_path = "$dist_auth/$dist_name"; my @auth_dir = qw(authors id A AU AUTHOR); my @pkgs = qw(PkgA~1 PkgB~1); my @files_to_check = ( [ @auth_dir, $dist_name ], [ @auth_dir, 'CHECKSUMS' ], [ qw(stacks master), @auth_dir, $dist_name ], [ qw(stacks master), @auth_dir, 'CHECKSUMS' ], ); #------------------------------------------------------------------------------ # Add a dist... $t->populate( "$dist_auth/$dist_name=" . join ';', @pkgs ); $t->registration_ok("$dist_auth/$dist_name/$_/master/-") for @pkgs; # Now pin it... $t->run_ok( Pin => { targets => 'PkgA' } ); $t->registration_ok("AUTHOR/Dist-1.0/$_/master/*") for @pkgs; # Make extra sure it is really there $t->path_exists_ok($_) for @files_to_check; # Get the dist so we can look it up later my $repo = $t->pinto->repo; my $dist = $repo->get_distribution( author => $dist_auth, archive => $dist_name ); ok defined $dist, "Got distribution $dist_name back from DB"; #----------------------------------------------------------------------------- # Now try to delete $t->run_throws_ok( Delete => { targets => $dist_path }, qr/cannot be deleted/ ); # Delete with force $t->run_ok( Delete => { targets => $dist_path, force => 1 } ); # Now make sure it is gone my $dist_id = $dist->id; my $schema = $repo->db->schema; is $schema->search_distribution( { id => $dist_id } )->count, 0, 'Records are gone from distribution table'; is $schema->search_package( { distribution => $dist_id } )->count, 0, 'Records are gone from package table'; is $schema->search_registration( { distribution => $dist_id } )->count, 0, 'Records are gone from registration table'; # Make extra sure it is really gone $t->path_not_exists_ok($_) for @files_to_check; #------------------------------------------------------------------------------ done_testing; Pinto-0.14/t/02-bowels/40-list.t000644 000766 000024 00000005773 13141540305 016153 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use lib 't/lib'; use Pinto::Tester; use Pinto::Tester::Util qw(make_dist_archive); #------------------------------------------------------------------------------ my $t = Pinto::Tester->new; $t->run_ok( 'New' => { stack => 'dev' } ); $t->run_ok( 'New' => { stack => 'qa' } ); my $archive1 = make_dist_archive("ME/Foo-0.01 = Foo~0.01"); my $archive2 = make_dist_archive("ME/Bar-0.02 = Bar~0.02"); my $archive3 = make_dist_archive("ME/Baz-0.03 = Baz~0.03"); $t->run_ok( 'Add' => { archives => $archive1, stack => 'dev', author => 'JOE' } ); $t->run_ok( 'Add' => { archives => $archive2, stack => 'qa', author => 'JOE' } ); $t->run_ok( 'Add' => { archives => $archive3, stack => 'qa', author => 'BOB' } ); #----------------------------------------------------------------------------- subtest 'list dev stack' => sub { $t->run_ok( 'List' => { stack => 'dev' } ); my @lines = split /\n/, ${ $t->outstr }; is scalar @lines, 1, 'Got correct number of records in listing'; like $lines[0], qr/Foo \s+ 0.01/x, 'Listing for dev stack'; }; #----------------------------------------------------------------------------- subtest 'list dev stack with specific packages' => sub { $t->run_ok( 'List' => { stack => 'qa', packages => 'B' } ); my @lines = split /\n/, ${ $t->outstr }; is scalar @lines, 2, 'Got correct number of records in listing'; like $lines[0], qr/Bar \s+ 0.02/x, 'Listing for packages matching /B/ on qa stack'; like $lines[1], qr/Baz \s+ 0.03/x, 'Listing for packages matching /B/ on qa stack'; }; #----------------------------------------------------------------------------- subtest 'list qa stack with specific authors' => sub { $t->run_ok( 'List' => { stack => 'qa', authors => '^B.B' } ); my @lines = split /\n/, ${ $t->outstr }; is scalar @lines, 1, 'Got correct number of records in listing'; like $lines[0], qr/Baz \s+ 0.03/x, 'Listing for author matching /^B.B/ on qa stack'; }; #----------------------------------------------------------------------------- subtest 'list dev stack with specific distributions' => sub { $t->run_ok( 'List' => { stack => 'dev', distributions => 'oo-' } ); my @lines = split /\n/, ${ $t->outstr }; is scalar @lines, 1, 'Got correct number of records in listing'; like $lines[0], qr/Foo \s+ 0.01/x, 'Listing for distribution matching /oo/ on qa stack'; }; #----------------------------------------------------------------------------- subtest 'list empty stack' => sub { # Testing result status... my $result; $t->run_ok( New => {stack => 'foo'}); $result = $t->pinto->run( List => { stack => 'foo' }); is $result->was_successful, 1, 'Listing an empty stack is successful'; $result = $t->pinto->run( List => { stack => 'foo', authors => 'nomatch' }); is $result->was_successful, 0, 'No matches means unsuccessful'; }; # TODO: Add tests for --all option #----------------------------------------------------------------------------- done_testing; Pinto-0.14/t/02-bowels/41-log.t000644 000766 000024 00000003740 13141540305 015752 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use Pinto::Globals; use lib 't/lib'; use Pinto::Tester; use Pinto::Tester::Util qw(make_dist_archive); #------------------------------------------------------------------------------ my $t = Pinto::Tester->new; $Pinto::Globals::current_utc_time = 0; # Freeze time to begining of epoch $Pinto::Globals::current_time_offset = 0; # Freeze local timezone to UTC $t->run_ok( Add => { stack => 'master', archives => make_dist_archive("ME/Foo-0.01 = Foo~0.01") } ); $t->run_ok( Copy => { stack => 'master', to_stack => 'branch' } ); $t->run_ok( Add => { stack => 'branch', archives => make_dist_archive("ME/Bar-0.02 = Bar~0.02") } ); #------------------------------------------------------------------------------ subtest 'log master' => sub { my $stack = 'master'; $t->run_ok( Log => { stack => $stack } ); my $msgs = () = ${ $t->outstr } =~ m/revision [0-9a-f\-]{36}/g; is $msgs, 1, "Stack $stack has correct message count"; $t->stdout_like( qr/Foo-0.01.tar.gz/, 'Log message has Foo archive' ); # TODO: Consider adding hook to set username on the Tester; $t->stdout_like( qr/User: USERNAME/, 'Log message has correct user' ); # This test might not be portable, based on locale settings: $t->stdout_like( qr/Date: Jan 1, 1970/, 'Log message has correct date' ); }; #------------------------------------------------------------------------------ subtest 'log branch' => sub { my $stack = 'branch'; $t->run_ok( Log => { stack => $stack } ); my $msgs = () = ${ $t->outstr } =~ m/revision [0-9a-f\-]{36}/g; is $msgs, 2, "Stack $stack has correct message count"; $t->stdout_like( qr/Foo-0.01.tar.gz/, 'Log messages have Foo archive' ); $t->stdout_like( qr/Bar-0.02.tar.gz/, 'Log messages have Bar archive' ); }; #----------------------------------------------------------------------------- done_testing; Pinto-0.14/t/02-bowels/42-install.t000644 000766 000024 00000012006 13141540305 016633 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use Test::File; use Test::Exception; use Path::Class qw(dir); use Capture::Tiny qw(capture_stderr); use lib 't/lib'; use Pinto::Tester; use Pinto::Tester::Util qw(has_cpanm); use Pinto::Constants qw($PINTO_MINIMUM_CPANM_VERSION); use Pinto::Util qw(tempdir); #------------------------------------------------------------------------------ # To prevent mucking with user's ~/.cpanm local $ENV{PERL_CPANM_HOME} = tempdir->stringify(); #------------------------------------------------------------------------------ plan skip_all => "Need cpanm $PINTO_MINIMUM_CPANM_VERSION or newer" unless has_cpanm($PINTO_MINIMUM_CPANM_VERSION); #------------------------------------------------------------------------------ my $t = Pinto::Tester->new; $t->populate('JOHN/DistA-1 = PkgA~1 & PkgB~1; PkgC~1'); $t->populate('PAUL/DistB-1 = PkgB~1 & PkgD~2'); $t->populate('MARK/DistC-1 = PkgC~1'); $t->populate('MARK/DistC-2 = PkgC~2; PkgD~2'); #------------------------------------------------------------------------------ subtest 'Install from default stack' => sub { my $sandbox = File::Temp->newdir; my $p5_dir = dir( $sandbox, qw(lib perl5) ); my %cpanm_opts = ( cpanm_options => { q => undef, L => $sandbox->dirname } ); my $stderr = capture_stderr { $t->run_ok( Install => { targets => ['PkgA'], %cpanm_opts } ); }; file_exists_ok( $p5_dir->file('PkgA.pm') ); file_exists_ok( $p5_dir->file('PkgB.pm') ); file_exists_ok( $p5_dir->file('PkgC.pm') ); file_exists_ok( $p5_dir->file('PkgD.pm') ); }; #------------------------------------------------------------------------------ subtest 'Install from named stack' => sub { $t->run_ok( 'New' => { stack => 'dev' } ); $t->run_ok( 'Pull' => { targets => 'PkgA', stack => 'dev' } ); my $sandbox = File::Temp->newdir; my $p5_dir = dir( $sandbox, qw(lib perl5) ); my %cpanm_opts = ( cpanm_options => { q => undef, L => $sandbox->dirname } ); my $stderr = capture_stderr { $t->run_ok( Install => { targets => ['PkgA'], stack => 'dev', %cpanm_opts } ); }; file_exists_ok( $p5_dir->file('PkgA.pm') ); file_exists_ok( $p5_dir->file('PkgB.pm') ); file_exists_ok( $p5_dir->file('PkgC.pm') ); file_exists_ok( $p5_dir->file('PkgD.pm') ); }; #------------------------------------------------------------------------------ subtest 'Install a missing target' => sub { my $sandbox = File::Temp->newdir; my $p5_dir = dir( $sandbox, qw(lib perl5) ); my %cpanm_opts = ( cpanm_options => { q => undef, L => $sandbox->dirname } ); my $stderr = capture_stderr { $t->run_throws_ok( Install => { targets => ['PkgZ'], %cpanm_opts }, qr/Installation failed/ ); }; }; #------------------------------------------------------------------------------ subtest 'Install target with unusual author ID' => sub { # Versions of cpanm before 1.6916 could not handle short author ids or those # that contained numbers and hyphens. But miyagawa agreed to support them # since they are allowed by CPAN::DistnameInfo. my $t = Pinto::Tester->new; $t->populate('FOO-22/DistA-1 = PkgA~1'); $t->populate('FO/DistB-1 = PkgB~1'); my $sandbox = File::Temp->newdir; my $p5_dir = dir( $sandbox, qw(lib perl5) ); my %cpanm_opts = ( cpanm_options => { q => undef, L => $sandbox->dirname } ); my $stderr = capture_stderr { $t->run_ok( Install => { targets => ['PkgA'], %cpanm_opts } ); $t->run_ok( Install => { targets => ['PkgB'], %cpanm_opts } ); }; file_exists_ok( $p5_dir->file('PkgA.pm') ); file_exists_ok( $p5_dir->file('PkgB.pm') ); }; #------------------------------------------------------------------------------ local $TODO = 'Fails intermittently, not sure why'; subtest 'Install a core module' => sub { # The index for a stack contains all the core modules that # are in the target_perl_version, even though the repository # doesn't actually contain perl itself. This allows installers # to cope with requests to install core modules. my $t = Pinto::Tester->new; my $sandbox = File::Temp->newdir; my $p5_dir = dir( $sandbox, qw(lib perl5) ); my %cpanm_opts = ( cpanm_options => { q => undef, L => $sandbox->dirname } ); capture_stderr { $t->run_ok( Install => { targets => ['strict'], %cpanm_opts } ); }; file_not_exists_ok( $p5_dir->file('strict.pm') ); # Inserting a dual-life module should replace the core one, and # cpanm should install it if the version is newer that core. $t->populate('AUTHOR/Strict-99 = strict~99'); capture_stderr { $t->run_ok( Install => { targets => ['strict'], %cpanm_opts } ); }; file_exists_ok( $p5_dir->file('strict.pm') ); }; #------------------------------------------------------------------------------ # TODO: Install (and maybe pull) target with complex vreq #------------------------------------------------------------------------------ done_testing; Pinto-0.14/t/02-bowels/43-install-and-pull.t000644 000766 000024 00000003141 13141540305 020346 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use Test::File; use Test::Exception; use Path::Class qw(dir); use Capture::Tiny qw(capture_stderr); use lib 't/lib'; use Pinto::Tester; use Pinto::Tester::Util qw(has_cpanm); use Pinto::Constants qw($PINTO_MINIMUM_CPANM_VERSION); use Pinto::Util qw(tempdir); #------------------------------------------------------------------------------ # To prevent mucking with user's ~/.cpanm local $ENV{PERL_CPANM_HOME} = tempdir->stringify(); #------------------------------------------------------------------------------ plan skip_all => "Need cpanm $PINTO_MINIMUM_CPANM_VERSION or newer" unless has_cpanm($PINTO_MINIMUM_CPANM_VERSION); #------------------------------------------------------------------------------ my $upstream = Pinto::Tester->new; $upstream->populate('JOHN/DistA-1 = PkgA~1'); my $local = Pinto::Tester->new( init_args => { sources => $upstream->stack_url } ); $local->populate('MARK/DistB-1 = PkgB~1 & PkgA~1'); #------------------------------------------------------------------------------ subtest 'Install while pulling upstream prereqs' => sub { my $sandbox = File::Temp->newdir; my $p5_dir = dir( $sandbox, qw(lib perl5) ); my %cpanm_opts = ( cpanm_options => { q => undef, L => $sandbox->dirname } ); my $stderr = capture_stderr { $local->run_ok( Install => { targets => ['PkgB'], %cpanm_opts, do_pull => 1 } ); }; file_exists_ok( $p5_dir->file('PkgA.pm') ); file_exists_ok( $p5_dir->file('PkgB.pm') ); }; #------------------------------------------------------------------------------ done_testing; Pinto-0.14/t/02-bowels/50-diff.t000644 000766 000024 00000005666 13141540305 016112 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use Pinto::Difference; use lib 't/lib'; use Pinto::Tester; use Pinto::Constants qw(:diff); #------------------------------------------------------------------------------ my $t = Pinto::Tester->new; $t->populate('AUTHOR/Dist-1 = PkgA~1; PkgB~1'); $t->populate('AUTHOR/Dist-2 = PkgB~2; PkgC~2'); #------------------------------------------------------------------------------ subtest 'detailed diff' => sub { local $ENV{PINTO_DIFF_STYLE} = $PINTO_DIFF_STYLE_DETAILED; my $fmt = '%a/%D/%P/%y'; my $right = $t->get_stack->head; my $left = ( $right->parents )[0]; my $expect_adds = [ 'AUTHOR/Dist-2/PkgB~2/-', 'AUTHOR/Dist-2/PkgC~2/-' ]; my $expect_dels = [ 'AUTHOR/Dist-1/PkgA~1/-', 'AUTHOR/Dist-1/PkgB~1/-' ]; my $diff = Pinto::Difference->new( left => $left, right => $right ); my @adds = map { $_->to_string($fmt) } $diff->additions; my @dels = map { $_->to_string($fmt) } $diff->deletions; is_deeply \@adds, $expect_adds, 'Got expected additions'; is_deeply \@dels, $expect_dels, 'Got expected deletions'; # If we reverse the direction of the diff, then # we should always get the opposite results... ( $right, $left ) = ( $left, $right ); ( $expect_adds, $expect_dels ) = ( $expect_dels, $expect_adds ); $diff = Pinto::Difference->new( left => $left, right => $right ); @adds = map { $_->to_string($fmt) } $diff->additions; @dels = map { $_->to_string($fmt) } $diff->deletions; is_deeply \@adds, $expect_adds, 'Got expected additions'; is_deeply \@dels, $expect_dels, 'Got expected deletions'; }; #------------------------------------------------------------------------------ subtest 'concise diff' => sub { local $ENV{PINTO_DIFF_STYLE} = $PINTO_DIFF_STYLE_CONCISE; my $fmt = '%a/%f'; my $right = $t->get_stack->head; my $left = ( $right->parents )[0]; my $expect_adds = [ 'AUTHOR/Dist-2.tar.gz' ]; my $expect_dels = [ 'AUTHOR/Dist-1.tar.gz' ]; my $diff = Pinto::Difference->new( left => $left, right => $right ); my @adds = map { $_->to_string($fmt) } $diff->additions; my @dels = map { $_->to_string($fmt) } $diff->deletions; is_deeply \@adds, $expect_adds, 'Got expected additions'; is_deeply \@dels, $expect_dels, 'Got expected deletions'; # If we reverse the direction of the diff, then we should always # get the opposite results. ( $right, $left ) = ( $left, $right ); ( $expect_adds, $expect_dels ) = ( $expect_dels, $expect_adds ); $diff = Pinto::Difference->new( left => $left, right => $right ); @adds = map { $_->to_string($fmt) } $diff->additions; @dels = map { $_->to_string($fmt) } $diff->deletions; is_deeply \@adds, $expect_adds, 'Got expected additions'; is_deeply \@dels, $expect_dels, 'Got expected deletions'; }; #------------------------------------------------------------------------------ done_testing; Pinto-0.14/t/02-bowels/51-diff-more.t000644 000766 000024 00000005464 13141540305 017047 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use Pinto::Difference; use lib 't/lib'; use Pinto::Tester; use Pinto::Constants qw(:diff); use Pinto::Tester::Util qw(make_dist_archive); #------------------------------------------------------------------------------ my $dist1 = make_dist_archive('AUTHOR/Dist-1 = PkgA~1; PkgB~1'); my $dist2 = make_dist_archive('AUTHOR/Dist-2 = PkgB~2; PkgC~2'); my $t = Pinto::Tester->new; $t->run_ok( Add => { archives => $dist1, author => 'AUTHOR', stack => 'master' } ); $t->run_ok( Copy => { stack => 'master', to_stack => 'foo' } ); $t->run_ok( Add => { archives => $dist2, author => 'AUTHOR', stack => 'foo' } ); $t->run_ok( Pin => { targets => 'PkgC', stack => 'foo' } ); local $ENV{PINTO_DIFF_STYLE} = $PINTO_DIFF_STYLE_CONCISE; #------------------------------------------------------------------------------ sub linere { map { qr{^ \Q$_\E $}mx } @_ } subtest 'basic comparisons' => sub { my @expected = ( '-[rl-] AUTHOR/Dist-1.tar.gz', '+[rl!] AUTHOR/Dist-2.tar.gz', ); # Compare by revision id my $rev0 = $t->get_stack('master')->head->uuid; my $rev1 = $t->get_stack('foo')->head->uuid; $t->run_ok( Diff => { left => $rev0, right => $rev1 } ); $t->stdout_like($_) for linere(@expected); # With abbreviated revision id $rev0 = substr( $rev0, 0, 4 ); $rev1 = substr( $rev1, 0, 4 ); $t->run_ok( Diff => { left => $rev0, right => $rev1 } ); $t->stdout_like($_) for linere(@expected); # With stack name and revision id $t->run_ok( Diff => { left => 'master', right => $rev1 } ); $t->stdout_like($_) for linere(@expected); # With a custom diff format $t->run_ok( Diff => { left => $rev0, right => $rev1, format => '%o[%F] %a/%f %s %S' } ); $t->stdout_like($_) for linere(map { "$_ l LOCAL" } @expected); }; #------------------------------------------------------------------------------ subtest 'basic comparisons with bogus data' => sub { # Error case: bogus stack name or revision id $t->run_throws_ok( Diff => { left => 'foo', right => 'bogus' }, qr/does not match any stack or revision/ ); # Forcing revision IDs to have same prefix my $rev0 = $t->get_stack('master')->head; $rev0->update( { uuid => 'aaa' . $rev0->uuid } ); my $rev1 = $t->get_stack('foo')->head; $rev1->update( { uuid => 'aaa' . $rev1->uuid } ); # Error case: ambiguous revision IDs $t->run_throws_ok( Diff => { left => undef, right => 'aaa' }, qr/is ambiguous/ ); # Error case: no default stack $t->run_ok( Default => { none => 1 } ); $t->run_throws_ok( Diff => { left => undef, right => 'foo' }, qr/default stack has not been set/ ); }; #------------------------------------------------------------------------------ done_testing; Pinto-0.14/t/02-bowels/52-intermingle.t000644 000766 000024 00000003041 13141540305 017502 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use lib 't/lib'; use Pinto::Tester; #------------------------------------------------------------------------------ subtest 'Not intermingled' => sub { my $t = Pinto::Tester->new; $t->populate('AUTHOR/Dist-1 = PkgA~1; PkgB~1'); $t->populate('AUTHOR/Dist-2 = PkgB~2; PkgC~2'); # When intermingling is not allowed (which is the default) # distributions may not overlap. Adding a distribution # with the same package as an existing one causes all # packages from the existing distribution to be removed. $t->registration_not_ok('AUTHOR/Dist-1/PkgA~1'); $t->registration_not_ok('AUTHOR/Dist-1/PkgB~1'); $t->registration_ok('AUTHOR/Dist-2/PkgB~2'); $t->registration_ok('AUTHOR/Dist-2/PkgC~2'); }; #------------------------------------------------------------------------------ subtest 'Interminged' => sub { my $t = Pinto::Tester->new(init_args => {intermingle => 1}); $t->populate('AUTHOR/Dist-1 = PkgA~1; PkgB~1'); $t->populate('AUTHOR/Dist-2 = PkgB~2; PkgC~2'); # When intermingling is allowed, distributions can overlap. # This means the stack may contain only some of the packages # in the dist. This is how PAUSE acutally behaves. $t->registration_ok('AUTHOR/Dist-1/PkgA~1'); $t->registration_not_ok('AUTHOR/Dist-1/PkgB~1'); $t->registration_ok('AUTHOR/Dist-2/PkgB~2'); $t->registration_ok('AUTHOR/Dist-2/PkgC~2'); }; #------------------------------------------------------------------------------ done_testing; Pinto-0.14/t/02-bowels/53-roots.t000644 000766 000024 00000002205 13141540305 016335 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use lib 't/lib'; use Pinto::Tester; #------------------------------------------------------------------------------ subtest 'Basic' => sub { my $t = Pinto::Tester->new; $t->populate('ME/Dist-1 = PkgA~1 & PkgB~1'); $t->populate('ME/Dist-2 = PkgB~1 & PkgC~1'); $t->populate('ME/Dist-3 = PkgC~1'); $t->populate('ME/Dist-4 = PkgD~1'); $t->run_ok( Roots => {format => '%D'}); my @lines = split /\n/, ${ $t->outstr }; is_deeply \@lines, [qw(Dist-1 Dist-4)], 'Got expected roots'; }; #------------------------------------------------------------------------------ subtest 'Circular dependency' => sub { my $t = Pinto::Tester->new; $t->populate('ME/Dist-1 = PkgA~1 & PkgB~1'); $t->populate('ME/Dist-2 = PkgB~1 & PkgA~1'); $t->run_ok( Roots => {format => '%D'}); my @lines = split /\n/, ${ $t->outstr }; # TODO: Not sure what to do with circular dependencies; # is_deeply \@lines, [qw(Dist-1 Dist-2)], 'Got expected roots in circular dependency'; }; #----------------------------------------------------------------------------- done_testing; Pinto-0.14/t/02-bowels/54-revert.t000644 000766 000024 00000006661 13141540305 016511 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use lib 't/lib'; use Pinto::Tester; #------------------------------------------------------------------------------ subtest "Revert to previous revision" => sub { my $t = Pinto::Tester->new; $t->populate('AUTHOR/Foo-1=Foo~1'); my $reg1 = 'AUTHOR/Foo-1/Foo~1'; my $rev1 = $t->get_stack->head; $t->registration_ok($reg1); $t->populate('AUTHOR/Foo-2=Foo~2'); my $reg2 = 'AUTHOR/Foo-2/Foo~2'; my $rev2 = $t->get_stack->head; $t->registration_ok($reg2); $t->run_ok(Revert => {}); isnt $t->get_stack->head->id, $rev2->id, 'Created a new revision'; $t->registration_ok($reg1, 'Reverted to rev1'); }; #------------------------------------------------------------------------------ subtest "Revert to specific revision" => sub { my $t = Pinto::Tester->new; $t->populate('AUTHOR/Foo-1=Foo~1'); my $reg1 = 'AUTHOR/Foo-1/Foo~1'; my $rev1 = $t->get_stack->head; $t->registration_ok($reg1); $t->populate('AUTHOR/Foo-2=Foo~2'); my $reg2 = 'AUTHOR/Foo-2/Foo~2'; my $rev2 = $t->get_stack->head; $t->registration_ok($reg2); $t->run_ok(Revert => {revision => "$rev1"}); isnt $t->get_stack->head->id, $rev2->id, 'Created a new revision'; $t->registration_ok($reg1, 'Reverted to rev1'); }; #------------------------------------------------------------------------------ subtest "Revert to root commit" => sub { my $t = Pinto::Tester->new; $t->populate('AUTHOR/Foo-1=Foo~1'); my $reg1 = 'AUTHOR/Foo-1/Foo~1'; my $rev1 = $t->get_stack->head; $t->registration_ok($reg1); $t->populate('AUTHOR/Foo-2=Foo~2'); my $reg2 = 'AUTHOR/Foo-2/Foo~2'; my $rev2 = $t->get_stack->head; $t->registration_ok($reg2); $t->run_ok(Revert => {revision => "0000"}); $t->stack_is_empty_ok('master'); }; #------------------------------------------------------------------------------ subtest "Revert to unrelated revision" => sub { my $t = Pinto::Tester->new; $t->populate('AUTHOR/Foo-1=Foo~1'); $t->registration_ok('AUTHOR/Foo-1/Foo~1'); my $rev1 = $t->get_stack->head; $t->run_ok(Copy => {stack => 'master', to_stack => 'other'}); $t->run_ok(Pin => {stack => 'other', targets => 'Foo'}); my $other_head = $t->get_stack('other')->head; isnt $other_head->id, $rev1->id, 'Other stack is on different rev'; $t->run_throws_ok(Revert => {stack => 'master', revision => "$other_head"}, qr/is not an ancestor/, "Reversion to unrelated revision is prohibited"); # Forcng... $t->run_ok(Revert => {stack => 'master', revision => "$other_head", force => 1}); $t->registration_ok('AUTHOR/Foo-1/Foo~1/other/*'); }; #------------------------------------------------------------------------------ subtest "Exceptions" => sub { my $t = Pinto::Tester->new; my $rev0 = $t->get_stack->head; $t->run_throws_ok(Revert => {revision => "$rev0"}, qr/is the head of stack/, "Cannot revert to the current head"); $t->run_throws_ok(Revert => {}, qr/Cannot revert past the root/, "Cannot revert beyond root"); #------------ $t->populate('AUTHOR/Foo-1=Foo~1'); $t->run_ok(Unregister => {targets => 'Foo'}); $t->stack_is_empty_ok('master'); # Same state as $rev0 $t->run_throws_ok(Revert => {revision => "$rev0"}, qr/$rev0 is identical/); }; #------------------------------------------------------------------------------ done_testing; Pinto-0.14/t/02-bowels/60-dryrun.t000644 000766 000024 00000001762 13141540305 016517 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use lib 't/lib'; use Pinto::Tester; use Pinto::Tester::Util qw(make_dist_archive); #------------------------------------------------------------------------------ my $source = Pinto::Tester->new; $source->populate('JOHN/Baz-1.2 = Baz~1.2 & Nuts~2.3'); $source->populate('PAUL/Nuts-2.3 = Nuts~2.3'); #------------------------------------------------------------------------------ # Do a bunch of operations with dry_run=1, and make sure repos is still empty subtest 'dry run leaves repo empty' => sub { my $local = Pinto::Tester->new( init_args => { sources => $source->stack_url } ); $local->run_ok( 'Pull', { dry_run => 1, targets => 'Baz~1.2' } ); $local->repository_clean_ok; my $archive = make_dist_archive('Qux-2.0 = Qux~2.0'); $local->run_ok( 'Add', { dry_run => 1, archives => $archive } ); $local->repository_clean_ok; }; #------------------------------------------------------------------------------ done_testing; Pinto-0.14/t/02-bowels/61-nofail.t000644 000766 000024 00000007175 13141540305 016451 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use lib 't/lib'; use Pinto::Tester; #------------------------------------------------------------------------------ my $source = Pinto::Tester->new; $source->populate('AUTHOR/DistA-1 = PkgA~1'); $source->populate('AUTHOR/DistB-1 = PkgB~1 & PkgD~1; PkgE~1'); # Depends on Pkge, but it does not exist! $source->populate('AUTHOR/DistC-1 = PkgC~1'); $source->populate('AUTHOR/DistD-1 = PkgD~1'); #------------------------------------------------------------------------------ # An error (missing prereq in this case) should rollback all changes... subtest 'error causes rollback of all changes' => sub { my $local = Pinto::Tester->new( init_args => { sources => $source->stack_url } ); $local->run_throws_ok( Pull => { targets => [qw(PkgA PkgB PkgC)] }, qr/Cannot find PkgE~1 anywhere/ ); # None of the packages should be registered because one failed... $local->registration_not_ok('AUTHOR/DistA-1/PkgA~1/master'); $local->registration_not_ok('AUTHOR/DistB-1/PkgB~1/master'); $local->registration_not_ok('AUTHOR/DistC-1/PkgC~1/master'); $local->registration_not_ok('AUTHOR/DistD-1/PkgD~1/master'); # And none of their archives should be on the filesystem... $local->path_not_exists_ok( [qw(stacks master authors id A AU AUTHOR DistA-1.tar.gz)] ); $local->path_not_exists_ok( [qw(stacks master authors id A AU AUTHOR DistB-1.tar.gz)] ); $local->path_not_exists_ok( [qw(stacks master authors id A AU AUTHOR DistD-1.tar.gz)] ); $local->path_not_exists_ok( [qw(stacks master authors id A AU AUTHOR DistC-1.tar.gz)] ); }; #------------------------------------------------------------------------------ # If the no_fail flag is set, then only the failed ones should be rollback... subtest 'error with no_fail flag only rolls back failed changes' => sub { my $local = Pinto::Tester->new( init_args => { sources => $source->stack_url } ); $local->run_throws_ok( Pull => { targets => [qw(PkgA PkgB PkgC)], no_fail => 1 }, qr/Cannot find PkgE~1 anywhere/, 'Result still a failure, even with no_fail' ); # We should see a log message saying that B failed, because E was missing... $local->stderr_like(qr/Cannot find PkgE~1 anywhere/); $local->stderr_like(qr/PkgB~0 failed...continuing/); # Both A and C should be registered... $local->registration_ok( 'AUTHOR/DistA-1/PkgA~1/master', 'Target before failure ok' ); $local->registration_ok( 'AUTHOR/DistC-1/PkgC~1/master', 'Target after failure ok' ); # But B (the middle target) should not... $local->registration_not_ok( 'AUTHOR/DistB-1/PkgB~1/master', 'But failed target should not be there' ); # Nor should any of B's prereqs... $local->registration_not_ok( 'AUTHOR/DistD-1/PkgD~1/master', 'Dependency of failed target was unregisted' ); # In fact, they shouldn't even exist in the DB... my $DistD = $local->pinto->repo->get_distribution( author => 'AUTHOR', archive => 'DistD-1.tar.gz' ); is $DistD, undef, 'Depedency of failed target is gone completely'; # However, the archive for B and its prereq D will still be on the filesystem... my @dist_B = qw(stacks master authors id A AU AUTHOR DistB-1.tar.gz); my @dist_D = qw(stacks master authors id A AU AUTHOR DistD-1.tar.gz); $local->path_exists_ok( \@dist_B ); $local->path_exists_ok( \@dist_D ); # If we clean up those files... $local->pinto->repo->clean_files; # Then they should both be gone... $local->path_not_exists_ok( \@dist_B ); $local->path_not_exists_ok( \@dist_D ); }; #----------------------------------------------------------------------------- done_testing; Pinto-0.14/t/02-bowels/62-commit.t000644 000766 000024 00000012256 13141540305 016466 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use lib 't/lib'; use Pinto::Tester; #------------------------------------------------------------------------------ use Pinto::Globals; local $Pinto::Globals::current_username = 'ME'; #------------------------------------------------------------------------------ my $source = Pinto::Tester->new; my $source_url = $source->stack_url; $source->populate('AUTHOR/A-1 = PkgA~1 & PkgB'); $source->populate('AUTHOR/B-1 = PkgB~1'); #------------------------------------------------------------------------------ subtest 'No message specified' => sub { my $t = Pinto::Tester->new( init_args => { sources => $source_url } ); $t->run_ok( Pull => {targets => 'PkgA'} ); my $revision = $t->get_stack->head; is $revision->username, 'ME', 'Revision was committed by ME'; is $revision->message_title, 'Pull AUTHOR/A-1.tar.gz', 'Message has correct title'; is $revision->message_body, '', 'Message body is empty'; is $revision->message, 'Pull AUTHOR/A-1.tar.gz', 'Full message is title only'; }; #------------------------------------------------------------------------------ subtest 'Use default message' => sub { my $t = Pinto::Tester->new( init_args => { sources => $source_url } ); $t->run_ok( Pull => {targets => 'PkgA', use_default_message => 1} ); my $revision = $t->get_stack->head; is $revision->username, 'ME', 'Revision was committed by ME'; is $revision->message_title, 'Pull AUTHOR/A-1.tar.gz', 'Message has correct title'; is $revision->message_body, q{}, 'Message body is empty'; is $revision->message, 'Pull AUTHOR/A-1.tar.gz', 'Full message is title only'; }; #------------------------------------------------------------------------------ subtest 'Use custom message, title only' => sub { my $t = Pinto::Tester->new( init_args => { sources => $source_url } ); $t->run_ok( Pull => {targets => 'PkgA', message => "TITLE\n\n"} ); my $revision = $t->get_stack->head; is $revision->username, 'ME', 'Revision was committed by ME'; is $revision->message_title, 'TITLE', 'Message has correct title (trailing whitespace chomped)'; is $revision->message_body, q{}, 'Message has correct body.'; is $revision->message, "TITLE\n\n", 'Full message is correct (trailing whitespace intact)'; }; #------------------------------------------------------------------------------ subtest 'Use custom message, title and body' => sub { my $t = Pinto::Tester->new( init_args => { sources => $source_url } ); $t->run_ok( Pull => {targets => 'PkgA', message => "TITLE\n\nBODY\n"} ); my $revision = $t->get_stack->head; is $revision->username, 'ME', 'Revision was committed by ME'; is $revision->message_title, 'TITLE', 'Message has correct title (trailing whitespace chomped)'; is $revision->message_body, 'BODY', 'Message has correct body (trailng whitespace chomped)'; is $revision->message, "TITLE\n\nBODY\n", 'Full message is correct (trailing whitespace intact)'; }; #------------------------------------------------------------------------------ subtest 'Custom message is just whitespace' => sub { my $t = Pinto::Tester->new( init_args => { sources => $source_url } ); $t->run_ok( Pull => {targets => 'PkgA', message => " \n \n "} ); my $revision = $t->get_stack->head; is $revision->username, 'ME', 'Revision was committed by ME'; is $revision->message_title, 'Pull AUTHOR/A-1.tar.gz', 'Message has correct title'; is $revision->message_body, q{}, 'Message body is empty'; is $revision->message, 'Pull AUTHOR/A-1.tar.gz', 'Full message is correct'; }; #------------------------------------------------------------------------------ subtest 'Targets are sorted and de-duped' => sub { my $t = Pinto::Tester->new( init_args => { sources => $source_url } ); $t->run_ok( Pull => {targets => [qw(PkgB PkgA PkgB PkgA)]} ); my $revision = $t->get_stack->head; is $revision->message_title, 'Pull AUTHOR/A-1.tar.gz, AUTHOR/B-1.tar.gz', 'Message has correct title'; }; #------------------------------------------------------------------------------ subtest 'Re-pulling target AND missing prereqs' => sub { my $t = Pinto::Tester->new( init_args => { sources => $source_url } ); $t->run_ok( Pull => {targets => 'PkgA', recurse => 0} ); # Without prereqs $t->run_ok( Pull => {targets => [qw(PkgA PkgB)], recurse => 1} ); # With prereqs my $revision = $t->get_stack->head; is $revision->message_title, 'Pull AUTHOR/A-1.tar.gz', 'Message has correct title'; }; #------------------------------------------------------------------------------ subtest 'Some targets fail' => sub { my $t = Pinto::Tester->new( init_args => { sources => $source_url } ); $t->pinto->run( Pull => {targets => [qw(PkgA PkgC)], no_fail => 1} ); my $revision = $t->get_stack->head; is $revision->message_title, 'Pull AUTHOR/A-1.tar.gz', 'Message has correct title'; }; #------------------------------------------------------------------------------ done_testing; Pinto-0.14/t/02-bowels/63-prereq-circular.t000644 000766 000024 00000002177 13141540305 020300 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use Pinto::PrerequisiteWalker; use lib 't/lib'; use Pinto::Tester; #------------------------------------------------------------------------------ my $t = Pinto::Tester->new; # Foo -> Bar -> Baz -> Foo $t->populate('AUTHOR/Foo-1 = Foo-1 & Bar~1'); $t->populate('AUTHOR/Bar-1 = Bar-1 & Baz~1'); $t->populate('AUTHOR/Baz-1 = Baz-1 & Foo~1'); #------------------------------------------------------------------------------ subtest 'handle circular prerequisites' => sub { my $cb = sub { my ($prereq) = @_; my $dist = $t->pinto->repo->get_distribution( target => $prereq->as_target ); ok defined $dist, "Got distribution for prereq $prereq"; return $dist; }; my $dist = $t->get_distribution( author => 'AUTHOR', archive => 'Foo-1.tar.gz' ); my $walker = Pinto::PrerequisiteWalker->new( start => $dist, callback => $cb ); while ( $walker->next ) { } # All we need to do is make sure we get out... ok 1, 'Escaped circular dependencies'; }; #------------------------------------------------------------------------------ done_testing; Pinto-0.14/t/02-bowels/63-prereq-core.t000644 000766 000024 00000003564 13141540305 017425 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use Pinto::PrerequisiteWalker; use lib 't/lib'; use Pinto::Tester; #------------------------------------------------------------------------------ # Module::Build was first introduced in perl 5.9.4 as 0.2805 # Module::Build~0.2808_01 entered perl in 5.10.0 my $t = Pinto::Tester->new; $t->populate('AUTHOR/Foo-1 = Foo-1 & Bar~1; perl~5.6.0; strict'); $t->populate('AUTHOR/Bar-1 = Bar-1 & Module::Build~0.2808_01'); my $dist = $t->pinto->repo->get_distribution( path => 'A/AU/AUTHOR/Foo-1.tar.gz' ); ok defined $dist, 'Got Foo distribution from repo'; my @total_prereqs = $dist->prerequisites; is scalar @total_prereqs, 3, 'Dist Foo has correct number of prereqs'; #------------------------------------------------------------------------------ my %bar = ( 'Bar' => '1' ); my %mb = ( 'Module::Build' => '0.2808_01' ); my %core = ( 'perl' => 'v5.6.0', 'strict' => '0' ); my %test_cases = ( 'v5.10.0' => {%bar}, 'v5.9.4' => { %bar, %mb }, 'v5.6.0' => { %bar, %mb }, '0' => { %bar, %mb, %core }, ); while ( my ( $pv, $expect ) = each %test_cases ) { my $walked_prereqs = {}; my $cb = sub { my ($prereq) = @_; $walked_prereqs->{ $prereq->package_name } = $prereq->package_version; return $t->pinto->repo->get_distribution( target => $prereq->as_target ); }; # If $pv is not a true value, then do not make a filter my %filter = $pv ? ( filters => [ sub { $_[0]->is_perl || $_[0]->is_core( in => $pv ) } ] ) : (); my $walker = Pinto::PrerequisiteWalker->new( start => $dist, callback => $cb, %filter ); while ( $walker->next ) { } my $test_name = "Got expected prereqs against perl version $pv"; is_deeply $walked_prereqs, $expect, $test_name; } #------------------------------------------------------------------------------ done_testing; Pinto-0.14/t/02-bowels/64-metadata.t000644 000766 000024 00000002615 13141540305 016756 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use lib 't/lib'; use Pinto::Tester; use Pinto::Tester::Util qw(make_dist_archive); #------------------------------------------------------------------------------ # TODO: What we really need here are tests that verify what happens when a dist # has broken META (or no META at all). To do that, we need to hand-roll some # broken distribution archives and ship them along as test data #------------------------------------------------------------------------------ my $t = Pinto::Tester->new; $t->populate('AUTHOR/Foo-3 = Foo-4 & Bar~1; perl~5.6.0; strict'); my $dist = $t->get_distribution( author => 'AUTHOR', archive => 'Foo-3.tar.gz' ); ok defined $dist, 'Got the distribution back'; my $meta = $dist->metadata; isa_ok $meta, 'CPAN::Meta'; is $meta->as_struct->{version}, '3', 'META has correct dist version'; is $meta->as_struct->{provides}->{Foo}->{version}, '4', 'META has correct package version'; is $meta->as_struct->{'meta-spec'}->{version}, '2', 'META has correct meta spec version'; my $prereqs = $meta->as_struct->{prereqs}; is $prereqs->{runtime}->{requires}->{Bar}, '1', 'Requires Bar~1'; is $prereqs->{runtime}->{requires}->{perl}, 'v5.6.0', 'Requires perl~5.6.0'; is $prereqs->{runtime}->{requires}->{strict}, '0', 'Requires strict~0'; #------------------------------------------------------------------------------ done_testing; Pinto-0.14/t/02-bowels/70-stack-copy.t000644 000766 000024 00000012464 13141540305 017253 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use Test::Exception; use lib 't/lib'; use Pinto::Tester; use Pinto::Tester::Util qw(make_dist_archive); #------------------------------------------------------------------------------ my $t = Pinto::Tester->new; #------------------------------------------------------------------------------ subtest 'create new stack' => sub { # Create a new stack... my $stk_name = 'dev'; $t->run_ok( New => { stack => $stk_name } ); my $stack = $t->pinto->repo->get_stack($stk_name); is $stack->name, $stk_name, 'Got correct stack name'; # Add to the stack... my $foo_and_bar_1 = make_dist_archive('FooAndBar-1 = Foo~1; Bar~1'); $t->run_ok( Add => { author => 'ME', stack => $stk_name, archives => $foo_and_bar_1 } ); # Note the time of last commit my $old_mtime = $stack->refresh->head->utc_time; # time passes sleep 2; # Add more stuff to the stack... my $foo_and_bar_2 = make_dist_archive('FooAndBar-2 = Foo~2; Bar~2'); $t->run_ok( Add => { author => 'ME', stack => $stk_name, archives => $foo_and_bar_2 } ); # Check that mtime was updated... cmp_ok $stack->refresh->head->utc_time, '>', $old_mtime, 'Updated stack mtime'; }; #------------------------------------------------------------------------------ subtest 'copy stack' => sub { # Copy dev -> qa... my $dev_stk_name = 'dev'; my $qa_stk_name = 'qa'; $t->run_ok( Copy => { stack => $dev_stk_name, to_stack => $qa_stk_name } ); my $dev_stack = $t->pinto->repo->get_stack($dev_stk_name); my $qa_stack = $t->pinto->repo->get_stack($qa_stk_name); is $qa_stack->name, $qa_stk_name, 'Got correct stack name'; is $qa_stack->description, 'Copy of stack dev', 'Got correct stack description'; is $qa_stack->head->id, $dev_stack->head->id, 'Head of copied stack points to head of original stack'; }; #------------------------------------------------------------------------------ subtest 'copy stack with changes' => sub { # Copy with extra stuff my $dev_stk_name = 'dev'; my $xtra_stk_name = 'xtra'; $t->run_ok( Copy => { stack => $dev_stk_name, to_stack => $xtra_stk_name, description => 'custom', lock => 1 } ); my $xtra_stack = $t->pinto->repo->get_stack($xtra_stk_name); is $xtra_stack->is_locked, 1, 'Copied stack is locked'; is $xtra_stack->description, 'custom', 'Copied stack has custom description'; }; #------------------------------------------------------------------------------ subtest 'mark stack as default' => sub { # Marking default stack... my $master_stack = $t->pinto->repo->get_stack; ok defined $master_stack, 'get_stack with no args returned a stack'; ok $master_stack->is_default, 'master stack is the default stack'; my $dev_stack = $t->pinto->repo->get_stack('dev'); ok defined $dev_stack, 'got the dev stack'; $dev_stack->mark_as_default; ok $dev_stack->is_default, 'dev stack is now default'; # Force reload from DB... $master_stack->discard_changes; ok !$master_stack->is_default, 'master stack is no longer default'; throws_ok { $master_stack->is_default(0) } qr/Cannot directly set is_default/, 'Setting is_default directly throws exception'; }; #------------------------------------------------------------------------------ # Mixed-case stack names... subtest 'stack with mixed-case name' => sub { $t->run_ok( New => { stack => 'MixedCase' }, 'Created stack with mixed-case name' ); ok $t->pinto->repo->get_stack('mixedcase'), 'Got stack using name with different case'; $t->path_exists_ok( [qw( stacks MixedCase)], 'Stack directory name has mixed-case name too' ); }; #------------------------------------------------------------------------------ # Exceptions... subtest 'stack exceptions' => sub { # Copy from a stack that doesn't exist $t->run_throws_ok( Copy => { stack => 'nowhere', to_stack => 'somewhere' }, qr/Stack nowhere does not exist/ ); # Copy to a stack that already exists $t->run_throws_ok( Copy => { stack => 'master', to_stack => 'dev' }, qr/Stack dev already exists/ ); # Copy to a stack that already exists, but with different case $t->run_throws_ok( Copy => { stack => 'master', to_stack => 'DeV' }, qr/Stack dev already exists/ ); # Create stack with invalid name $t->run_throws_ok( New => { stack => '$bogus@' }, qr/must be alphanumeric/ ); # Copy to stack with invalid name $t->run_throws_ok( Copy => { stack => 'master', to_stack => '$bogus@' }, qr/must be alphanumeric/ ); # Copy to stack with no name $t->run_throws_ok( Copy => { stack => 'master', to_stack => '' }, qr/must be alphanumeric/ ); # Copy to stack with undef name $t->run_throws_ok( Copy => { stack => 'master', to_stack => undef }, qr/must be alphanumeric/ ); }; #------------------------------------------------------------------------------ done_testing; Pinto-0.14/t/02-bowels/71-stack-kill.t000644 000766 000024 00000004623 13141540305 017233 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use Test::Exception; use lib 't/lib'; use Pinto::Tester; use Pinto::Tester::Util qw(make_dist_archive); #------------------------------------------------------------------------------ subtest 'kill existing master stack' => sub { my $t = Pinto::Tester->new; # Check that master stack dir exists in the first place $t->path_exists_ok( [qw(stacks master)] ); # Put archive on the master stack. my $archive = make_dist_archive('Dist-1=PkgA~1'); $t->run_ok( Add => { archives => $archive, author => 'JOHN', recurse => 0 } ); $t->registration_ok('JOHN/Dist-1/PkgA~1/master'); # Copy the "master" stack to "dev" and make it the default $t->run_ok( Copy => { stack => 'master', to_stack => 'dev', default => 1 } ); $t->registration_ok('JOHN/Dist-1/PkgA~1/dev'); $t->stack_is_default_ok('dev'); # Delete the "master" stack. $t->run_ok( Kill => { stack => 'master' } ); $t->stack_not_exists_ok('master'); # The dev stack should still be the same $t->registration_ok('JOHN/Dist-1/PkgA~1/dev'); }; #------------------------------------------------------------------------------ subtest 'kill default stack' => sub { my $t = Pinto::Tester->new; # Make sure master is the default $t->stack_is_default_ok('master'); # Try killing the default stack $t->run_throws_ok( Kill => { stack => 'master' }, qr/Cannot kill the default stack/, 'Killing default stack throws exception' ); # Is stack still there? $t->stack_exists_ok('master'); }; #------------------------------------------------------------------------------ subtest 'kill locked stack' => sub { my $t = Pinto::Tester->new( init_args => { no_default => 1 } ); $t->no_default_stack_ok; # Lock the master stack $t->run_ok( Lock => { stack => 'master' } ); $t->stack_is_locked_ok('master'); # Try killing the locked stack $t->run_throws_ok( Kill => { stack => 'master' }, qr/is locked/, 'Killing locked stack throws exception' ); # Is stack still there? $t->stack_exists_ok('master'); # Try killing locked stack with force $t->run_ok( Kill => { stack => 'master', force => 1 } ); # Is stack still there? $t->stack_not_exists_ok('master'); }; #------------------------------------------------------------------------------ done_testing; Pinto-0.14/t/02-bowels/72-stack-rename.t000644 000766 000024 00000005051 13141540305 017544 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use Test::Exception; use lib 't/lib'; use Pinto::Tester; use Pinto::Tester::Util qw(make_dist_archive); #------------------------------------------------------------------------------ subtest 'rename master stack' => sub { my $t = Pinto::Tester->new; my $archive = make_dist_archive('Dist-1=PkgA~1'); # Put archive on the master stack. $t->run_ok( Add => { archives => $archive, author => 'JOHN', recurse => 0 } ); $t->registration_ok('JOHN/Dist-1/PkgA~1/master'); # Rename the master stack. $t->run_ok( Rename => { stack => 'master', to_stack => 'dev' } ); $t->registration_ok('JOHN/Dist-1/PkgA~1/dev'); # Can't use old stack name any more throws_ok { $t->pinto->repo->get_stack('master') } qr/does not exist/; # Renamed stack should still be the default $t->stack_is_default_ok( 'dev', 'after renaming stack' ); # Check the filesystem $t->path_not_exists_ok( [qw(stacks master)] ); $t->path_exists_ok( [qw(stacks dev modules 02packages.details.txt.gz)] ); $t->path_exists_ok( [qw(stacks dev modules 03modlist.data.gz)] ); $t->path_exists_ok( [qw(stacks dev authors 01mailrc.txt.gz)] ); }; #------------------------------------------------------------------------------ subtest 'compare stacks' => sub { my $t = Pinto::Tester->new; $t->path_exists_ok( [qw(stacks master)] ); #$t->path_not_exists_ok( [qw(stacks MASTER)] ); my $master = $t->get_stack('master'); $t->run_ok( Rename => { stack => 'master', to_stack => 'MASTER' } ); my $MASTER = $t->get_stack('master'); $t->path_exists_ok( [qw(stacks MASTER)] ); #$t->path_not_exists_ok( [qw(stacks master)] ); is($master->id, $MASTER->id, 'Stacks are the same') }; #------------------------------------------------------------------------------ subtest 'rename non-existant stack' => sub { my $t = Pinto::Tester->new; $t->run_throws_ok( Rename => { stack => 'bogus', to_stack => 'whatever' }, qr/does not exist/, 'Cannot rename non-existant stack' ); $t->run_ok( New => { stack => 'existing' } ); $t->run_throws_ok( Rename => { stack => 'master', to_stack => 'existing' }, qr/already exists/, 'Cannot rename to stack that already exists' ); $t->run_throws_ok( Rename => { stack => 'existing', to_stack => 'existing' }, qr/already exists/, 'Cannot rename to stack to itself' ); }; #------------------------------------------------------------------------------ done_testing; Pinto-0.14/t/02-bowels/73-stack-lock.t000644 000766 000024 00000003377 13141540305 017237 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use lib 't/lib'; use Pinto::Tester; use Pinto::Tester::Util qw(make_dist_archive); #------------------------------------------------------------------------------ subtest 'stack lock' => sub { my $t = Pinto::Tester->new->populate('AUTHOR/Foo-1=Foo~1'); my $archive = make_dist_archive('Foo-2=Foo~2'); # First, assert stack is initially unlocked $t->stack_is_not_locked_ok('master'); # Now lock the stack $t->run_ok( Lock => {} ); $t->stack_is_locked_ok('master'); # Try and modify the stack $t->run_throws_ok( Add => { archives => $archive }, qr/is locked/, 'Cannot Add to locked stack' ); $t->run_throws_ok( Pin => { targets => 'Foo' }, qr/is locked/, 'Cannot Pin on locked stack' ); $t->run_throws_ok( Unpin => { targets => 'Foo' }, qr/is locked/, 'Cannot Unpin on locked stack' ); $t->run_throws_ok( Unregister => { targets => 'AUTHOR/Foo-1.tar.gz' }, qr/is locked/, 'Cannot Unregister from locked stack' ); $t->run_throws_ok( Register => { targets => 'AUTHOR/Foo-1.tar.gz' }, qr/is locked/, 'Cannot Register on locked stack' ); # Now unlock the stack $t->run_ok( Unlock => {} ); $t->stack_is_not_locked_ok('master'); # Try modifying again $t->run_ok( Add => { archives => $archive } ); $t->run_ok( Pin => { targets => 'Foo' } ); $t->run_ok( Unpin => { targets => 'Foo' } ); $t->run_ok( Unregister => { targets => 'AUTHOR/Foo-2.tar.gz' } ); $t->run_ok( Register => { targets => 'AUTHOR/Foo-2.tar.gz' } ); }; #------------------------------------------------------------------------------ done_testing; Pinto-0.14/t/02-bowels/74-stack-default.t000644 000766 000024 00000001631 13141540305 017723 0ustar00jeffstaff000000 000000 #!perl use Test::More; use Test::Exception; use lib 't/lib'; use Pinto::Tester; #------------------------------------------------------------------------------ subtest 'stack default' => sub { my $t = Pinto::Tester->new; $t->stack_is_default_ok('master'); $t->run_ok( New => { stack => 'dev' } ); $t->stack_is_not_default_ok('dev'); $t->run_ok( Default => { stack => 'dev' } ); $t->stack_is_default_ok('dev'); $t->stack_is_not_default_ok('master'); $t->run_ok( Default => { none => 1 } ); $t->stack_is_not_default_ok('master'); $t->stack_is_not_default_ok('dev'); $t->no_default_stack_ok; throws_ok { $t->pinto->repo->get_stack } qr/default stack has not been set/, 'There is no default stack at all'; $t->path_not_exists_ok( [qw(modules)] ); }; #------------------------------------------------------------------------------ done_testing; Pinto-0.14/t/02-bowels/75-stack-props.t000644 000766 000024 00000003607 13141540305 017450 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use Test::Exception; use lib 't/lib'; use Pinto::Tester; #------------------------------------------------------------------------------ my $t = Pinto::Tester->new; #------------------------------------------------------------------------------ subtest 'create stack' => sub { # Create a stack... my $stack = $t->pinto->repo->create_stack( name => 'test' ); # Set a property... $stack->set_property( a => 1 ); is $stack->get_property('a'), 1, 'set/get one property'; # Set several properties... $stack->set_properties( { b => 2, c => 3 } ); is_deeply $stack->get_properties, { a => 1, b => 2, c => 3 }, 'get/set many props at once'; # Copy stack... my $new_stack = $t->pinto->repo->copy_stack( stack => $stack, name => 'qa' ); my $new_props = $new_stack->get_properties; # All the copied properties should be identical is_deeply $new_props, $stack->get_properties, 'Copied stack has same properties'; # Delete a property... $new_stack->delete_property('a'); ok !exists $new_stack->get_properties->{'a'}, 'Deleted a prop'; # Delete a property by setting to empty string... $new_stack->set_property( a => '' ); ok !exists $new_stack->get_properties->{'a'}, 'Deleted a prop by setting to empty'; # Invalid property name.. throws_ok { $new_stack->set_property( 'foo#bar' => 4 ) } qr{Invalid property name}; # Property names forced to lowercase... $new_stack->set_property( SHOUTING => 4 ); ok exists $new_stack->get_properties->{'shouting'}, 'Get/Set property irrespective of case'; # Property names forced to lowercase... $new_stack->delete_property('ShOuTiNg'); ok !exists $new_stack->get_properties->{'shouting'}, 'Delete property irrespective of case'; }; #------------------------------------------------------------------------------ done_testing; Pinto-0.14/t/02-bowels/80-repo-lock.t000644 000766 000024 00000007622 13141540305 017072 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use Test::Exception; use Test::File; use lib 't/lib'; use Pinto::Tester; #------------------------------------------------------------------------------ # Setup a repository... my $t = Pinto::Tester->new; #------------------------------------------------------------------------------ subtest 'exclusive locking' => sub { note 'Testing exclusive locking'; my $pid = fork; die "fork failed: $!" unless defined $pid; if ($pid) { # parent sleep 3; # Let the child start print "Starting parent: $$\n"; my $lock_file = $t->root->file('.lock'); file_exists_ok($lock_file); local $Pinto::Locker::LOCKFILE_TIMEOUT = 5; $t->run_throws_ok( 'Nop', {}, qr/currently in use/, 'Operation denied when exclusive lock is in place' ); my $kid = wait; # Let the child finish is( $kid, $pid, "reaped correct child" ); is( $?, 0, "child finished succesfully" ); file_not_exists_ok($lock_file); $t->run_ok( 'Nop', {}, 'Operation allowed after exclusive lock is removed' ); } else { # child print "Starting child: $$\n"; require Pinto::Action::Pull; no warnings qw(redefine once); # Override the execute method to just sit and idle local *Pinto::Action::Pull::execute = sub { sleep 12; return $_[0]->result }; my $result = $t->pinto->run( 'Pull', targets => 'whatever' ); exit $result->exit_status; } }; #------------------------------------------------------------------------------ subtest 'shared locking' => sub { note 'Testing shared locking'; my $pid = fork; die "fork failed: $!" unless defined $pid; if ($pid) { # parent sleep 3; # Let the child start print "Starting parent: $$\n"; my $lock_file = $t->root->file('.lock'); file_exists_ok($lock_file); local $Pinto::Locker::LOCKFILE_TIMEOUT = 5; $t->run_ok( 'List', {}, 'Non-excusive operation allowed with shared lock' ); $t->run_throws_ok( 'Pull', { targets => 'whatever' }, qr/currently in use/, 'Exclusive operation denied when shared lock is in place' ); my $kid = wait; # Let the child finish is( $kid, $pid, "reaped correct child" ); is( $?, 0, "child finished succesfully" ); file_not_exists_ok($lock_file); } else { # child print "Starting child: $$\n"; require Pinto::Action::List; no warnings qw(redefine once); # Override the execute method to just sit and idle local *Pinto::Action::List::execute = sub { sleep 15; return $_[0]->result }; my $result = $t->pinto->run('List'); exit $result->exit_status; } }; #------------------------------------------------------------------------------ subtest 'Test stale lock file' => sub { # create dummy lock file not connected to us my $lockfile = $t->root->file('.lock'); $lockfile->touch; $t->path_exists_ok( $lockfile, 'dummy lockfile exists' ); # confirm error thrown if unable to obtain lock local $Pinto::Locker::LOCKFILE_TIMEOUT = 4; # wait 4 seconds to acquire lock local $Pinto::Locker::STALE_LOCKFILE_TIMEOUT = 0; # don't expire stale lock throws_ok { $t->pinto->repo->lock( 'EX' ) } 'Pinto::Exception', 'repo locked elsewhere'; # confirm we can steal lock local $Pinto::Locker::STALE_LOCKFILE_TIMEOUT = 2; # steal lock after 2 seconds sleep( $Pinto::Locker::STALE_LOCKFILE_TIMEOUT + 1 ); isa_ok( $t->pinto->repo->lock( 'EX' ), 'Pinto::Locker', 'steal the repo lock' ); ok( $t->pinto->repo->unlock, 'unlock repo'); $t->path_not_exists_ok( $lockfile, 'confirm lockfile removed' ); }; #------------------------------------------------------------------------------ done_testing; Pinto-0.14/t/01-common/01-types.t000644 000766 000024 00000011501 13141540305 016317 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use Test::Exception; use Path::Class; use FindBin qw($Bin); use lib dir( $Bin, 'lib' )->stringify(); use TestClass; #----------------------------------------------------------------------------- my $t = TestClass->new(); $t->file('foo/bar/baz'); is( ref $t->file(), 'Path::Class::File', 'Coerced file from string' ); $t->file('file:///foo/bar/baz'); is( $t->file, '/foo/bar/baz', 'Converted file:// URI to file path' ); $t->dir('foo/bar/baz'); is( ref $t->dir(), 'Path::Class::Dir', 'Coerced dir from string' ); $t->dir('file:///foo/bar/baz'); is( $t->dir, '/foo/bar/baz', 'Converted file:// URI to dir path' ); $t->uri('http://nuts'); is( ref $t->uri(), 'URI::http', 'Coerced URI from string' ); $t->author('foobar'); is( $t->author, 'FOOBAR', 'Author coerced to uppercase' ); lives_ok { $t->author('FOO-123') } q{Author name can contain trailing numbers}; throws_ok { $t->author('FOO_BAR') } qr/must match/, 'Author must be alphanumeric'; throws_ok { $t->author('F') } qr/must match/, 'Author must be at least 2 chars'; throws_ok { $t->author('F6') } qr/must match/, 'First 2 chars of author must be letters'; throws_ok { $t->author(undef) } qr/must match/, 'Author must not be undef'; throws_ok { $t->author('') } qr/must match/, 'Author must have length'; lives_ok { $t->stack('MyStack') } q{MyStack is a valid stack name}; lives_ok { $t->stack('My_Stack-1.2') } q{My_Stack-1.2 is a valid stack name}; throws_ok { $t->stack('foo bar!') } qr/alphanumeric/, 'StackName must be alphanumeric'; throws_ok { $t->stack(undef) } qr/alphanumeric/, 'StackName not be undef'; throws_ok { $t->stack('') } qr/alphanumeric/, 'StackName must have length'; # XXX: Do we still need StackAll? lives_ok { $t->stack_all('%') } q{StackAll as "%"}; dies_ok { $t->stack_all('') } 'Invalid StackAll'; dies_ok { $t->stack_all(undef) } 'Invalid StackAll'; dies_ok { $t->stack_all('X') } 'Invalid StackAll'; lives_ok { $t->stack_default(undef) } q{StackDefault as undef}; dies_ok { $t->stack_default('') } 'Invalid StackDefault'; dies_ok { $t->stack_default('X') } 'Invalid StackDefault'; $t->property('MyProperty'); throws_ok { $t->property('foo bar!') } qr/alphanumeric/, 'PropertyName must be alphanumeric'; throws_ok { $t->property(undef) } qr/alphanumeric/, 'PropertyName must not be undef'; throws_ok { $t->property('') } qr/alphanumeric/, 'PropertyName must have length'; $t->version(5.1); is( ref $t->version, 'version', 'Coerced version from number' ); $t->version('5.1.2'); is( ref $t->version, 'version', 'Coerced version from string' ); $t->version('v5.1.2'); is( ref $t->version, 'version', 'Coerced version from v-string' ); $t->pkg('Foo~0.01'); is( ref $t->pkg, 'Pinto::Target::Package', 'Coerced PackageSpec from string' ); is( $t->pkg->name, 'Foo', 'PackageSpec has correct name' ); is( $t->pkg->version, '0.01', 'PackageSpec has correct version' ); $t->dist('Author/subdir/Dist-1.0.tar.gz'); is( ref $t->dist, 'Pinto::Target::Distribution', 'Coerced DistributionSpec from string' ); is( $t->dist->author, 'AUTHOR', 'DistributionSpec has correct author' ); is_deeply( $t->dist->subdirs, ['subdir'], 'DistribiutionsSpec has correct subdirs' ); is( $t->dist->archive, 'Dist-1.0.tar.gz', 'DistribiutionsSpec has correct archive' ); $t->targets('author/subdir/Dist-1.0.tar.gz'); is( ref $t->targets, 'ARRAY', 'Coerced ArrayRef from string' ); is( ref $t->targets->[0], 'Pinto::Target::Distribution', 'Coereced DistributionSpec from string' ); $t->targets( [ 'Foo~1.2', 'author/subdir/Dist-1.0.tar.gz' ] ); is( ref $t->targets->[0], 'Pinto::Target::Package', 'Coerced PackageSpec in array' ); is( ref $t->targets->[1], 'Pinto::Target::Distribution', 'Coereced DistributionSpec in array' ); $t->targets( ['Foo'] ); is( ref $t->targets->[0], 'Pinto::Target::Package', 'Coerced PackageSpec in array' ); $t->revision('AA-AA'); is( $t->revision, 'aa-aa', 'Coerced RevisionID to lowercase' ); throws_ok { $t->revision('gh123') } qr/hexadecimal/, 'RevisionID must be hex'; throws_ok { $t->revision('abc') } qr/hexadecimal/, 'RevisionID must be at least 4 chars'; lives_ok { $t->color('blue') }; lives_ok { $t->color('dark red') }; dies_ok { $t->color('foo bar') } 'Invalid color thorws exception'; dies_ok { $t->color(undef) } 'undef color thorws exception'; lives_ok { $t->palette( [qw(red blue green)] ) }; dies_ok { $t->palette( [qw(red blue)] ) } 'Palette needs 3 colors'; dies_ok { $t->palette( [qw(a b c)] ) } 'Palette must be valid colors'; dies_ok { $t->palette(undef) }; dies_ok { $t->palette( [] ) }; lives_ok { $t->diffstyle('concise') } 'Valid DiffStyle'; lives_ok { $t->diffstyle('detailed') } 'Valid DiffStyle'; dies_ok { $t->diffstyle('pretty') } 'Invalid DiffStyle'; #----------------------------------------------------------------------------- done_testing; Pinto-0.14/t/01-common/02-target-package.t000644 000766 000024 00000007341 13141540305 020042 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use version; use Test::More; use Pinto::Target::Package; #------------------------------------------------------------------------------ subtest 'name from name+version string' => sub { my $target = Pinto::Target::Package->new('Foo~1.2'); is $target->name, 'Foo', 'Parsed package name from string'; is $target->version, '1.2', 'Parsed package version from string'; is "$target", 'Foo~1.2', 'Stringified Target object'; }; #------------------------------------------------------------------------------ subtest 'name from name-only string' => sub { my $target = Pinto::Target::Package->new('Foo'); is $target->name, 'Foo', 'Parsed package name from string'; is $target->version, '0', 'Parsed package version from string without version'; is "$target", 'Foo~0', 'Stringified Target object'; }; #------------------------------------------------------------------------------ subtest 'name from constructor' => sub { my $target = Pinto::Target::Package->new( name => 'Foo', version => 1.2 ); is $target->name, 'Foo', 'Constructor with normal name attribute'; is $target->version, '1.2', 'Constructor with normal version version'; is "$target", 'Foo~1.2', 'Stringified Target object'; }; #------------------------------------------------------------------------------ subtest 'version specifications' => sub { my %tests = ( '' => [ ['1.2' => 1], [undef => 1], [0 => 1], ], 'undef' => [ ['1.2' => 1], [undef => 1], [0 => 1], ], '~1.2' => [ ['1.2' => 1], ['1.3' => 1], ['1.1' => 0], [undef => 0], [0 => 0], ], '@1.2' => [ ['1.1' => 0], ['1.2' => 1], ['1.3' => 0], ['1.1' => 0], [undef => 0], [0 => 0], ], ' 1.2 ' => [ ['1.2' => 1], ['1.3' => 1], ['1.1' => 0], [undef => 0], [0 => 0], ], '~1.2, <= 1.9, != 1.5' => [ ['1.1' => 0], ['1.2' => 1], ['1.5' => 0], ['1.9' => 1], ['2.0' => 0], [undef => 0], [0 => 0], ] ); while ( my ($req, $cases) = each %tests ) { for my $case ( @$cases ) { my ($version, $expect) = @{$case}; my $target = Pinto::Target::Package->new("Foo::Bar$req"); my $got = $target->is_satisfied_by($version); ok $got, "Target $target should be satisfied by $version" if $expect; ok !$got, "Target $target should not be satisfied by $version" if not $expect; } } }; #------------------------------------------------------------------------------ subtest 'Module::Build core status' => sub { # Module::Build first introduced into core in perl 5.9.4 # Module::Build was upgraded to 0.038 in perl 5.13.11 # Module::Build became deprecated in perl 5.19.0 my $target = Pinto::Target::Package->new( name => 'Module::Build', version => 0.38 ); is $target->is_core( in => 'v5.6.1' ), 0, "$target is not core in perl 5.6.1"; is $target->is_core( in => 'v5.10.1' ), 0, "$target is not core in perl 5.10.1"; is $target->is_core( in => 'v5.14.2' ), 1, "$target is core in perl 5.14.2"; local $] = 5.013011; is $target->is_core, 1, "$target is core in *this* perl, pretending we are $]"; local $] = 5.019000; is $target->is_core, 0, "$target is deprecated in *this* perl, pretending we are $]"; }; #------------------------------------------------------------------------------ done_testing; Pinto-0.14/t/01-common/03-target-distribution.t000644 000766 000024 00000003615 13141540305 021167 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use Test::Exception; use Pinto::Target::Distribution; #------------------------------------------------------------------------------ subtest string_constructor => sub { my $target = Pinto::Target::Distribution->new('Author/subdir/Foo-1.2.tar.gz'); is $target->author, 'AUTHOR', 'author attribute'; is $target->archive, 'Foo-1.2.tar.gz', 'archive attribute'; is $target->path, 'A/AU/AUTHOR/subdir/Foo-1.2.tar.gz', 'Constructed path'; is "$target", 'AUTHOR/subdir/Foo-1.2.tar.gz', 'Stringified object'; }; #------------------------------------------------------------------------------ subtest hash_constructor => sub { my $target = Pinto::Target::Distribution->new( author => 'Author', subdirs => [qw(foo bar)], archive => 'Foo-1.2.tar.gz' ); is $target->author, 'AUTHOR', 'author attribute'; is $target->archive, 'Foo-1.2.tar.gz', 'archive attribute'; is $target->path, 'A/AU/AUTHOR/foo/bar/Foo-1.2.tar.gz', 'Constructed path'; is "$target", 'AUTHOR/foo/bar/Foo-1.2.tar.gz', 'Stringified object'; }; #------------------------------------------------------------------------------ subtest invalid_constructor => sub { throws_ok { Pinto::Target::Distribution->new('AUTHOR/') } qr{Invalid distribution target}, 'Invalid dist target'; throws_ok { Pinto::Target::Distribution->new('/Foo-1.2.tar.gz') } qr{Invalid distribution target}, 'Invalid dist target'; throws_ok { Pinto::Target::Distribution->new('Foo-1.2.tar.gz') } qr{Invalid distribution target}, 'Invalid dist target'; throws_ok { Pinto::Target::Distribution->new('') } qr{Invalid distribution target}, 'Empty dist target'; }; #------------------------------------------------------------------------------ done_testing; Pinto-0.14/t/01-common/04-util.t000644 000766 000024 00000011011 13141540305 016127 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use Test::Exception; use Path::Class; use Pinto::Util qw(:all); use Pinto::Constants qw(:all); #----------------------------------------------------------------------------- subtest 'validate globals' => sub { isnt( current_username, '__ME__', 'Actual user' ); local $Pinto::Globals::current_username = '__ME__'; is( current_username, '__ME__', 'Override user' ); isnt( current_utc_time, -9, 'Actual time' ); local $Pinto::Globals::current_utc_time = -9; is( current_utc_time, -9, 'Override time' ); isnt( current_time_offset, -9, 'Actual time offset' ); local $Pinto::Globals::current_time_offset = -9; is( current_time_offset, -9, 'Override time offset' ); isnt( is_interactive, -9, 'Actual interactive state' ); local $Pinto::Globals::is_interactive = -9; is( is_interactive, -9, 'Override interactive state' ); local $Pinto::Globals::current_username = 'foo.bar-baz'; is( current_author_id, 'FOOBARBAZ', 'Convert username to author id' ); }; #----------------------------------------------------------------------------- subtest 'validate author path' => sub { my $author = 'joseph'; my $expect = dir(qw(J JO JOSEPH)); is( Pinto::Util::author_dir($author), $expect, 'Author dir path for joseph' ); }; #----------------------------------------------------------------------------- subtest 'validate author path (short)' => sub { my $author = 'JO'; my $expect = dir(qw(J JO JO)); is( Pinto::Util::author_dir($author), $expect, 'Author dir path for JO' ); }; #----------------------------------------------------------------------------- subtest 'validate author path with base' => sub { my $author = 'Mike'; my @base = qw(a b); my $expect = dir(qw(a b M MI MIKE)); is( Pinto::Util::author_dir( @base, $author ), $expect, 'Author dir with base' ); }; #----------------------------------------------------------------------------- subtest 'find distribution' => sub { my @cases = qw( A/AU/AUTHOR/Dist-1.0.tar.gz A/AU/AUTHOR/subdir/Dist-1.0.tar.gz whatever/authors/id/A/AU/AUTHOR/subdir/Dist-1.0.tar.gz http://foo.com/whatever/authors/id/A/AU/AUTHOR/subdir/Dist-1.0.tar.gz ); my $expect_auth = 'AUTHOR'; my $expect_archive = 'Dist-1.0.tar.gz'; for my $case (@cases) { my ( $got_auth, $got_archive ) = Pinto::Util::parse_dist_path($case); is( $got_auth, $expect_auth, "Parsed author from $case" ); is( $got_archive, $expect_archive, "Parsed archive from $case" ); } }; #----------------------------------------------------------------------------- subtest 'title_text()' => sub { is( title_text("foo"), 'foo' ); is( title_text("foo\nbar"), 'foo' ); is( title_text("\nbar"), '' ); }; #----------------------------------------------------------------------------- subtest 'body_text()' => sub { is( body_text("foo"), '' ); is( body_text("foo\n"), '' ); is( body_text("foo\nbar\n"), "bar\n" ); }; #----------------------------------------------------------------------------- subtest 'indent_text()' => sub { is( indent_text("foo"), "foo" ); is( indent_text( "foo\nbar", 2 ), " foo\n bar" ); is( indent_text( "\nfoo\n\n", 2 ), " \n foo\n \n" ); }; #----------------------------------------------------------------------------- subtest 'truncate_text()' => sub { is( truncate_text( "foobar", 3 ), "foo..." ); is( truncate_text( "foobar", 6 ), "foobar" ); is( truncate_text( "foobar", 0 ), "foobar" ); is( truncate_text( "foobar", 3, '-' ), "foo-" ); }; #----------------------------------------------------------------------------- subtest 'is_blank()' => sub { is( is_blank(), 1 ); is( is_blank(""), 1 ); is( is_blank(" \n\t\r\f "), 1 ); is( is_blank("foo"), 0 ); }; #----------------------------------------------------------------------------- subtest 'diff styles' => sub { local $ENV{PINTO_DIFF_STYLE} = ''; is default_diff_style, $PINTO_DIFF_STYLE_CONCISE, 'Got default diff style'; local $ENV{PINTO_DIFF_STYLE} = 'detailed'; is default_diff_style, $PINTO_DIFF_STYLE_DETAILED, 'Got default diff style from ENV'; local $ENV{PINTO_DIFF_STYLE} = 'pretty'; throws_ok { default_diff_style() } qr/\QPINTO_DIFF_STYLE (pretty) is invalid\E/, 'Invalid default diff style from ENV'; }; #----------------------------------------------------------------------------- done_testing; Pinto-0.14/t/01-common/05-pauseconfig.t000644 000766 000024 00000002510 13141540305 017462 0ustar00jeffstaff000000 000000 #!perl use strict; use warnings; use Test::More; use File::Temp; use Pinto::Globals; #----------------------------------------------------------------------------- package Local::PauseConfig; use Moose; with qw(Pinto::Role::PauseConfig); #----------------------------------------------------------------------------- package main; sub write_temp_file { my ($content) = @_; my $temp = File::Temp->new; $temp->autoflush(1); print $temp $content; return $temp; } #----------------------------------------------------------------------------- my $pauserc = write_temp_file(<<'TEXT'); user SOMEUSER mailto somebody@example.com non_interactive TEXT #----------------------------------------------------------------------------- subtest 'Read from ~/.pause' => sub { my $obj = Local::PauseConfig->new( pauserc => $pauserc->filename ); is_deeply $obj->pausecfg, { user => "SOMEUSER", mailto => 'somebody@example.com' }; }; #----------------------------------------------------------------------------- subtest 'Override using current_author_id' => sub { local $Pinto::Globals::current_author_id = 'ME'; my $obj = Local::PauseConfig->new( pauserc => $pauserc->filename ); is_deeply $obj->pausecfg, {}; }; #----------------------------------------------------------------------------- done_testing; Pinto-0.14/t/01-common/lib/000755 000766 000024 00000000000 13141540305 015320 5ustar00jeffstaff000000 000000 Pinto-0.14/t/01-common/lib/TestClass.pm000644 000766 000024 00000003603 13141540305 017565 0ustar00jeffstaff000000 000000 package TestClass; use Moose; use Pinto::Types qw( ANSIColor ANSIColorPalette AuthorID DiffStyle Dir DistributionTarget DistributionTargetList File Io PackageTarget PackageTargetList PropertyName RevisionID StackAll StackDefault StackName TargetList Uri Version ); #----------------------------------------------------------------------------- has file => ( is => 'rw', isa => File, coerce => 1, ); has dir => ( is => 'rw', isa => Dir, coerce => 1, ); has uri => ( is => 'rw', isa => Uri, coerce => 1, ); has io => ( is => 'rw', isa => Io, coerce => 1, ); has author => ( is => 'rw', isa => AuthorID, coerce => 1, ); has stack => ( is => 'rw', isa => StackName, ); has stack_all => ( is => 'rw', isa => StackAll, ); has stack_default => ( is => 'rw', isa => StackDefault, ); has property => ( is => 'rw', isa => PropertyName, ); has version => ( is => 'rw', isa => Version, coerce => 1, ); has pkg => ( is => 'rw', isa => PackageTarget, coerce => 1, ); has pkgs => ( is => 'rw', isa => PackageTargetList, coerce => 1, ); has dist => ( is => 'rw', isa => DistributionTarget, coerce => 1, ); has dists => ( is => 'rw', isa => DistributionTargetList, coerce => 1, ); has targets => ( is => 'rw', isa => TargetList, coerce => 1, ); has revision => ( is => 'rw', isa => RevisionID, coerce => 1, ); has color => ( is => 'rw', isa => ANSIColor, ); has palette => ( is => 'rw', isa => ANSIColorPalette, ); has diffstyle => ( is => 'rw', isa => DiffStyle, ); #----------------------------------------------------------------------------- 1; Pinto-0.14/lib/App/000755 000766 000024 00000000000 13141540305 014067 5ustar00jeffstaff000000 000000 Pinto-0.14/lib/Pinto/000755 000766 000024 00000000000 13141540305 014440 5ustar00jeffstaff000000 000000 Pinto-0.14/lib/Pinto.pm000644 000766 000024 00000030635 13141540305 015005 0ustar00jeffstaff000000 000000 # ABSTRACT: Curate a repository of Perl modules package Pinto; use Moose; use MooseX::StrictConstructor; use MooseX::MarkAsMethods ( autoclean => 1 ); use Try::Tiny; use Class::Load; use Pinto::Result; use Pinto::Repository; use Pinto::Chrome::Term; use Pinto::Types qw(Dir); use Pinto::Util qw(throw); #------------------------------------------------------------------------------ # HACK: On perl-5.14.x (and possibly others) Package::Stash::XS has some funky # behavior that causes Class::Load to think that certain modules are already # loaded when they actually are not. I don't know why it happens. But loading # those modules here explicitly prevents the problem. The module may or may not # actually be used depending on your platform, and forcibly loading it anyway # seems to be innocuous. We use Class::Load quite a lot in Pinto, so this same # bug may manifest in other places too. For the moment, this these are the # only ones that I'm aware of. use Devel::StackTrace; use DateTime::TimeZone::Local::Unix; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ with qw( Pinto::Role::Plated ); #------------------------------------------------------------------------------ has root => ( is => 'ro', isa => Dir, default => $ENV{PINTO_REPOSITORY_ROOT}, coerce => 1, ); has repo => ( is => 'ro', isa => 'Pinto::Repository', default => sub { Pinto::Repository->new( root => $_[0]->root ) }, lazy => 1, ); #------------------------------------------------------------------------------ around BUILDARGS => sub { my $orig = shift; my $class = shift; my $args = $class->$orig(@_); # Grrr. Gotta avoid passing undefs to Moose my @chrome_attrs = qw(verbose quiet color); my %chrome_args = map { $_ => delete $args->{$_} } grep { exists $args->{$_} } @chrome_attrs; $args->{chrome} ||= Pinto::Chrome::Term->new(%chrome_args); return $args; }; #------------------------------------------------------------------------------ sub run { my ( $self, $action_name, @action_args ) = @_; # Divert all warnings through our chrome local $SIG{__WARN__} = sub { $self->warning($_) for @_ }; # Convert hash refs to plain hash @action_args = %{$action_args[0]} if @action_args == 1 and ref $action_args[0]; my $result = try { $self->repo->assert_sanity_ok; $self->repo->assert_version_ok; my $action = $self->create_action( $action_name => @action_args ); $self->repo->lock( $action->lock_type ); $action->execute; } catch { $self->repo->unlock; $self->error($_); Pinto::Result->new->failed( because => $_ ); } finally { $self->repo->unlock; }; return $result; } #------------------------------------------------------------------------------ sub create_action { my ( $self, $action_name, %action_args ) = @_; @action_args{qw(chrome repo)} = ( $self->chrome, $self->repo ); my $action_class = $self->load_class_for_action( name => $action_name ); my $action = $action_class->new(%action_args); return $action; } #------------------------------------------------------------------------------ sub load_class_for_action { my ( $self, %args ) = @_; my $action_name = ucfirst( $args{name} || throw 'Must specify an action name' ); my $action_class = "Pinto::Action::$action_name"; Class::Load::load_class($action_class); return $action_class; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #----------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan =head1 NAME Pinto - Curate a repository of Perl modules =head1 VERSION version 0.14 =head1 SYNOPSIS See L to create and manage a Pinto repository. See L to allow remote access to your Pinto repository. See L for more information about the Pinto tools. L for hosting your Pinto repository in the cloud. =head1 DESCRIPTION Pinto is an application for creating and managing a custom CPAN-like repository of Perl modules. The purpose of such a repository is to provide a stable, curated stack of dependencies from which you can reliably build, test, and deploy your application using the standard Perl tool chain. Pinto supports various operations for gathering and managing distribution dependencies within the repository, so that you can control precisely which dependencies go into your application. =head1 FEATURES Pinto is inspired by L, L, and L, but adds a few interesting features: =over 4 =item * Pinto supports multiple indexes A Pinto repository can have multiple indexes. Each index corresponds to a "stack" of dependencies that you can control. So you can have one stack for development, one for production, one for feature-xyz, and so on. You can also branch and merge stacks to experiment with new dependencies or upgrades. =item * Pinto helps manage incompatibles between dependencies Sometimes, you discover that a new version of a dependency is incompatible with your application. Pinto allows you to "pin" a dependency to a stack, which prevents it from being accidentally upgraded (either directly or via some other dependency). =item * Pinto has built-in version control When things go wrong, you can roll back any of the indexes in your Pinto repository to a prior revision. Also, you can view the complete history of index changes as you add or upgrade dependencies. =item * Pinto can pull archives from multiple remote repositories Pinto can pull dependencies from multiple sources, so you can create private (or public) networks of repositories that enable separate teams or individuals to collaborate and share Perl modules. =item * Pinto supports team development Pinto is suitable for small to medium-sized development teams and supports concurrent users. Pinto also has a web service interface (via L), so remote developers can use a centrally hosted repository. =item * Pinto has a robust command line interface. The L utility has commands and options to control every aspect of your Pinto repository. They are well documented and behave in the customary UNIX fashion. =item * Pinto can be extended. You can extend Pinto by creating L subclasses to perform new operations on your repository, such as extracting documentation from a distribution, or grepping the source code of several distributions. =back =head1 Pinto vs PAUSE In some ways, Pinto is similar to L. Both are capable of accepting distributions and constructing a directory structure and index that Perl installers understand. But there are some important differences: =over =item * Pinto does not promise to index exactly like PAUSE does Over the years, PAUSE has evolved complicated heuristics for dealing with all the different ways that Perl code is written and packaged. Pinto is much less sophisticated, and only aspires to produce an index that is "good enough" for most situations. =item * Pinto does not understand author permissions PAUSE has a system of assigning ownership and co-maintenance permission of modules to specific people. Pinto does not have any such permission system. All activity is logged so you can identify the culprit, but Pinto expects you to be accountable for your actions. =item * Pinto does not enforce security PAUSE requires authors to authenticate themselves before they can upload or remove modules. Pinto does not require authentication, so any user with sufficient file permission can potentially change the repository. However L does support HTTP authentication, which gives you some control over access to a remote repository. =back =head1 BUT WHERE IS THE API? For now, the Pinto API is private and subject to radical change without notice. Any API documentation you see is purely for my own references. In the meantime, the command line utilities mentioned in the L are your public user interface. =head1 SUPPORT =head2 Perldoc You can find documentation for this module with the perldoc command. perldoc Pinto =head2 Websites The following websites have more information about this module, and may be of help to you. As always, in addition to those websites please use your favorite search engine to discover more resources. =over 4 =item * MetaCPAN A modern, open-source CPAN search engine, useful to view POD in HTML format. L =item * CPAN Ratings The CPAN Ratings is a website that allows community ratings and reviews of Perl modules. L =item * CPANTS The CPANTS is a website that analyzes the Kwalitee ( code metrics ) of a distribution. L =item * CPAN Testers The CPAN Testers is a network of smokers who run automated tests on uploaded CPAN distributions. L =item * CPAN Testers Matrix The CPAN Testers Matrix is a website that provides a visual overview of the test results for a distribution on various Perls/platforms. L =item * CPAN Testers Dependencies The CPAN Testers Dependencies is a website that shows a chart of the test results of all dependencies for a distribution. L =back =head2 Internet Relay Chat You can get live help by using IRC ( Internet Relay Chat ). If you don't know what IRC is, please read this excellent guide: L. Please be courteous and patient when talking to us, as we might be busy or sleeping! You can join those networks/channels and get help: =over 4 =item * irc.perl.org You can connect to the server at 'irc.perl.org' and join this channel: #pinto then talk to this person for help: thaljef. =back =head2 Bugs / Feature Requests L =head2 Source Code The code is open to the world, and available for you to hack on. Please feel free to browse it and play with it, or whatever. If you want to contribute patches, please send me a diff or prod me to pull from your repository :) L git clone git://github.com/thaljef/Pinto.git =head1 CONTRIBUTORS =for stopwords BenRifkah Bergsten-Buret Boris Däppen brian d foy Chris Kirke Cory G Watson David Steinbrunner Ferenc Erki Florian Ragwitz Glenn Fowler hesco Jakob Voss Jeffrey Ryan Thalhammer Kahlil (Kal) Hodgson Karen Etheridge Michael G. Schwern Jemmeson Mike Raynham Nikolay Martynov Oleg Gashev popl Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Champoux =over 4 =item * BenRifkah Bergsten-Buret =item * Boris Däppen =item * brian d foy =item * Chris Kirke =item * Cory G Watson =item * David Steinbrunner =item * Ferenc Erki =item * Florian Ragwitz =item * Glenn Fowler =item * hesco =item * Jakob Voss =item * Jeffrey Ryan Thalhammer =item * Kahlil (Kal) Hodgson =item * Karen Etheridge =item * Michael G. Schwern =item * Michael Jemmeson =item * Mike Raynham =item * Nikolay Martynov =item * Oleg Gashev =item * popl =item * Steffen Schwigon =item * Tommy Stanton =item * Wolfgang Kinkeldei =item * Yanick Champoux =back =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Action/000755 000766 000024 00000000000 13141540305 015655 5ustar00jeffstaff000000 000000 Pinto-0.14/lib/Pinto/Action.pm000644 000766 000024 00000003501 13141540305 016212 0ustar00jeffstaff000000 000000 # ABSTRACT: Base class for all Actions package Pinto::Action; use Moose; use MooseX::StrictConstructor; use MooseX::Types::Moose qw(Str); use MooseX::MarkAsMethods ( autoclean => 1 ); use Pinto::Result; use Pinto::Util qw(throw); use Pinto::Constants qw($PINTO_LOCK_TYPE_SHARED); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ with qw( Pinto::Role::Plated ); #------------------------------------------------------------------------------ has repo => ( is => 'ro', isa => 'Pinto::Repository', required => 1, ); has result => ( is => 'ro', isa => 'Pinto::Result', default => sub { Pinto::Result->new }, init_arg => undef, lazy => 1, ); has lock_type => ( is => 'ro', isa => Str, default => $PINTO_LOCK_TYPE_SHARED, init_arg => undef, ); #------------------------------------------------------------------------------ sub BUILD { } #------------------------------------------------------------------------------ sub execute { throw 'Abstract method' } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Action - Base class for all Actions =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/ArchiveUnpacker.pm000644 000766 000024 00000004471 13141540305 020056 0ustar00jeffstaff000000 000000 # ABSTRACT: Unpack an archive into a temporary directory package Pinto::ArchiveUnpacker; use Moose; use MooseX::StrictConstructor; use MooseX::Types::Moose qw(Bool); use MooseX::MarkAsMethods ( autoclean => 1 ); use Cwd qw(getcwd); use Cwd::Guard qw(cwd_guard); use Path::Class qw(dir); use Archive::Extract; use File::Temp; use Pinto::Types qw(File); use Pinto::Util qw(debug throw); #----------------------------------------------------------------------------- our $VERSION = '0.14'; # VERSION #----------------------------------------------------------------------------- has archive => ( is => 'ro', isa => File, required => 1, coerce => 1, ); has temp_dir => ( is => 'ro', isa => 'File::Temp::Dir', default => sub { File::Temp->newdir( CLEANUP => $_[0]->cleanup ) }, lazy => 1, ); has cleanup => ( is => 'ro', isa => Bool, default => 1, ); #----------------------------------------------------------------------------- sub unpack { my ($self) = @_; my $archive = $self->archive; my $temp_dir = $self->temp_dir->dirname; my $cwd_guard = cwd_guard(getcwd); # Archive::Extract will chdir local $Archive::Extract::PREFER_BIN = 1; local $Archive::Extract::DEBUG = 1 if ( $ENV{PINTO_DEBUG} || 0 ) > 1; my $ae = Archive::Extract->new( archive => $archive ); debug "Unpacking $archive into $temp_dir"; my $ok = $ae->extract( to => $temp_dir ); throw "Failed to unpack $archive: " . $ae->error if not $ok; my @children = dir($temp_dir)->children; return @children == 1 && -d $children[0] ? $children[0] : dir($temp_dir); } #----------------------------------------------------------------------------- __PACKAGE__->meta->make_immutable; #----------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::ArchiveUnpacker - Unpack an archive into a temporary directory =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Chrome/000755 000766 000024 00000000000 13141540305 015655 5ustar00jeffstaff000000 000000 Pinto-0.14/lib/Pinto/Chrome.pm000644 000766 000024 00000005444 13141540305 016222 0ustar00jeffstaff000000 000000 # ABSTRACT: Base class for interactive interfaces package Pinto::Chrome; use Moose; use MooseX::StrictConstructor; use MooseX::Types::Moose qw(Int Bool); use MooseX::MarkAsMethods ( autoclean => 1 ); #----------------------------------------------------------------------------- our $VERSION = '0.14'; # VERSION #----------------------------------------------------------------------------- has verbose => ( is => 'ro', isa => Int, default => 0, ); has quiet => ( is => 'ro', isa => Bool, default => 0, ); #----------------------------------------------------------------------------- sub show { return 1 } #----------------------------------------------------------------------------- sub diag { return 1 } #----------------------------------------------------------------------------- sub edit { return $_[1] } #----------------------------------------------------------------------------- sub show_progress { return 1 } #----------------------------------------------------------------------------- sub progress_done { return 1 } #----------------------------------------------------------------------------- sub should_render_diag { my ( $self, $level ) = @_; return 1 if $level == 0; # Always, always display errors return 0 if $self->quiet; # Don't display anything else if quiet return 1 if $self->verbose + 1 >= $level; return 0; } #----------------------------------------------------------------------------- sub diag_levels { return qw(error warning notice info) } #----------------------------------------------------------------------------- my @levels = __PACKAGE__->diag_levels; __generate_diag_method( $levels[$_], $_ ) for ( 0 .. $#levels ); #----------------------------------------------------------------------------- sub __generate_diag_method { my ( $method_name, $diag_level ) = @_; my $template = <<'END_METHOD'; sub %s { my ($self, $msg, $opts) = @_; return unless $self->should_render_diag(%s); $self->diag($msg, $opts); } END_METHOD eval sprintf $template, $method_name, $diag_level; croak $@ if $@; } #----------------------------------------------------------------------------- __PACKAGE__->meta->make_immutable; #----------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Chrome - Base class for interactive interfaces =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Config.pm000644 000766 000024 00000013577 13141540305 016220 0ustar00jeffstaff000000 000000 # ABSTRACT: Internal configuration for a Pinto repository package Pinto::Config; use Moose; use MooseX::StrictConstructor; use MooseX::Types::Moose qw(Str Bool Int ArrayRef); use MooseX::MarkAsMethods ( autoclean => 1 ); use MooseX::Configuration; use MooseX::Aliases; use URI; use Pinto::Constants qw(@PINTO_DEFAULT_SOURCE_URIS); use Pinto::Types qw(Dir File Username PerlVersion); use Pinto::Util qw(current_username current_time_offset); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ # Moose attributes has root => ( is => 'ro', isa => Dir, alias => 'root_dir', required => 1, coerce => 1, ); has username => ( is => 'ro', isa => Username, default => sub { return current_username }, lazy => 1, ); has time_offset => ( is => 'ro', isa => Int, default => sub { return current_time_offset }, lazy => 1, ); has stacks_dir => ( is => 'ro', isa => Dir, init_arg => undef, default => sub { return $_[0]->root_dir->subdir('stacks') }, lazy => 1, ); has authors_dir => ( is => 'ro', isa => Dir, init_arg => undef, default => sub { return $_[0]->root_dir->subdir('authors') }, lazy => 1, ); has authors_id_dir => ( is => 'ro', isa => Dir, init_arg => undef, default => sub { return $_[0]->authors_dir->subdir('id') }, lazy => 1, ); has modules_dir => ( is => 'ro', isa => Dir, init_arg => undef, default => sub { return $_[0]->root_dir->subdir('modules') }, lazy => 1, ); has mailrc_file => ( is => 'ro', isa => File, init_arg => undef, default => sub { return $_[0]->authors_dir->file('01mailrc.txt.gz') }, lazy => 1, ); has db_dir => ( is => 'ro', isa => Dir, init_arg => undef, default => sub { return $_[0]->pinto_dir->subdir('db') }, lazy => 1, ); has db_file => ( is => 'ro', isa => File, init_arg => undef, default => sub { return $_[0]->db_dir->file('pinto.db') }, lazy => 1, ); has pinto_dir => ( is => 'ro', isa => Dir, init_arg => undef, default => sub { return $_[0]->root_dir->subdir('.pinto') }, lazy => 1, ); has config_dir => ( is => 'ro', isa => Dir, init_arg => undef, default => sub { return $_[0]->pinto_dir->subdir('config') }, lazy => 1, ); has cache_dir => ( is => 'ro', isa => Dir, init_arg => undef, default => sub { return $_[0]->pinto_dir->subdir('cache') }, lazy => 1, ); has log_dir => ( is => 'ro', isa => Dir, init_arg => undef, default => sub { return $_[0]->pinto_dir->subdir('log') }, lazy => 1, ); has version_file => ( is => 'ro', isa => File, init_arg => undef, default => sub { return $_[0]->pinto_dir->file('version') }, lazy => 1, ); has basename => ( is => 'ro', isa => Str, init_arg => undef, default => 'pinto.ini', ); #------------------------------------------------------------------------------ # Actual configurable attributes has sources => ( is => 'ro', isa => Str, key => 'sources', default => "@PINTO_DEFAULT_SOURCE_URIS", documentation => 'URIs of upstream repositories (space delimited)', ); has target_perl_version => ( is => 'ro', isa => PerlVersion, key => 'target_perl_version', documentation => 'Default target perl version for new stacks', default => $], # Note: $PERL_VERSION is broken on old perls coerce => 1, ); has recurse => ( is => 'ro', isa => Bool, key => 'recurse', documentation => 'Default recursive behavior', default => 1, ); has intermingle => ( is => 'ro', isa => Bool, key => 'intermingle', documentation => 'Allow stacks to intermingle distributions', default => 0, ); #------------------------------------------------------------------------------ sub _build_config_file { my ($self) = @_; my $config_file = $self->config_dir->file( $self->basename ); return -e $config_file ? $config_file : (); } #------------------------------------------------------------------------------ sub sources_list { my ($self) = @_; # Some folks tend to put quotes around multi-value configuration # parameters, even though they shouldn't. Be kind and remove them. my $sources = $self->sources; $sources =~ s/ ['"] //gx; return map { URI->new($_) } split m{ \s+ }mx, $sources; } #------------------------------------------------------------------------------ sub directories { my ($self) = @_; return ( $self->root_dir, $self->config_dir, $self->cache_dir, $self->authors_dir, $self->log_dir, $self->db_dir ); } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Config - Internal configuration for a Pinto repository =head1 VERSION version 0.14 =head1 DESCRIPTION This is a private module for internal use only. There is nothing for you to see here (yet). =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Constants.pm000644 000766 000024 00000013740 13141540305 016757 0ustar00jeffstaff000000 000000 # ABSTRACT: Constants used across the Pinto utilities package Pinto::Constants; use strict; use warnings; use URI; use Readonly; use Exporter qw(import); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ Readonly our @EXPORT_OK => qw( $PINTO_SERVER_DEFAULT_PORT $PINTO_SERVER_DEFAULT_HOST $PINTO_SERVER_DEFAULT_ROOT $PINTO_PROTOCOL_VERSION $PINTO_PROTOCOL_STATUS_OK $PINTO_PROTOCOL_DIAG_PREFIX $PINTO_PROTOCOL_NULL_MESSAGE $PINTO_PROTOCOL_PROGRESS_MESSAGE $PINTO_PROTOCOL_ACCEPT $PINTO_DEFAULT_PALETTE $PINTO_PALETTE_COLOR_0 $PINTO_PALETTE_COLOR_1 $PINTO_PALETTE_COLOR_2 $PINTO_LOCK_TYPE_SHARED $PINTO_LOCK_TYPE_EXCLUSIVE $PINTO_STACK_NAME_ALL $PINTO_AUTHOR_REGEX $PINTO_USERNAME_REGEX $PINTO_STACK_NAME_REGEX $PINTO_PROPERTY_NAME_REGEX $PINTO_REVISION_ID_REGEX $PINTO_MINIMUM_CPANM_VERSION $PINTO_DIFF_STYLE_CONCISE $PINTO_DIFF_STYLE_DETAILED @PINTO_DIFF_STYLES $PINTO_STRATOPAN_CPAN_URI $PINTO_STRATOPAN_LOCATOR_URI $PINTO_BACKPAN_CPAN_URI @PINTO_DEFAULT_SOURCE_URIS @PINTO_PREREQ_PHASES @PINTO_PREREQ_RELATIONS @PINTO_ENVIRONMENT_VARIABLES ); Readonly our %EXPORT_TAGS => ( all => \@EXPORT_OK, color => [ grep {m/PALETTE/x} @EXPORT_OK ], server => [ grep {m/SERVER/x} @EXPORT_OK ], protocol => [ grep {m/PROTOCOL/x} @EXPORT_OK ], regex => [ grep {m/REGEX/x} @EXPORT_OK ], lock => [ grep {m/LOCK/x} @EXPORT_OK ], diff => [ grep {m/DIFF/x} @EXPORT_OK ], prereq => [ grep {m/PREREQ/x} @EXPORT_OK ], stratopan => [ grep {m/STRATOPAN/x} @EXPORT_OK ], ); #------------------------------------------------------------------------------ Readonly our $PINTO_SERVER_DEFAULT_HOST => 'localhost'; Readonly our $PINTO_SERVER_DEFAULT_PORT => 3111; Readonly our $PINTO_SERVER_DEFAULT_ROOT => "http://$PINTO_SERVER_DEFAULT_HOST:$PINTO_SERVER_DEFAULT_PORT"; #------------------------------------------------------------------------------ Readonly our $PINTO_PROTOCOL_VERSION => 1; Readonly our $PINTO_PROTOCOL_DIAG_PREFIX => '## '; Readonly our $PINTO_PROTOCOL_STATUS_OK => "${PINTO_PROTOCOL_DIAG_PREFIX}Status: ok"; Readonly our $PINTO_PROTOCOL_NULL_MESSAGE => "${PINTO_PROTOCOL_DIAG_PREFIX}-- ##"; Readonly our $PINTO_PROTOCOL_PROGRESS_MESSAGE => "${PINTO_PROTOCOL_DIAG_PREFIX}. ##"; Readonly our $PINTO_PROTOCOL_ACCEPT => "application/vnd.pinto.v${PINTO_PROTOCOL_VERSION}+text"; #------------------------------------------------------------------------------ Readonly our $PINTO_DEFAULT_PALETTE => [qw(green yellow red)]; Readonly our $PINTO_PALETTE_COLOR_0 => 0; Readonly our $PINTO_PALETTE_COLOR_1 => 1; Readonly our $PINTO_PALETTE_COLOR_2 => 2; #------------------------------------------------------------------------------ Readonly our $PINTO_LOCK_TYPE_SHARED => 'SH'; Readonly our $PINTO_LOCK_TYPE_EXCLUSIVE => 'EX'; #------------------------------------------------------------------------------ Readonly our $PINTO_STACK_NAME_ALL => '%'; #------------------------------------------------------------------------------ Readonly my $PINTO_ALPHANUMERIC_REGEX => qr{^ [a-zA-Z0-9-._]+ $}x; Readonly my $PINTO_HEXADECIMAL_UUID_REGEX => qr{^ [a-f0-9-]+ $}x; Readonly our $PINTO_AUTHOR_REGEX => qr/^ [A-Z]{2} [-A-Z0-9]* $/x; Readonly our $PINTO_USERNAME_REGEX => $PINTO_ALPHANUMERIC_REGEX; Readonly our $PINTO_STACK_NAME_REGEX => $PINTO_ALPHANUMERIC_REGEX; Readonly our $PINTO_PROPERTY_NAME_REGEX => $PINTO_ALPHANUMERIC_REGEX; Readonly our $PINTO_REVISION_ID_REGEX => $PINTO_HEXADECIMAL_UUID_REGEX; #------------------------------------------------------------------------------ Readonly our $PINTO_MINIMUM_CPANM_VERSION => '1.6920'; #------------------------------------------------------------------------------ Readonly our $PINTO_DIFF_STYLE_CONCISE => 'concise'; Readonly our $PINTO_DIFF_STYLE_DETAILED => 'detailed'; Readonly our @PINTO_DIFF_STYLES => ($PINTO_DIFF_STYLE_CONCISE, $PINTO_DIFF_STYLE_DETAILED); #------------------------------------------------------------------------------ # TODO: Make these configurable via ENV vars Readonly our $PINTO_PUBLIC_CPAN_URI => URI->new('http://www.cpan.org'); Readonly our $PINTO_BACKPAN_CPAN_URI => URI->new('http://backpan.perl.org'); Readonly our $PINTO_STRATOPAN_CPAN_URI => URI->new('http://cpan.stratopan.com'); Readonly our $PINTO_STRATOPAN_LOCATOR_URI => URI->new('http://meta.stratopan.com/locate'); Readonly our @PINTO_DEFAULT_SOURCE_URIS => ( $PINTO_STRATOPAN_CPAN_URI, $PINTO_PUBLIC_CPAN_URI, $PINTO_BACKPAN_CPAN_URI ); #------------------------------------------------------------------------------ Readonly our @PINTO_PREREQ_PHASES => qw(configure build test runtime develop); Readonly our @PINTO_PREREQ_RELATIONS => qw(requires suggests recommends); #------------------------------------------------------------------------------ Readonly our @PINTO_ENVIRONMENT_VARIABLES => qw( PINTO_AUTHOR_ID PINTO_DEBUG PINTO_DIFF_STYLE PINTO_EDITOR PINTO_LOCKFILE_TIMEOUT PINTO_NO_COLOR PINTO_PAGER PINTO_PAGER_OPTIONS PINTO_PALETTE PINTO_REPOSITORY_ROOT PINTO_STALE_LOCKFILE_TIMEOUT PINTO_USERNAME ); #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Constants - Constants used across the Pinto utilities =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Database.pm000644 000766 000024 00000020221 13141540305 016477 0ustar00jeffstaff000000 000000 # ABSTRACT: Interface to the Pinto database package Pinto::Database; use Moose; use MooseX::StrictConstructor; use MooseX::ClassAttribute; use MooseX::MarkAsMethods ( autoclean => 1 ); use MooseX::Types::Moose qw(Str); use Path::Class qw(file); use Pinto::Schema; use Pinto::Types qw(File); use Pinto::Util qw(debug throw); #------------------------------------------------------------------------------- our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------- has repo => ( is => 'ro', isa => 'Pinto::Repository', weak_ref => 1, required => 1, ); has schema => ( is => 'ro', isa => 'Pinto::Schema', builder => '_build_schema', init_arg => undef, lazy => 1, ); class_has ddl => ( is => 'ro', isa => Str, init_arg => undef, default => do { local $/ = undef; }, lazy => 1, ); #------------------------------------------------------------------------------- sub _build_schema { my ($self) = @_; my $schema = Pinto::Schema->new; my $db_file = $self->repo->config->db_file; my $dsn = "dbi:SQLite:$db_file"; my $xtra = { on_connect_call => 'use_foreign_keys' }; my @args = ( $dsn, undef, undef, $xtra ); my $connected = $schema->connect(@args); # Inject attributes thru back door $connected->repo( $self->repo ); # Tune sqlite (taken from monotone)... my $dbh = $connected->storage->dbh; $dbh->do('PRAGMA page_size = 8192'); $dbh->do('PRAGMA cache_size = 4000'); # These may be unhelpful or unwise... #$dbh->do('PRAGMA temp_store = MEMORY'); #$dbh->do('PRAGMA journal_mode = WAL'); #$dbh->do('PRAGMA synchronous = OFF'); return $connected; } #------------------------------------------------------------------------------- # NB: We used to just let DBIx::Class generate the DDL from its own schema, but # SQL::Translator does not support the COLLATE feature of SQLite. So now, we # ship Pinto with a real copy of the DDL, and feed it into the database when # the repository is initialized. # # Personally, I kinda prefer having a raw DDL file, rather than generating it # because then I know *exactly* what the database schema will be, and we are # no longer exposed to bugs that might exist in SQL::Translator. We don't need # to deploy to different RDBMSes, so we don't really need SQL::Translator to # help with that anyway. # # DBD::SQLite can only process one statement at a time, so we have to parse # the file and "do" each statement separately. Splitting on semicolons is # primitive, but effective (as long as semicolons are only used in statement # terminators). #------------------------------------------------------------------------------- sub deploy { my ($self) = @_; my $db_dir = $self->repo->config->db_dir; debug("Makding db directory at $db_dir"); $db_dir->mkpath; my $guard = $self->schema->storage->txn_scope_guard; $self->create_database_schema; $self->create_root_revision; $guard->commit; return $self; } #------------------------------------------------------------------------------- sub create_database_schema { my ($self) = @_; debug("Creating database schema"); my $dbh = $self->schema->storage->dbh; $dbh->do("$_;") for split /;/, $self->ddl; return $self; } #------------------------------------------------------------------------------- sub create_root_revision { my ($self) = @_; my $attrs = { uuid => $self->root_revision_uuid, message => 'root commit', is_committed => 1 }; debug("Creating root revision"); return $self->schema->create_revision($attrs); } #------------------------------------------------------------------------------- sub get_root_revision { my ($self) = @_; my $where = { uuid => $self->root_revision_uuid }; my $attrs = { key => 'uuid_unique' }; my $revision = $self->schema->find_revision( $where, $attrs ) or throw "PANIC: No root revision was found"; return $revision; } #------------------------------------------------------------------------------- sub root_revision_uuid { return '00000000-0000-0000-0000-000000000000' } #------------------------------------------------------------------------------- __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------- 1; =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Database - Interface to the Pinto database =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 __DATA__ CREATE TABLE distribution ( id INTEGER PRIMARY KEY NOT NULL, author TEXT NOT NULL COLLATE NOCASE, archive TEXT NOT NULL, source TEXT NOT NULL, mtime INTEGER NOT NULL, sha256 TEXT NOT NULL, md5 TEXT NOT NULL, metadata TEXT NOT NULL, UNIQUE(author, archive) ); CREATE TABLE package ( id INTEGER PRIMARY KEY NOT NULL, name TEXT NOT NULL, version TEXT NOT NULL, file TEXT DEFAULT NULL, sha256 TEXT DEFAULT NULL, distribution INTEGER NOT NULL REFERENCES distribution(id) ON DELETE CASCADE, UNIQUE(name, distribution) ); CREATE TABLE stack ( id INTEGER PRIMARY KEY NOT NULL, name TEXT NOT NULL UNIQUE COLLATE NOCASE, is_default BOOLEAN NOT NULL, is_locked BOOLEAN NOT NULL, properties TEXT NOT NULL, head INTEGER NOT NULL REFERENCES revision(id) ON DELETE RESTRICT ); CREATE TABLE registration ( id INTEGER PRIMARY KEY NOT NULL, revision INTEGER NOT NULL REFERENCES revision(id) ON DELETE CASCADE, package_name TEXT NOT NULL, package INTEGER NOT NULL REFERENCES package(id) ON DELETE CASCADE, distribution INTEGER NOT NULL REFERENCES distribution(id) ON DELETE CASCADE, is_pinned BOOLEAN NOT NULL, UNIQUE(revision, package_name) ); CREATE TABLE revision ( id INTEGER PRIMARY KEY NOT NULL, uuid TEXT NOT NULL UNIQUE, message TEXT NOT NULL, username TEXT NOT NULL, utc_time INTEGER NOT NULL, time_offset INTEGER NOT NULL, is_committed BOOLEAN NOT NULL, has_changes BOOLEAN NOT NULL ); CREATE TABLE ancestry ( id INTEGER PRIMARY KEY NOT NULL, parent INTEGER NOT NULL REFERENCES revision(id) ON DELETE CASCADE, child INTEGER NOT NULL REFERENCES revision(id) ON DELETE CASCADE ); CREATE TABLE prerequisite ( id INTEGER PRIMARY KEY NOT NULL, phase TEXT NOT NULL, distribution INTEGER NOT NULL REFERENCES distribution(id) ON DELETE CASCADE, package_name TEXT NOT NULL, package_version TEXT NOT NULL, UNIQUE(distribution, phase, package_name) ); CREATE INDEX idx_ancestry_parent ON ancestry(parent); CREATE INDEX idx_ancestry_child ON ancestry(child); CREATE INDEX idx_package_sha256 ON package(sha256); CREATE INDEX idx_distribution_sha256 ON distribution(sha256); Pinto-0.14/lib/Pinto/Difference.pm000644 000766 000024 00000015255 13141540305 017040 0ustar00jeffstaff000000 000000 # ABSTRACT: Compute difference between two revisions package Pinto::Difference; use Moose; use MooseX::StrictConstructor; use MooseX::Types::Moose qw(ArrayRef Bool); use MooseX::MarkAsMethods ( autoclean => 1 ); use Pinto::DifferenceEntry; use Pinto::Constants qw(:diff); use Pinto::Types qw(DiffStyle); use Pinto::Util qw(itis default_diff_style); use overload ( q{""} => 'to_string' ); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ has left => ( is => 'ro', isa => 'Pinto::Schema::Result::Revision', required => 1, ); has right => ( is => 'ro', isa => 'Pinto::Schema::Result::Revision', required => 1, ); has entries => ( traits => [qw(Array)], handles => { entries => 'elements' }, isa => ArrayRef ['Pinto::DifferenceEntry'], builder => '_build_diffs', init_arg => undef, lazy => 1, ); has additions => ( traits => [qw(Array)], handles => { additions => 'elements' }, isa => ArrayRef ['Pinto::DifferenceEntry'], default => sub { [ grep { $_->op eq '+' } shift->entries ] }, init_arg => undef, lazy => 1, ); has deletions => ( traits => [qw(Array)], handles => { deletions => 'elements' }, isa => ArrayRef ['Pinto::DifferenceEntry'], default => sub { [ grep { $_->op eq '-' } shift->entries ] }, init_arg => undef, lazy => 1, ); has is_different => ( is => 'ro', isa => Bool, init_arg => undef, default => sub { shift->entries > 0 }, lazy => 1, ); has style => ( is => 'ro', isa => DiffStyle, default => \&default_diff_style, ); #------------------------------------------------------------------------------ around BUILDARGS => sub { my $orig = shift; my $class = shift; my $args = $class->$orig(@_); # The left and right attributes can also be Stack objects. # In those cases, we just use the head revision of the Stack for my $side (qw(left right)) { if ( $args->{$side}->isa('Pinto::Schema::Result::Stack') ) { $args->{$side} = $args->{$side}->head; } } return $args; }; #------------------------------------------------------------------------------ sub _build_diffs { my ($self) = @_; # We want to find the registrations that are "different" in either # side. Two registrations are the same if they have the same values in # the package, distribution, and is_pinned columns. So we use these # columns to construct the keys of a hash. The value is the id of # the registration. For a concise diff, we just use the distribution # and is_pinned columns, which effectively groups the records so there # is only one diff entry per distribution. In that case, the package # referenced by the registration won't be meaningful. my @fields = $self->style eq $PINTO_DIFF_STYLE_DETAILED ? qw(distribution package is_pinned) : qw(distribution is_pinned); my $cb = sub { my $value = $_[0]->id; my $key = join '|', map { $_[0]->get_column($_) } @fields; return ( $key => $value ); }; my $attrs = { select => [ 'id', @fields ] }; my %left = $self->left->registrations( {}, $attrs )->as_hash($cb); my %right = $self->right->registrations( {}, $attrs )->as_hash($cb); # Now that we have hashes representing the left and right, we use # the keys as "sets" and compute the difference between them. Keys # present on the right but not on the left have been added. And # those present on left but not on the right have been deleted. my @add_ids = @right{ grep { not exists $left{$_} } keys %right }; my @del_ids = @left{ grep { not exists $right{$_} } keys %left }; # Now we have the ids of all the registrations that were added or # deleted between the left and right revisions. We use those ids to # requery the database and construct full objects for each of them. my @adds = $self->_create_entries( '+', $self->right, \@add_ids ); my @dels = $self->_create_entries( '-', $self->left, \@del_ids ); # Strictly speaking, the registrations are an unordered list. But # the diff is more readable if we group registrations together by # distribution name. my @diffs = sort @dels, @adds; return \@diffs; } #------------------------------------------------------------------------------ sub _create_entries { my ( $self, $type, $side, $ids ) = @_; # The number of ids is potentially pretty big (1000's) and we # can't use that many values in an IN clause. So we insert all # those ids into a temporary table. my $tmp_tbl = "__diff_${$}__"; my $dbh = $self->right->result_source->schema->storage->dbh; $dbh->do("CREATE TEMP TABLE $tmp_tbl (reg INTEGER NOT NULL)"); my $sth = $dbh->prepare("INSERT INTO $tmp_tbl VALUES( ? )"); $sth->execute($_) for @{$ids}; # Now fetch the actual Registration objects (with all their # related objects) for each id in the temp table. Finally, # map all the Registrations into DifferenceEntry objects. my $where = { 'me.id' => { in => \"SELECT reg from $tmp_tbl" } }; my $reg_rs = $side->registrations($where)->with_distribution->with_package; my @entries = map { Pinto::DifferenceEntry->new( op => $type, registration => $_ ) } $reg_rs->all; $dbh->do("DROP TABLE $tmp_tbl"); return @entries; } #------------------------------------------------------------------------------ sub foreach { my ( $self, $cb ) = @_; $cb->($_) for $self->entries; return $self; } #------------------------------------------------------------------------------ sub to_string { my ($self) = @_; my $format = $self->style eq $PINTO_DIFF_STYLE_CONCISE ? '%o[%F] %a/%f' : ''; return join("\n", map {$_->to_string($format) } $self->entries) . "\n"; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Difference - Compute difference between two revisions =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/DifferenceEntry.pm000644 000766 000024 00000005075 13141540305 020061 0ustar00jeffstaff000000 000000 # ABSTRACT: Represents one addition or deletion in a diff package Pinto::DifferenceEntry; use Moose; use MooseX::StrictConstructor; use MooseX::MarkAsMethods ( autoclean => 1 ); use MooseX::Types::Moose qw(Str); use String::Format; #------------------------------------------------------------------------------ use overload ( q{""} => 'to_string', 'cmp' => 'string_compare', ); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ # TODO: Consider breaking this into separate Addition and Deletion subclasses, # rather than using an "op" attribute to indicate which kind it is. That sort # of "type" flag is always a code smell to me. #------------------------------------------------------------------------------ has op => ( is => 'ro', isa => Str, required => 1 ); has registration => ( is => 'ro', isa => 'Pinto::Schema::Result::Registration', required => 1, ); #------------------------------------------------------------------------------ sub is_addition { shift->op eq '+' } sub is_deletion { shift->op eq '-' } #------------------------------------------------------------------------------ sub to_string { my ( $self, $format ) = @_; my %fspec = ( o => $self->op ); $format ||= $self->default_format; return $self->registration->to_string( String::Format::stringf($format, %fspec) ); } #------------------------------------------------------------------------------ sub default_format { my ($self) = @_; return '%o[%F] %-40p %12v %a/%f', } #------------------------------------------------------------------------------ sub string_compare { my ( $self, $other ) = @_; return $self->registration->distribution->name cmp $other->registration->distribution->name; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::DifferenceEntry - Represents one addition or deletion in a diff =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Editor/000755 000766 000024 00000000000 13141540305 015666 5ustar00jeffstaff000000 000000 Pinto-0.14/lib/Pinto/Editor.pm000644 000766 000024 00000005124 13141540305 016226 0ustar00jeffstaff000000 000000 # ABSTRACT: Utility class for authoring commit messages package Pinto::Editor; use Moose; use File::Temp; use Pinto::Editor::Edit; #----------------------------------------------------------------------------- our $VERSION = '0.14'; # VERSION #----------------------------------------------------------------------------- sub EDITOR { return $ENV{VISUAL} || $ENV{EDITOR}; } #----------------------------------------------------------------------------- our $__singleton__; sub __singleton__ { return $__singleton__ ||=__PACKAGE__->new; } #----------------------------------------------------------------------------- sub edit_file { my $self = shift; my $file = shift; die "*** Missing editor (No \$VISUAL or \$EDITOR)\n" unless my $editor = $self->EDITOR; my $rc = system $editor, $file; unless ( $rc == 0 ) { my ($exit_value, $signal, $core_dump); $exit_value = $? >> 8; $signal = $? & 127; $core_dump = $? & 128; die "Error during edit ($editor): exit value($exit_value), signal($signal), core_dump($core_dump): $!"; } } #----------------------------------------------------------------------------- sub edit { my $self = shift; $self = $self->__singleton__ unless blessed $self; my %given = @_; my $document = delete $given{document}; $document = '' unless defined $document; my $file = delete $given{file}; $file = $self->tmp unless defined $file; my $edit = Pinto::Editor::Edit->new( editor => $self, file => $file, document => $document, %given, # process, split, ... ); return $edit->edit; } #----------------------------------------------------------------------------- sub tmp { return File::Temp->new( unlink => 1 ) } #----------------------------------------------------------------------------- 1; =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Editor - Utility class for authoring commit messages =head1 VERSION version 0.14 =head1 DESCRIPTION This is a forked version of L which does not use the deprecated module L. My thanks to Robert Krimen for authoring the original. No user-servicable parts in here. =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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__ #----------------------------------------------------------------------------- Pinto-0.14/lib/Pinto/Exception.pm000644 000766 000024 00000001777 13141540305 016750 0ustar00jeffstaff000000 000000 # ABSTRACT: Base class for Pinto exceptions package Pinto::Exception; use Moose; use MooseX::MarkAsMethods ( autoclean => 1 ); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ extends qw(Throwable::Error); #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Exception - Base class for Pinto exceptions =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Globals.pm000644 000766 000024 00000002503 13141540305 016361 0ustar00jeffstaff000000 000000 # ABSTRACT: Global variables used across the Pinto utilities package Pinto::Globals; use strict; use warnings; use LWP::UserAgent; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ ## no critic qw(PackageVars); our $current_utc_time = undef; our $current_time_offset = undef; our $current_username = undef; our $current_author_id = undef; our $is_interactive = undef; #------------------------------------------------------------------------------ # TODO: Decide how to expose this our $UA = LWP::UserAgent->new( agent => 'Pinto/' . (__PACKAGE__->VERSION || '???'), env_proxy => 1, keep_alive => 5, ); #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Globals - Global variables used across the Pinto utilities =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/IndexReader.pm000644 000766 000024 00000004115 13141540305 017171 0ustar00jeffstaff000000 000000 # ABSTRACT: The package index of a repository package Pinto::IndexReader; use Moose; use MooseX::Types::Moose qw(HashRef); use MooseX::MarkAsMethods (autoclean => 1); use IO::Zlib; use Pinto::Types qw(File); use Pinto::Util qw(throw); #------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------ has index_file => ( is => 'ro', isa => File, required => 1, ); has packages => ( is => 'ro', isa => HashRef, builder => '_build_packages', lazy => 1, ); #------------------------------------------------------------------------------ sub _build_packages { my ($self) = @_; my $file = $self->index_file->stringify; my $fh = IO::Zlib->new($file, 'rb') or throw "Failed to open index file $file: $!"; my $index_data = $self->__read_index($fh); close $fh; return $index_data; } #------------------------------------------------------------------------------ sub __read_index { my ($self, $fh) = @_; my $inheader = 1; my $packages = {}; while (<$fh>) { if ($inheader) { $inheader = 0 if not m/ \S /x; next; } chomp; my ($package, $version, $path) = split; $packages->{$package} = {name => $package, version => $version, path => $path}; } return $packages } #------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::IndexReader - The package index of a repository =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/IndexWriter.pm000644 000766 000024 00000013410 13141540305 017241 0ustar00jeffstaff000000 000000 # ABSTRACT: Write records to an 02packages.details.txt file package Pinto::IndexWriter; use Moose; use MooseX::StrictConstructor; use MooseX::MarkAsMethods ( autoclean => 1 ); use IO::Zlib; use Module::CoreList; use Path::Class qw(file); use HTTP::Date qw(time2str); use Pinto::Types qw(File); use Pinto::Util qw(debug throw); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ has stack => ( is => 'ro', isa => 'Pinto::Schema::Result::Stack', required => 1, ); has index_file => ( is => 'ro', isa => File, default => sub { $_[0]->stack->modules_dir->file('02packages.details.txt.gz') }, lazy => 1, ); #------------------------------------------------------------------------------ sub write_index { my ($self) = @_; my $index_file = $self->index_file; my $stack = $self->stack; debug("Writing index for stack $stack at $index_file"); my $handle = IO::Zlib->new( $index_file->stringify, 'wb' ) or throw "Cannot open $index_file: $!"; my @records = $self->_get_index_records($stack); my $count = scalar @records; debug("Index for stack $stack has $count records"); $self->_write_header( $handle, $index_file, $count ); $self->_write_records( $handle, @records ); close $handle; return $self; } #------------------------------------------------------------------------------ sub _write_header { my ( $self, $fh, $filename, $line_count ) = @_; my $base = $filename->basename; my $uri = 'file://' . $filename->absolute->as_foreign('Unix'); my $writer = ref $self; my $version = $self->VERSION || 'UNKNOWN'; my $date = time2str(time); print {$fh} <<"END_PACKAGE_HEADER"; File: $base URL: $uri Description: Package names found in directory \$CPAN/authors/id/ Columns: package name, version, path Intended-For: Automated fetch routines, namespace documentation. Written-By: $writer version $version Line-Count: $line_count Last-Updated: $date END_PACKAGE_HEADER return $self; } #------------------------------------------------------------------------------ sub _write_records { my ( $self, $fh, @records ) = @_; for my $record (@records) { my ( $name, $version, $author, $archive ) = @{$record}; my $path = join '/', substr( $author, 0, 1 ), substr( $author, 0, 2 ), $author, $archive; my $width = 38 - length $version; $width = length $name if $width < length $name; printf {$fh} "%-${width}s %s %s\n", $name, $version, $path; } return $self; } #------------------------------------------------------------------------------ sub _get_index_records { my ( $self, $stack ) = @_; # The index is rewritten after almost every action, so we want # this to be as fast as possible (especially during an Add or # Remove action). Therefore, we use a cursor to get raw data and # skip all the DBIC extras. # Yes, slurping all the records at once consumes a lot of memory, # but I want them to be sorted the way perl sorts them, not the # way sqlite sorts them. That way, the index file looks more # like one produced by PAUSE. Also, this is about twice as fast # as using an iterator to read each record lazily. my @joins = qw(package distribution); my @selects = qw(package.name package.version distribution.author distribution.archive); my $attrs = { join => \@joins, select => \@selects }; my $rs = $stack->head->search_related( 'registrations', {}, $attrs ); my %stack_records = map { ($_->[0] => $_) } $rs->cursor->all; # Now, we merge the stuff from the stack with core modules. If # the stack has a newer version of a core module (dual-life) then # it should be the one that appears in the index. Then finally # we sort them. my %fake_records = $self->_get_fake_records; my %merged_records = (%fake_records, %stack_records); return map { $merged_records{$_} } sort {lc $a cmp lc $b} keys %merged_records; } #------------------------------------------------------------------------------ sub _get_fake_records { my ($self) = @_; # We generate artificial records for all the (non-deprecated) core modules # that are in the target perl. That way, the index appears to have perl # itself (just like the real CPAN) and installers can handle requests to # install a core module. my $tpv = $self->stack->target_perl_version; my $tpv_normal = $tpv->normal; $tpv_normal =~ s/^v//; my @fake = ("FAKE", "perl-$tpv_normal.tar.gz"); my $core_versions = $Module::CoreList::version{$tpv->numify + 0}; my $deprecated_modules = $Module::CoreList::deprecated{$tpv->numify + 0}; my $fake_records = {}; for my $module (keys %{ $core_versions }) { next if $deprecated_modules && exists $deprecated_modules->{ $module }; $fake_records->{$module} = [$module, $core_versions->{$module} || 0, @fake]; } return %{ $fake_records }; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::IndexWriter - Write records to an 02packages.details.txt file =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Initializer.pm000644 000766 000024 00000007175 13141540305 017273 0ustar00jeffstaff000000 000000 # ABSTRACT: Initializes a new Pinto repository package Pinto::Initializer; use Moose; use MooseX::StrictConstructor; use MooseX::MarkAsMethods ( autoclean => 1 ); use IO::Zlib; use Path::Class; use Pinto; use Pinto::Config; use Pinto::Util qw(debug); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ sub init { my ( $self, %args ) = @_; die "Must specify a root\n" if not $args{root}; # Normalize root $args{root} =~ s{^file://}{}; $self->_check_sanity(%args); $self->_make_dirs(%args); $self->_write_config(%args); $self->_write_mailrc(%args); $self->_set_version(%args); $self->_create_db(%args); $self->_create_stack(%args); return $self; } #------------------------------------------------------------------------------ sub _check_sanity { my ( $self, %args ) = @_; my $root_dir = dir( $args{root} ); die "Directory $root_dir must be empty to create a repository there\n" if -e $root_dir and $root_dir->children; return; } #------------------------------------------------------------------------------ sub _make_dirs { my ( $self, %args ) = @_; my $config = Pinto::Config->new( root => $args{root} ); for my $dir ( $config->directories ) { debug "Making directory $dir"; $dir->mkpath; } return; } #------------------------------------------------------------------------------ sub _write_config { my ( $self, %args ) = @_; my $config = Pinto::Config->new( root => $args{root} ); my $config_file = $config->config_dir->file( $config->basename ); $config->write_config_file( file => $config_file, values => \%args ); return; } #------------------------------------------------------------------------------ sub _write_mailrc { my ( $self, %args ) = @_; my $config = Pinto::Config->new( root => $args{root} ); my $fh = IO::Zlib->new( $config->mailrc_file->stringify, 'wb' ) or die $!; print {$fh} ''; # File will be empty, but have gzip headers close $fh or throw $!; return; } #------------------------------------------------------------------------------ sub _set_version { my ( $self, %args ) = @_; my $pinto = Pinto->new( root => $args{root} ); $pinto->repo->set_version; return; } #------------------------------------------------------------------------------ sub _create_db { my ( $self, %args ) = @_; my $pinto = Pinto->new( root => $args{root} ); $pinto->repo->db->deploy; return; } #------------------------------------------------------------------------------ sub _create_stack { my ( $self, %args ) = @_; my $stack = $args{stack} || 'master'; my $is_default = $args{no_default} ? 0 : 1; my $pinto = Pinto->new( root => $args{root} ); $pinto->run( New => ( stack => $stack, default => $is_default ) ); return; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Initializer - Initializes a new Pinto repository =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Locator/000755 000766 000024 00000000000 13141540305 016043 5ustar00jeffstaff000000 000000 Pinto-0.14/lib/Pinto/Locator.pm000644 000766 000024 00000004251 13141540305 016403 0ustar00jeffstaff000000 000000 # ABSTRACT: Base class for Locators package Pinto::Locator; use Moose; use MooseX::StrictConstructor; use MooseX::MarkAsMethods (autoclean => 1); use Pinto::Types qw(Dir Uri); use Pinto::Util qw(throw tempdir); #------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------ with qw(Pinto::Role::UserAgent); #------------------------------------------------------------------------ has uri => ( is => 'ro', isa => Uri, default => 'http://backpan.perl.org', coerce => 1, ); has cache_dir => ( is => 'ro', isa => Dir, default => \&tempdir, ); #------------------------------------------------------------------------ sub locate { my ($self, %args) = @_; $args{target} || throw 'Invalid arguments'; $args{target} = Pinto::Target->new($args{target}) if not ref $args{target}; return $self->locate_package(%args) if $args{target}->isa('Pinto::Target::Package'); return $self->locate_distribution(%args) if $args{target}->isa('Pinto::Target::Distribution'); throw 'Invalid arguments'; } #------------------------------------------------------------------------ sub locate_package { die 'Abstract method'} #------------------------------------------------------------------------ sub locate_distribution { die 'Abstract method'} #------------------------------------------------------------------------ sub refresh {} #------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Locator - Base class for Locators =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Locker.pm000644 000766 000024 00000007464 13141540305 016230 0ustar00jeffstaff000000 000000 # ABSTRACT: Manage locks to synchronize concurrent operations package Pinto::Locker; use Moose; use MooseX::StrictConstructor; use MooseX::MarkAsMethods ( autoclean => 1 ); use Path::Class; use File::NFSLock; use Pinto::Util qw(debug throw whine); use Pinto::Types qw(File); #----------------------------------------------------------------------------- our $VERSION = '0.14'; # VERSION #----------------------------------------------------------------------------- our $LOCKFILE_TIMEOUT = $ENV{PINTO_LOCKFILE_TIMEOUT} || 50; # Seconds our $STALE_LOCKFILE_TIMEOUT = $ENV{PINTO_STALE_LOCKFILE_TIMEOUT} || 0; # Seconds #----------------------------------------------------------------------------- has repo => ( is => 'ro', isa => 'Pinto::Repository', weak_ref => 1, required => 1, ); has _lock => ( is => 'rw', isa => 'File::NFSLock', predicate => '_is_locked', clearer => '_clear_lock', init_arg => undef, ); #----------------------------------------------------------------------------- sub lock { ## no critic qw(Homonym) my ( $self, $lock_type ) = @_; return if $self->_is_locked; $lock_type ||= 'SH'; local $File::NFSLock::LOCK_EXTENSION = ''; local @File::NFSLock::CATCH_SIGS = (); my $root_dir = $self->repo->config->root_dir; my $lock_file = $root_dir->file('.lock')->stringify; if ($STALE_LOCKFILE_TIMEOUT) { whine( 'PINTO_STALE_LOCKFILE_TIMEOUT > 0, may steal lock !!'); } my $lock = File::NFSLock->new( $lock_file, $lock_type, $LOCKFILE_TIMEOUT, $STALE_LOCKFILE_TIMEOUT ) or throw 'The repository is currently in use -- please try again later (' . $File::NFSLock::errstr . ')'; debug("Process $$ got $lock_type lock on $root_dir"); $self->_lock($lock); return $self; } #----------------------------------------------------------------------------- sub unlock { my ($self) = @_; return $self if not $self->_is_locked; # I'm not sure if failure to unlock is really a problem $self->_lock->unlock or warn 'Unable to unlock repository'; $self->_clear_lock; my $root_dir = $self->repo->config->root_dir; debug("Process $$ released the lock on $root_dir"); return $self; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #----------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer NFS =head1 NAME Pinto::Locker - Manage locks to synchronize concurrent operations =head1 VERSION version 0.14 =head1 DESCRIPTION =head1 METHODS =head2 lock Attempts to get a lock on a Pinto repository. If the repository is already locked, we will attempt to contact the current lock holder and make sure they are really alive. If not, then we will steal the lock. If they are, then we patiently wait until we timeout, which is about 60 seconds. =head2 unlock Releases the lock on the Pinto repository so that other processes can get to work. In many situations, a Pinto repository is a shared resource. At any given moment, multiple processes may be trying to add distributions, remove packages, or pull files from a mirror. To keep things working properly, we can only let one process fiddle with the repository at a time. This module manages a lock file for that purpose. Supposedly, this does work on NFS. But it cannot steal the lock from a dead process if that process was not running on the same host. =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Manual/000755 000766 000024 00000000000 13141540305 015655 5ustar00jeffstaff000000 000000 Pinto-0.14/lib/Pinto/Manual.pod000644 000766 000024 00000003425 13141540305 016365 0ustar00jeffstaff000000 000000 # ABSTRACT: Entry point for Pinto documentation package Pinto::Manual; #------------------------------------------------------------------------------ # VERSION #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer Stratopan =head1 NAME Pinto::Manual - Entry point for Pinto documentation =head1 VERSION version 0.14 =head1 TABLE OF CONTENTS The manual consists of the following documents: =head2 L Explains the goals, terminology, and concepts in L. =head2 L Some suggestions for installing L. =head2 L Presents a narrative explanation of how to use L. =head2 L Presents a condensed summary of L commands. =head2 L Names of those who helped to finance L. =head1 SEE ALSO L is a web service built on Pinto. Using Stratopan, you can store all your public and private Perl modules in the cloud without having to create and manage your own Pinto repository. Stratopan also has facilities for creating teams of collaborators, controlling access to your repositories, browsing your repository contents or revision history, and visualizing your dependency tree. At the time of this writing, L is still in the alpha stage. But it is definitely worth investigation. =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Migrator.pm000644 000766 000024 00000003550 13141540305 016565 0ustar00jeffstaff000000 000000 # ABSTRACT: Migrate an existing repository to a new version package Pinto::Migrator; use Moose; use MooseX::StrictConstructor; use MooseX::MarkAsMethods ( autoclean => 1 ); use Pinto::Types qw(Dir); use Pinto::Repository; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ has root => ( is => 'ro', isa => Dir, default => $ENV{PINTO_REPOSITORY_ROOT}, coerce => 1, ); #------------------------------------------------------------------------------ sub migrate { my ($self) = @_; my $repo = Pinto::Repository->new( root => $self->root ); my $repo_version = $repo->get_version; my $code_version = $Pinto::Repository::REPOSITORY_VERSION; die "This repository is too old to migrate.\n" . "Contact thaljef\@cpan.org for a migration plan.\n" if not $repo_version; die "This repository is already up to date.\n" if $repo_version == $code_version; die "This repository too new. Upgrade Pinto instead.\n" if $repo_version > $code_version; die "Migration is not implemented yet\n"; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Migrator - Migrate an existing repository to a new version =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/ModlistWriter.pm000644 000766 000024 00000004465 13141540305 017617 0ustar00jeffstaff000000 000000 # ABSTRACT: Generates a stub 03modlist.data.gz file package Pinto::ModlistWriter; use Moose; use MooseX::StrictConstructor; use MooseX::MarkAsMethods ( autoclean => 1 ); use IO::Zlib; use HTTP::Date qw(time2str); use Pinto::Types qw(File); use Pinto::Util qw(debug throw); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ has stack => ( is => 'ro', isa => 'Pinto::Schema::Result::Stack', required => 1, ); has modlist_file => ( is => 'ro', isa => File, default => sub { $_[0]->stack->modules_dir->file('03modlist.data.gz') }, lazy => 1, ); #------------------------------------------------------------------------------ sub write_modlist { my ($self) = @_; my $stack = $self->stack; my $modlist_file = $self->modlist_file; debug("Writing module list for stack $stack at $modlist_file"); my $fh = IO::Zlib->new( $modlist_file->stringify, 'wb' ) or throw $!; print {$fh} $self->modlist_data; close $fh or throw $!; return $self; } #------------------------------------------------------------------------------ sub modlist_data { my ($self) = @_; my $writer = ref $self; my $version = $self->VERSION || 'UNKNOWN'; my $package = 'CPAN::Modulelist'; my $date = time2str(time); return <<"END_MODLIST"; File: 03modlist.data Description: This a placeholder for CPAN.pm Modcount: 0 Written-By: $writer version $version Date: $date package $package; sub data { {} } 1; END_MODLIST } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::ModlistWriter - Generates a stub 03modlist.data.gz file =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/PackageExtractor.pm000644 000766 000024 00000014022 13141540305 020224 0ustar00jeffstaff000000 000000 # ABSTRACT: Extract packages provided/required by a distribution archive package Pinto::PackageExtractor; use Moose; use MooseX::StrictConstructor; use MooseX::MarkAsMethods ( autoclean => 1 ); use Try::Tiny; use Dist::Metadata; use Pinto::Types qw(File Dir); use Pinto::Util qw(debug throw whine); use Pinto::ArchiveUnpacker; #----------------------------------------------------------------------------- our $VERSION = '0.14'; # VERSION #----------------------------------------------------------------------------- has archive => ( is => 'ro', isa => File, required => 1, coerce => 1, ); has unpacker => ( is => 'ro', isa => 'Pinto::ArchiveUnpacker', default => sub { Pinto::ArchiveUnpacker->new( archive => $_[0]->archive ) }, init_arg => undef, lazy => 1, ); has work_dir => ( is => 'ro', isa => Dir, default => sub { $_[0]->unpacker->unpack }, init_arg => undef, lazy => 1, ); has dm => ( is => 'ro', isa => 'Dist::Metadata', default => sub { Dist::Metadata->new( dir => $_[0]->work_dir, include_inner_packages => 1 ) }, init_arg => undef, lazy => 1, ); #----------------------------------------------------------------------------- sub provides { my ($self) = @_; my $archive = $self->archive; my $basename = $archive->basename; debug "Extracting packages provided by archive $basename"; my $mod_info = try { # Some modules get their VERSION by loading some other # module from lib/. So make sure that lib/ is in @INC my $lib_dir = $self->work_dir->subdir('lib'); local @INC = ( $lib_dir->stringify, @INC ); # TODO: Run this under Safe to protect ourselves # from evil. See ANDK/pause/pmfile.pm for example $self->dm->module_info; # returned from try{} } catch { throw "Unable to extract packages from $basename: $_"; }; my @provides; for my $package ( sort keys %{$mod_info} ) { my $info = $mod_info->{$package}; my $version = version->parse( $info->{version} ); debug "Archive $basename provides: $package-$version"; push @provides, { name => $package, version => $version, file => $info->{file}, }; } @provides = $self->__apply_workarounds(@provides); whine "$basename contains no packages and will not be in the index" if not @provides; return @provides; } #----------------------------------------------------------------------------- sub requires { my ($self) = @_; my $archive = $self->archive; debug "Extracting packages required by archive $archive"; my $prereqs_meta = try { $self->dm->meta->prereqs } catch { throw "Unable to extract prereqs from $archive: $_" }; my @prereqs; for my $phase ( keys %{$prereqs_meta} ) { # TODO: Also capture the relation (suggested, requires, recomends, etc.) # But that will require a schema change to add another column to the table. my $prereqs_for_phase = $prereqs_meta->{$phase} || {}; my $required_prereqs = $prereqs_for_phase->{requires} || {}; for my $package ( sort keys %{$required_prereqs} ) { my $version = $required_prereqs->{$package}; debug "Archive $archive requires ($phase): $package~$version"; push @prereqs, { name => $package, version => $version, phase => $phase, }; } } my $base = $archive->basename; whine "$base appears to be a bundle. Prereqs for bundles cannot be determined automatically" if $base =~ m/^ Bundle- /x; # whine "$base uses dynamic configuration so prereqs may be incomplete" # if $self->dm->meta->dynamic_config; return @prereqs; } #----------------------------------------------------------------------------- sub metadata { my ($self) = @_; my $archive = $self->archive; debug "Extracting metadata from archive $archive"; my $metadata = try { $self->dm->meta } catch { throw "Unable to extract metadata from $archive: $_" }; return $metadata; } #============================================================================= # TODO: Generalize these workarounds and/or move them into a separate module sub __apply_workarounds { my ($self, @provides) = @_; return $self->__common_sense_workaround(@provides) if $self->archive->basename =~ m/^ common-sense /x; return $self->__fcgi_workaround(@provides) if $self->archive->basename =~ m/^ FCGI-\d /x; return @provides; } #----------------------------------------------------------------------------- sub __common_sense_workaround { my ($self) = @_; my ($version) = ( $self->archive->basename =~ m/common-sense- ([\d_.]+) \.tar\.gz/x ); return { name => 'common::sense', file => 'sense.pm.PL', version => version->parse($version), }; } #----------------------------------------------------------------------------- sub __fcgi_workaround { my ($self) = @_; my ($version) = ( $self->archive->basename =~ m/FCGI- ([\d_.]+) \.tar\.gz/x ); return { name => 'FCGI', file => 'FCGI.PL', version => version->parse($version), }; } #----------------------------------------------------------------------------- __PACKAGE__->meta->make_immutable; #----------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::PackageExtractor - Extract packages provided/required by a distribution archive =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/PrerequisiteWalker.pm000644 000766 000024 00000005160 13141540305 020627 0ustar00jeffstaff000000 000000 # ABSTRACT: Iterates through distribution prerequisites package Pinto::PrerequisiteWalker; use Moose; use MooseX::StrictConstructor; use MooseX::Types::Moose qw(CodeRef ArrayRef HashRef Bool); use MooseX::MarkAsMethods ( autoclean => 1 ); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ has start => ( is => 'ro', isa => 'Pinto::Schema::Result::Distribution', required => 1, ); has callback => ( is => 'ro', isa => CodeRef, required => 1, ); has filters => ( is => 'ro', isa => ArrayRef [CodeRef], predicate => 'has_filters', ); has queue => ( isa => ArrayRef ['Pinto::Schema::Result::Prerequisite'], traits => [qw(Array)], handles => { enqueue => 'push', dequeue => 'shift' }, default => sub { return [ $_[0]->apply_filters( $_[0]->start->prerequisites ) ] }, init_arg => undef, lazy => 1, ); has seen => ( is => 'ro', isa => HashRef, default => sub { return { $_[0]->start->path => 1 } }, init_arg => undef, lazy => 1, ); #----------------------------------------------------------------------------- sub next { my ($self) = @_; my $prereq = $self->dequeue or return; my $dist = $self->callback->($prereq); if ( defined $dist ) { my $path = $dist->path; my @prereqs = $self->apply_filters( $dist->prerequisites ); $self->enqueue(@prereqs) unless $self->seen->{$path}; $self->seen->{$path} = 1; } return $prereq; } #------------------------------------------------------------------------------ sub apply_filters { my ( $self, @prereqs ) = @_; return @prereqs if not $self->has_filters; for my $filter ( @{ $self->filters } ) { @prereqs = grep { !$filter->($_) } @prereqs; } return @prereqs; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::PrerequisiteWalker - Iterates through distribution prerequisites =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Remote/000755 000766 000024 00000000000 13141540305 015673 5ustar00jeffstaff000000 000000 Pinto-0.14/lib/Pinto/Remote.pm000644 000766 000024 00000010745 13141540305 016240 0ustar00jeffstaff000000 000000 # ABSTRACT: Interact with a remote Pinto repository package Pinto::Remote; use Moose; use MooseX::StrictConstructor; use MooseX::MarkAsMethods ( autoclean => 1 ); use MooseX::Types::Moose qw(Maybe Str); use Try::Tiny; use LWP::UserAgent; use Pinto::Chrome::Term; use Pinto::Remote::Action; use Pinto::Constants qw(:server); use Pinto::Util qw(throw current_username); use Pinto::Types qw(Uri); #------------------------------------------------------------------------------- our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ with qw(Pinto::Role::Plated Pinto::Role::UserAgent); #------------------------------------------------------------------------------ has root => ( is => 'ro', isa => Uri, default => $ENV{PINTO_REPOSITORY_ROOT}, coerce => 1, ); has username => ( is => 'ro', isa => Str, default => current_username, ); has password => ( is => 'ro', isa => Maybe [Str], ); #------------------------------------------------------------------------------ around BUILDARGS => sub { my $orig = shift; my $class = shift; my $args = $class->$orig(@_); # Grrr. Gotta avoid passing undefs to Moose my @chrome_attrs = qw(verbose quiet color); my %chrome_args = map { $_ => delete $args->{$_} } grep { exists $args->{$_} } @chrome_attrs; $args->{chrome} ||= Pinto::Chrome::Term->new(%chrome_args); return $args; }; #------------------------------------------------------------------------------ sub run { my ( $self, $action_name, @args ) = @_; # Divert all warnings through our chrome local $SIG{__WARN__} = sub { $self->warning($_) for @_ }; my $action_args = ( @args == 1 and ref $args[0] eq 'HASH' ) ? $args[0] : {@args}; my $result = try { my $action_class = $self->load_class_for_action( name => $action_name ); my $action = $action_class->new( name => $action_name, args => $action_args, root => $self->root, username => $self->username, password => $self->password, chrome => $self->chrome, ); $action->execute; } catch { $self->error($_); Pinto::Result->new->failed( because => $_ ); }; return $result; } #------------------------------------------------------------------------------ sub load_class_for_action { my ( $self, %args ) = @_; my $action_name = $args{name} or throw 'Must specify an action name'; my $action_baseclass = __PACKAGE__ . '::Action'; my $action_subclass = __PACKAGE__ . '::Action::' . ucfirst $action_name; my $subclass_did_load = Class::Load::try_load_class($action_subclass); my $action_class = $subclass_did_load ? $action_subclass : $action_baseclass; Class::Load::load_class($action_class); return $action_class; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Remote - Interact with a remote Pinto repository =head1 VERSION version 0.14 =head1 SYNOPSIS See L to create and manage a Pinto repository. See L to allow remote access to your Pinto repository. See L for more information about the Pinto tools. =head1 DESCRIPTION Pinto::Remote is the cousin of L. It provides the same API, but instead of running Actions against a local repository, it just sends the Action parameters to a L server that invokes Pinto on the remote host. If you are using the L application, it will automatically load either Pinto or Pinto::Remote depending on whether your repository root looks like a local directory path or a remote URI. =head1 METHODS =head2 run( $action_name => %action_args ) Loads the Action subclass for the given C<$action_name> and constructs an object using the given C<$action_args>. If the subclass C does not exist, then it falls back to the L base class. =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Repository.pm000644 000766 000024 00000061706 13141540305 017167 0ustar00jeffstaff000000 000000 # ABSTRACT: Coordinates the database, files, and indexes package Pinto::Repository; use Moose; use MooseX::StrictConstructor; use MooseX::MarkAsMethods ( autoclean => 1 ); use Readonly; use File::Find; use Path::Class; use List::Util qw(first); use Pinto::Store; use Pinto::Config; use Pinto::Locker; use Pinto::Database; use Pinto::PackageExtractor; use Pinto::Locator::Multiplex; use Pinto::PrerequisiteWalker; use Pinto::Util qw(itis debug mksymlink throw); use Pinto::Types qw(Dir); use version; #------------------------------------------------------------------------------- our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------- Readonly our $REPOSITORY_VERSION => 1; #------------------------------------------------------------------------------- with qw( Pinto::Role::UserAgent ); #------------------------------------------------------------------------------- has root => ( is => 'ro', isa => Dir, required => 1, coerce => 1, ); has config => ( is => 'ro', isa => 'Pinto::Config', default => sub { Pinto::Config->new( root => $_[0]->root ) }, lazy => 1, ); has db => ( is => 'ro', isa => 'Pinto::Database', default => sub { Pinto::Database->new( repo => $_[0] ) }, lazy => 1, ); has store => ( is => 'ro', isa => 'Pinto::Store', default => sub { Pinto::Store->new( repo => $_[0] ) }, lazy => 1, ); has locator => ( is => 'ro', isa => 'Pinto::Locator', handles => [ qw(locate) ], default => sub { my $self = shift; my $cache_dir = $self->config->cache_dir; my $mux = Pinto::Locator::Multiplex->new(cache_dir => $cache_dir); return $mux->assemble($self->config->sources_list) }, lazy => 1, ); has locker => ( is => 'ro', isa => 'Pinto::Locker', handles => [qw(lock unlock)], default => sub { Pinto::Locker->new( repo => $_[0] ) }, lazy => 1, ); #------------------------------------------------------------------------------- sub get_stack { my ( $self, $stack ) = @_; my $got = $self->get_stack_maybe($stack) or throw "Stack $stack does not exist"; return $got; } #------------------------------------------------------------------------------- sub get_stack_maybe { my ( $self, $stack ) = @_; return $stack if itis( $stack, 'Pinto::Schema::Result::Stack' ); return $self->get_default_stack if not $stack; my $where = { name => $stack }; return $self->db->schema->find_stack($where); } #------------------------------------------------------------------------------- sub get_default_stack { my ($self) = @_; my $where = { is_default => 1 }; my @stacks = $self->db->schema->search_stack($where)->all; # Assert that there is no more than one default stack throw "PANIC: There must be no more than one default stack" if @stacks > 1; # Error if the default stack has been set throw "The default stack has not been set" if @stacks == 0; return $stacks[0]; } #------------------------------------------------------------------------------- sub get_all_stacks { my ($self) = @_; return $self->db->schema->stack_rs->all; } #------------------------------------------------------------------------------- sub get_revision { my ($self, $revision) = @_; my $rev = $self->get_revision_maybe($revision) or throw "No such revision $revision exists"; return $rev; } #------------------------------------------------------------------------------- sub get_revision_maybe { my ( $self, $revision ) = @_; return $revision if itis( $revision, 'Pinto::Schema::Result::Revision' ); my $where = { uuid => { like => lc "$revision%" } }; my @revs = $self->db->schema->search_revision($where); if ( @revs > 1 ) { my $msg = "Revision ID $revision is ambiguous. Possible matches are:\n"; $msg .= $_->to_string("%i: %{48}T\n") for @revs; throw $msg; } return @revs ? $revs[0] : (); } #------------------------------------------------------------------------------- sub get_package { my ( $self, %args ) = @_; my $target = $args{target}; my $pkg_name = $args{name}; my $dist_path = $args{path}; my $schema = $self->db->schema; # Retrieve latest version of package that satisfies the target if ($target) { my $where = {name => $target->name}; return unless my @pkgs = $schema->search_package( $where )->with_distribution; return unless my $latest = first { $target->is_satisfied_by($_->version) } reverse sort { $a <=> $b } @pkgs; return $latest; } # Retrieve package from a specific distribution elsif ( $pkg_name && $dist_path ) { my ( $author, $archive ) = Pinto::Util::parse_dist_path($dist_path); my $where = {'me.name' => $pkg_name, 'distribution.author' => $author, 'distribution.archive' => $archive}; return unless my @pkgs = $schema->search_package($where)->with_distribution; return $pkgs[0]; } # Retrieve latest version of package in the entire repository elsif ($pkg_name) { my $where = { name => $pkg_name }; return unless my @pkgs = $schema->search_package($where)->with_distribution; return (reverse sort { $a <=> $b } @pkgs)[0]; } throw 'Invalid arguments'; } #------------------------------------------------------------------------------- sub get_distribution { my ( $self, %args ) = @_; my $rs = $self->db->schema->distribution_rs->with_packages; # Retrieve a distribution by target if ( my $target = $args{target} ) { if ( itis( $target, 'Pinto::Target::Distribution' ) ) { return $rs->find_by_author_archive( $target->author, $target->archive ); } elsif ( itis( $target, 'Pinto::Target::Package' ) ) { return unless my $pkg = $self->get_package( target => $target ); return $pkg->distribution; } throw 'Invalid arguments'; } # Retrieve a distribution by its path (e.g. AUTHOR/Dist-1.0.tar.gz) elsif ( my $path = $args{path} ) { my ( $author, $archive ) = Pinto::Util::parse_dist_path($path); return $rs->find_by_author_archive( $author, $archive ); } # Retrieve a distribution by author and archive elsif ( my $author = $args{author} ) { my $archive = $args{archive} or throw "Must specify archive with author"; return $rs->find_by_author_archive( $author, $archive ); } throw 'Invalid arguments'; } #------------------------------------------------------------------------------- sub ups_distribution { my ( $self, %args ) = @_; return unless my $found = $self->locate( %args ); return $self->fetch_distribution( uri => $found->{uri} ); } #------------------------------------------------------------------------------- sub add_distribution { my ( $self, %args ) = @_; my $archive = $args{archive}; my $author = uc $args{author}; my $source = $args{source} || 'LOCAL'; $self->assert_archive_not_duplicate( $author, $archive ); # Assemble the basic structure... my $dist_struct = { author => $author, source => $source, archive => $archive->basename, mtime => Pinto::Util::mtime($archive), md5 => Pinto::Util::md5($archive), sha256 => Pinto::Util::sha256($archive) }; my $extractor = Pinto::PackageExtractor->new( archive => $archive ); # Add provided packages... my @provides = $extractor->provides; $dist_struct->{packages} = \@provides; # Add required packages... my @requires = $extractor->requires; $dist_struct->{prerequisites} = \@requires; # Add metadata... my $metadata = $extractor->metadata; $dist_struct->{metadata} = $metadata; my $p = scalar @provides; my $r = scalar @requires; debug "Distribution $archive provides $p and requires $r packages"; # Update database *before* moving the archive into the # repository, so if there is an error in the DB, we can stop and # the repository will still be clean. my $dist = $self->db->schema->create_distribution($dist_struct); $self->store->add_archive( $archive => $dist->native_path ); return $dist; } #------------------------------------------------------------------------------ sub fetch_distribution { my ( $self, %args ) = @_; my $uri = $args{uri}; my $path = $uri->path; my $existing = $self->get_distribution( path => $path ); throw "Distribution $existing already exists" if $existing; my ( $author, undef ) = Pinto::Util::parse_dist_path($path); my $archive = $self->mirror_temporary( $uri ); my $dist = $self->add_distribution( archive => $archive, author => $author, source => $uri, ); return $dist; } #------------------------------------------------------------------------------ sub delete_distribution { my ( $self, %args ) = @_; my $dist = $args{dist}; my $force = $args{force}; for my $reg ( $dist->registrations ) { # TODO: say which stack it is pinned to throw "$dist is pinned to a stack and cannot be deleted" if $reg->is_pinned and not $force; } $dist->delete; my $basedir = $self->config->authors_id_dir; $self->store->remove_archive( $dist->native_path($basedir) ); return $self; } #------------------------------------------------------------------------------ sub package_count { my ($self) = @_; return $self->db->schema->package_rs->count; } #------------------------------------------------------------------------------- sub distribution_count { my ($self) = @_; return $self->db->schema->distribution_rs->count; } #------------------------------------------------------------------------------- sub stack_count { my ($self) = @_; return $self->db->schema->stack_rs->count; } #------------------------------------------------------------------------------- sub revision_count { my ($self) = @_; return $self->db->schema->revision_rs->count; } #------------------------------------------------------------------------------- sub txn_begin { my ($self) = @_; debug 'Beginning db transaction'; $self->db->schema->txn_begin; return $self; } #------------------------------------------------------------------------------- sub txn_rollback { my ($self) = @_; debug 'Rolling back db transaction'; $self->db->schema->txn_rollback; return $self; } #------------------------------------------------------------------------------- sub txn_commit { my ($self) = @_; debug 'Committing db transaction'; $self->db->schema->txn_commit; return $self; } #------------------------------------------------------------------------------- sub svp_begin { my ( $self, $name ) = @_; debug 'Beginning db savepoint'; $self->db->schema->svp_begin($name); return $self; } #------------------------------------------------------------------------------- sub svp_rollback { my ( $self, $name ) = @_; debug 'Rolling back db savepoint'; $self->db->schema->svp_rollback($name); return $self; } #------------------------------------------------------------------------------- sub svp_release { my ( $self, $name ) = @_; debug 'Releasing db savepoint'; $self->db->schema->svp_release($name); return $self; } #------------------------------------------------------------------------------- sub create_stack { my ( $self, %args ) = @_; my $stk_name = $args{name}; throw "Stack $stk_name already exists" if $self->get_stack_maybe( $stk_name ); my $root = $self->db->get_root_revision; my $stack = $self->db->schema->create_stack( { %args, head => $root } ); $stack->make_filesystem; $stack->write_index; return $stack; } #------------------------------------------------------------------------------- sub copy_stack { my ( $self, %args ) = @_; my $copy_name = $args{name}; my $stack = delete $args{stack}; my $orig_name = $stack->name; if ( my $existing = $self->get_stack_maybe( $copy_name ) ) { throw "Stack $existing already exists"; } my $dupe = $stack->duplicate(%args); $dupe->make_filesystem; $dupe->write_index; return $dupe; } #------------------------------------------------------------------------------- sub rename_stack { my ( $self, %args ) = @_; my $new_name = $args{to}; my $stack = delete $args{stack}; my $old_name = $stack->name; if (my $existing_stack = $self->get_stack_maybe( $new_name )) { my $is_different_stack = lc $new_name ne lc $existing_stack->name; throw "Stack $new_name already exists" if $is_different_stack || $new_name eq $old_name; } $stack->rename_filesystem( to => $new_name ); $stack->rename( to => $new_name ); return $stack; } #------------------------------------------------------------------------------- sub kill_stack { my ( $self, %args ) = @_; my $stack = $args{stack}; $stack->kill; $stack->kill_filesystem; return $stack; } #------------------------------------------------------------------------------- sub link_modules_dir { my ( $self, %args ) = @_; my $target_dir = $args{to}; my $modules_dir = $self->config->modules_dir; my $root_dir = $self->config->root_dir; if ( -e $modules_dir or -l $modules_dir ) { debug "Unlinking $modules_dir"; unlink $modules_dir or throw $!; } debug "Linking $modules_dir to $target_dir"; mksymlink( $modules_dir => $target_dir->relative($root_dir) ); return $self; } #------------------------------------------------------------------------------- sub unlink_modules_dir { my ($self) = @_; my $modules_dir = $self->config->modules_dir; if ( -e $modules_dir or -l $modules_dir ) { debug "Unlinking $modules_dir"; unlink $modules_dir or throw $!; } return $self; } #------------------------------------------------------------------------------- sub clean_files { my ( $self, %args ) = @_; my $deleted = 0; my $dists_rs = $self->db->schema->distribution_rs->search( undef, { prefetch => {} } ); my %known_dists = map { ( $_->to_string => 1 ) } $dists_rs->all; my $callback = sub { return if not -f $_; my $path = Path::Class::file($_); my $author = $path->parent->basename; my $archive = $path->basename; return if $archive eq 'CHECKSUMS'; return if $archive eq '01mailrc.txt.gz'; return if exists $known_dists{"$author/$archive"}; debug "Removing orphaned archive at $path"; $self->store->remove_archive($path); $deleted++; }; my $authors_dir = $self->config->authors_dir; debug "Cleaning orphaned archives beneath $authors_dir"; File::Find::find( { no_chdir => 1, wanted => $callback }, $authors_dir ); return $deleted; } #------------------------------------------------------------------------------- sub optimize_database { my ($self) = @_; debug 'Removing empty database pages'; $self->db->schema->storage->dbh->do('VACUUM;'); debug 'Updating database statistics'; $self->db->schema->storage->dbh->do('ANALYZE;'); return $self; } #------------------------------------------------------------------------------- sub get_version { my ($self) = @_; my $version_file = $self->config->version_file; return undef if not -e $version_file; # Old repos have no version file my $version = $version_file->slurp( chomp => 1 ); return $version; } #------------------------------------------------------------------------------- sub set_version { my ( $self, $version ) = @_; $version ||= $REPOSITORY_VERSION; my $version_fh = $self->config->version_file->openw; print {$version_fh} $version, "\n"; close $version_fh; return $self; } #------------------------------------------------------------------------------ sub assert_archive_not_duplicate { my ( $self, $author, $archive ) = @_; throw "Archive $archive does not exist" if not -e $archive; throw "Archive $archive is not readable" if not -r $archive; my $basename = $archive->basename; if ( my $same_path = $self->get_distribution( author => $author, archive => $basename ) ) { throw "A distribution already exists as $same_path"; } my $sha256 = Pinto::Util::sha256($archive); my $dupe = $self->db->schema->search_distribution( { sha256 => $sha256 } )->first; throw "Archive $archive is identical to $dupe" if $dupe; return $self; } #------------------------------------------------------------------------------- sub assert_version_ok { my ($self) = @_; my $repo_version = $self->get_version; my $code_version = $REPOSITORY_VERSION; no warnings qw(uninitialized); if ( $repo_version != $code_version ) { my $msg = "Repository version ($repo_version) and Pinto version ($code_version) do not match.\n"; # For really old repositories, the version is undefined and there is no automated # migration process. If the version is defined, then automatic migration should work. $msg .= defined $repo_version ? "Use the 'migrate' command to bring the repo up to date" : "Contact thaljef\@cpan.org for migration instructions"; throw $msg; } return $self; } #------------------------------------------------------------------------------- sub assert_sanity_ok { my ($self) = @_; my $root_dir = $self->config->root_dir; throw "Directory $root_dir does not exist" unless -e $root_dir; throw "$root_dir is not a directory" unless -d $root_dir; throw "Directory $root_dir is not readable by you" unless -r $root_dir; throw "Directory $root_dir is not writable by you" unless -w $root_dir; throw "Directory $root_dir does not look like a Pinto repository" unless -e $self->config->db_file && -e $self->config->authors_dir; return $self; } #------------------------------------------------------------------------------- sub clear_cache { my ($self) = @_; $self->locator->refresh; # Clears cache file from disk return $self; } #------------------------------------------------------------------------------- __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Repository - Coordinates the database, files, and indexes =head1 VERSION version 0.14 =head1 ATTRIBUTES =head2 root =head2 config =head2 db =head2 store =head2 locator =head2 locker =head1 METHODS =head2 locate( target => ); =head2 lock( $LOCK_TYPE ) =head2 unlock =head2 get_stack() =head2 get_stack( $stack_name ) =head2 get_stack( $stack_object ) Returns the L object with the given C<$stack_name>. If the argument is a L, then it just returns that. If there is no stack with such a name in the repository, throws an exception. If you do not specify a stack name (or it is undefined) then you'll get whatever stack is currently marked as the default stack. The stack object will not be open for revision, so you will not be able to change any of the registrations for that stack. To get a stack that you can modify, use C. =head2 get_stack_maybe() =head2 get_stack_maybe( $stack_name ) =head2 get_stack_maybe( $stack_object ) Same as C but simply returns undef if the stack does not exist rather than throwing an exception. =head2 get_default_stack() Returns the L that is currently marked as the default stack in this repository. This is what you get when you call C without any arguments. The stack object will not be open for revision, so you will not be able to change any of the registrations for that stack. To get a stack that you can modify, use C. At any time, there must be exactly one default stack. This method will throw an exception if it discovers that condition is not true. =head2 get_all_stacks() Returns a list of all the L objects in the repository. You can sort them as strings (by name) or numerically (by last modification time). =head2 get_revision($commit) =head2 get_revision_maybe($commit) =head2 get_package( target => $pkg_spec ) Returns a L representing the latest version of the package in the repository with the same name as the package target B as the package spec. See L for the definition of a package target. =head2 get_package( name => $pkg_name ) Returns a L representing the latest version of the package in the repository with the given C<$pkg_name>. If there is no such package with that name in the repository, returns nothing. =head2 get_package( name => $pkg_name, path => $dist_path ) Returns the L with the given C<$pkg_name> that belongs to the distribution identified by C<$dist_path>. If there is no such package in the repository, returns nothing. TODO: Consider making this a "maybe" function and the wrapping it with a version that throws exceptions if no match is found. See C for an example. =head2 get_distribution( target => $target ) Given a L, returns the L that contains the B in this repository with the same name as the target B. Returns nothing if no such distribution is found. Given a L, returns the L from this repository with the same author id and archive attributes as the target. Returns nothing if no such distribution is found. =head2 get_distribution( path => $dist_path ) Given a distribution path, (for example C or C returns the L from this repository that is identified by the author ID and archive file name in the path. Returns nothing if no such distribution is found. =head2 get_distribution( author => $author, archive => $archive ) Given an author id and a distribution archive file basename, returns the L from this repository with those attributes. Returns nothing if no such distribution exists. TODO: Consider making this a "maybe" function and the wrapping it with a version that throws exceptions if no match is found. See C for an example. =head2 ups_distribution( target => target ) Given a L, locates the distribution that contains the latest version of the package across all upstream repositories with the same name as the target, and the same or higher version as the target. If such distribution is found, it is fetched and added to this repository. If it is not found, then an exception is thrown. Given a L, locates the first distribution in any upstream repository with the same author and archive as the target. If such distribution is found, it is fetched and added to this repository. If it is not found, then an exception is thrown. TODO: Consider making this a "maybe" function and the wrapping it with a version that throws exceptions if no match is found. See C for an example. =head2 add( archive => $path, author => $id ) =head2 add( archive => $path, author => $id, source => $uri ) Adds the distribution archive located on the local filesystem at C<$path> to the repository in the author directory for the author with C<$id>. The packages provided by the distribution will be indexed, and the prerequisites will be recorded. If the C is specified, it must be the URI to the root of the repository where the distribution came from. Otherwise, the C defaults to C. Returns a L object representing the newly added distribution. =head2 fetch_distribution( uri => $uri ) Fetches a distribution archive from a remote URI and adds it to this repository. The packages provided by the distribution will be indexed, and the prerequisites will be recorded. Returns a L object representing the fetched distribution. =head2 clean_files() Deletes all distribution archives that are on the filesystem but not in the database. This can happen when an Action fails or is aborted prematurely. =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Result.pm000644 000766 000024 00000005577 13141540305 016272 0ustar00jeffstaff000000 000000 # ABSTRACT: The result from running an Action package Pinto::Result; use Moose; use MooseX::StrictConstructor; use MooseX::Types::Moose qw(Bool ArrayRef); use MooseX::MarkAsMethods ( autoclean => 1 ); use Pinto::Util qw(itis); use overload ( q{""} => 'to_string' ); #----------------------------------------------------------------------------- our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ has made_changes => ( is => 'ro', isa => Bool, writer => '_set_made_changes', default => 0, ); has was_successful => ( is => 'ro', isa => Bool, writer => '_set_was_successful', default => 1, ); has exceptions => ( traits => [qw(Array)], handles => { exceptions => 'elements', add_exception => 'push' }, isa => ArrayRef, default => sub { [] }, ); #----------------------------------------------------------------------------- sub failed { my ( $self, %args ) = @_; $self->_set_was_successful(0); if ( my $reason = $args{because} ) { # HACK: Sometimes we'll get exceptions that are strings # instead of objects (like from Moose type constraint # violations). So we have to convert them ourselves. # If the message already contains a full stack trace, # then it will be really ugly. God I wish Perl had # sane native exceptions. require Pinto::Exception; $reason = Pinto::Exception->new( message => "$reason" ) if not itis( $reason, 'Pinto::Exception' ); $self->add_exception($reason); } return $self; } #----------------------------------------------------------------------------- sub changed { my ($self) = @_; $self->_set_made_changes(1); return $self; } #----------------------------------------------------------------------------- sub exit_status { my ($self) = @_; return $self->was_successful ? 0 : 1; } #----------------------------------------------------------------------------- sub to_string { my ($self) = @_; return 'ok' if $self->was_successful; if ( my @exceptions = $self->exceptions ) { return join "\n", @exceptions; } return 'unknown error'; } #----------------------------------------------------------------------------- __PACKAGE__->meta->make_immutable; #----------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Result - The result from running an Action =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/RevisionWalker.pm000644 000766 000024 00000003375 13141540305 017752 0ustar00jeffstaff000000 000000 # ABSTRACT: Iterates through revision history package Pinto::RevisionWalker; use Moose; use MooseX::StrictConstructor; use MooseX::Types::Moose qw(ArrayRef); use MooseX::MarkAsMethods ( autoclean => 1 ); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ # TODO: Rethink this API. Do we need start? Can we just use queue? What # about filtering, or walking forward? Sort chronological or topological? has start => ( is => 'ro', isa => 'Pinto::Schema::Result::Revision', required => 1, ); has queue => ( isa => ArrayRef, traits => [qw(Array)], handles => { enqueue => 'push', dequeue => 'shift' }, default => sub { [ $_[0]->start ] }, lazy => 1, ); #------------------------------------------------------------------------------ sub next { my ($self) = @_; my $next = $self->dequeue; return if not $next; return if $next->is_root; $self->enqueue( $next->parents ); return $next; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::RevisionWalker - Iterates through revision history =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Role/000755 000766 000024 00000000000 13141540305 015341 5ustar00jeffstaff000000 000000 Pinto-0.14/lib/Pinto/Schema/000755 000766 000024 00000000000 13141540305 015640 5ustar00jeffstaff000000 000000 Pinto-0.14/lib/Pinto/Schema.pm000644 000766 000024 00000007606 13141540305 016207 0ustar00jeffstaff000000 000000 use utf8; package Pinto::Schema; # Created by DBIx::Class::Schema::Loader # DO NOT MODIFY THE FIRST PART OF THIS FILE use Moose; use MooseX::MarkAsMethods autoclean => 1; extends 'DBIx::Class::Schema'; __PACKAGE__->load_namespaces; # Created by DBIx::Class::Schema::Loader v0.07015 @ 2012-04-29 01:03:56 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:yRlbDgtAuKaDHF9i1Kwqsg #------------------------------------------------------------------------------- # ABSTRACT: The DBIx::Class::Schema for Pinto #------------------------------------------------------------------------------- our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------- use MooseX::SetOnce; use Pinto::Util qw(decamelize throw); #------------------------------------------------------------------------------- use Readonly; Readonly our $SCHEMA_VERSION => 1; sub schema_version { return $SCHEMA_VERSION } #------------------------------------------------------------------------------- has repo => ( is => 'rw', isa => 'Pinto::Repository', traits => [qw(SetOnce)], weak_ref => 1, ); #------------------------------------------------------------------------------- sub set_db_version { my ($self) = @_; # NOTE: SQLite only permits integers for the user_version. # The decimal portion of any float will be truncated. my $version = $self->schema_version; my $dbh = $self->storage->dbh; $dbh->do("PRAGMA user_version = $version"); return; } #------------------------------------------------------------------------------- sub get_db_version { my ($self) = @_; my $dbh = $self->storage->dbh; my @version = $dbh->selectrow_array('PRAGMA user_version'); return $version[0]; } #------------------------------------------------------------------------------- sub assert_db_version_ok { my ($self) = @_; my $schema_version = $self->schema_version; my $db_version = $self->get_db_version; throw "Database version ($db_version) and schema version ($schema_version) do not match" if $db_version != $schema_version; return $self; } #------------------------------------------------------------------------------- sub resultset_names { my ($class) = @_; my @resultset_names = sort keys %{ $class->source_registrations }; return @resultset_names; } #------------------------------------------------------------------------------- for my $rs ( __PACKAGE__->resultset_names ) { ## no critic no strict 'refs'; my $rs_decameled = decamelize($rs); my $rs_method_name = __PACKAGE__ . "::${rs_decameled}_rs"; *{$rs_method_name} = eval "sub { return \$_[0]->resultset('$rs') }"; my $create_method_name = __PACKAGE__ . "::create_${rs_decameled}"; *{$create_method_name} = eval "sub { return \$_[0]->$rs_method_name->create(\$_[1]) }"; my $search_method_name = __PACKAGE__ . "::search_${rs_decameled}"; *{$search_method_name} = eval "sub { return \$_[0]->$rs_method_name->search(\$_[1] || {}, \$_[2] || {}) }"; my $find_method_name = __PACKAGE__ . "::find_${rs_decameled}"; *{$find_method_name} = eval "sub { return \$_[0]->$rs_method_name->find(\$_[1] || {}, \$_[2] || {}) }"; ## use critic } #------------------------------------------------------------------------------- __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Schema - The DBIx::Class::Schema for Pinto =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Server/000755 000766 000024 00000000000 13141540305 015706 5ustar00jeffstaff000000 000000 Pinto-0.14/lib/Pinto/Server.pm000644 000766 000024 00000007332 13141540305 016251 0ustar00jeffstaff000000 000000 # ABSTRACT: Web interface to a Pinto repository package Pinto::Server; use Moose; use MooseX::ClassAttribute; use MooseX::Types::Moose qw(Int HashRef); use Carp; use Path::Class; use Class::Load; use Scalar::Util qw(blessed); use IO::Interactive qw(is_interactive); use Plack::Middleware::Auth::Basic; use Pinto::Types qw(Dir); use Pinto::Constants qw(:server); use Pinto::Server::Router; use Pinto::Repository; #------------------------------------------------------------------------------- our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------- has root => ( is => 'ro', isa => Dir, required => 1, coerce => 1, ); has auth => ( is => 'ro', isa => HashRef, traits => ['Hash'], handles => { auth_options => 'elements' }, ); has router => ( is => 'ro', isa => 'Pinto::Server::Router', default => sub { Pinto::Server::Router->new }, lazy => 1, ); class_has default_port => ( is => 'ro', isa => Int, default => $PINTO_SERVER_DEFAULT_PORT, ); #------------------------------------------------------------------------------- sub BUILD { my ($self) = @_; my $repo = Pinto::Repository->new( root => $self->root ); $repo->assert_sanity_ok; return $self; } #------------------------------------------------------------------------------- sub to_app { my ($self) = @_; my $app = sub { $self->call(@_) }; if ( my %auth_options = $self->auth_options ) { my $backend = delete $auth_options{backend} or carp 'No auth backend provided!'; my $class = 'Authen::Simple::' . $backend; print "Authenticating using $class\n" if is_interactive; Class::Load::load_class($class); $app = Plack::Middleware::Auth::Basic->wrap( $app, authenticator => $class->new(%auth_options) ); } return $app; } #------------------------------------------------------------------------------- sub call { my ( $self, $env ) = @_; my $response = $self->router->route( $env, $self->root ); $response = $response->finalize if blessed($response) && $response->can('finalize'); return $response; } #------------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Server - Web interface to a Pinto repository =head1 VERSION version 0.14 =head1 ATTRIBUTES =head2 root The path to the root directory of your Pinto repository. The repository must already exist at this location. This attribute is required. =head2 auth The hashref of authentication options, if authentication is to be used within the server. One of the options must be 'backend', to specify which Authen::Simple:: class to use; the other key/value pairs will be passed as-is to the Authen::Simple class. =head2 router An object that does the L role. This object will do the work of processing the request and returning a response. =head2 default_port Returns the default port number that the server will listen on. This is a class attribute. =head1 METHODS =head2 to_app() Returns the application as a subroutine reference. =head2 call( $env ) Invokes the application with the specified environment. Returns a PSGI-compatible response. There is nothing to see here. Look at L if you want to start the server. =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Shell.pm000644 000766 000024 00000005076 13141540305 016055 0ustar00jeffstaff000000 000000 # ABSTRACT: Shell into a distribution package Pinto::Shell; use Moose; use MooseX::StrictConstructor; use MooseX::MarkAsMethods ( autoclean => 1 ); use MooseX::Types::Moose qw(Str); use Pinto::Util qw(throw); use Pinto::Types qw(File Dir); use Path::Class qw(file); use Cwd::Guard qw(cwd_guard); use overload ( q{""} => 'to_string' ); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ has shell => ( is => 'ro', isa => File, builder => '_build_shell', ); has archive => ( is => 'ro', isa => File, required => 1, ); has unpacker => ( is => 'ro', isa => 'Pinto::ArchiveUnpacker', default => sub { Pinto::ArchiveUnpacker->new( archive => $_[0]->archive ) }, init_arg => undef, lazy => 1, ); has work_dir => ( is => 'ro', isa => Dir, default => sub { $_[0]->unpacker->unpack }, init_arg => undef, lazy => 1, ); #------------------------------------------------------------------------------ sub _build_shell { my $shell = $ENV{PINTO_SHELL} || $ENV{SHELL} || $ENV{COMSPEC} or throw "You don't seem to have a SHELL"; my $shell_resolved = eval { file($shell)->resolve } or throw "Can't resolve the path to your SHELL $shell"; -x $shell_resolved or throw "Your SHELL $shell is not executable"; return $shell_resolved; } #------------------------------------------------------------------------------ sub spawn { my ($self) = @_; my $cwd_guard = cwd_guard( $self->work_dir ); # TODO: This probably isn't very portable, especially if the # shell command contains spaces or special characters. We # probably need to shell-quote the command and pass a list. return system("$self") == 0; } #----------------------------------------------------------------------------- sub to_string { my ($self) = @_; return $self->shell->stringify; } #----------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Shell - Shell into a distribution =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Statistics.pm000644 000766 000024 00000006026 13141540305 017134 0ustar00jeffstaff000000 000000 # ABSTRACT: Report statistics about a Pinto repository package Pinto::Statistics; use Moose; use MooseX::StrictConstructor; use MooseX::MarkAsMethods ( autoclean => 1 ); use String::Format; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ has stack => ( is => 'ro', isa => 'Pinto::Schema::Result::Stack', required => 1, ); #------------------------------------------------------------------------------ sub total_distributions { my ($self) = @_; return $self->stack->repo->distribution_count; } #------------------------------------------------------------------------------ sub stack_distributions { my ($self) = @_; return $self->stack->distribution_count; } #------------------------------------------------------------------------------ sub total_packages { my ($self) = @_; return $self->stack->repo->package_count; } #------------------------------------------------------------------------------ sub stack_packages { my ($self) = @_; return $self->stack->package_count; } #------------------------------------------------------------------------------ # TODO: Other statistics to consider... # # foreign packages (total/indexed) # local packages (total/indexed) # foreign dists (total/indexed) # local dists (total/indexed) # avg pkgs per dist # avg # pkg revisions # authors # most prolific author # N most recently added dist #------------------------------------------------------------------------------ sub to_string { my ( $self, $format ) = @_; my %fspec = ( 'D' => sub { $self->total_distributions }, 'd' => sub { $self->stack_distributions }, 'k' => sub { $self->stack }, 'P' => sub { $self->total_packages }, 'p' => sub { $self->stack_packages }, ); $format ||= $self->default_format(); return String::Format::stringf( $format, %fspec ); } #------------------------------------------------------------------------------ sub default_format { my ($self) = @_; return <<'END_FORMAT'; STATISTICS FOR THE "%k" STACK ------------------------------------- Stack Total ---------------------- Packages %10p %10P Distributions %10d %10D END_FORMAT } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Statistics - Report statistics about a Pinto repository =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Store.pm000644 000766 000024 00000006465 13141540305 016105 0ustar00jeffstaff000000 000000 # ABSTRACT: Storage for distribution archives package Pinto::Store; use Moose; use MooseX::StrictConstructor; use MooseX::MarkAsMethods ( autoclean => 1 ); use Try::Tiny; use CPAN::Checksums; use Pinto::Util qw(debug throw); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ with qw( Pinto::Role::UserAgent ); #------------------------------------------------------------------------------ has repo => ( is => 'ro', isa => 'Pinto::Repository', weak_ref => 1, required => 1, ); #------------------------------------------------------------------------------ # TODO: Use named arguments here... sub add_archive { my ( $self, $origin, $destination ) = @_; throw "$origin does not exist" if not -e $origin; throw "$origin is not a file" if not -f $origin; $self->mirror( $origin => $destination ); $self->update_checksums( directory => $destination->parent ); return $self; } #------------------------------------------------------------------------------ # TODO: Use named arguments here... sub remove_archive { my ( $self, $archive_file ) = @_; $self->remove_path( path => $archive_file ); $self->update_checksums( directory => $archive_file->parent ); return $self; } #------------------------------------------------------------------------------ sub remove_path { my ( $self, %args ) = @_; my $path = $args{path}; throw "Must specify a path" if not $path; return if not -e $path; $path->remove or throw "Failed to remove path $path: $!"; while ( my $dir = $path->parent ) { last if $dir->children; debug("Removing empty directory $dir"); $dir->remove or throw "Failed to remove directory $dir: $!"; $path = $dir; } return $self; } #------------------------------------------------------------------------------ sub update_checksums { my ( $self, %args ) = @_; my $dir = $args{directory}; return 0 if $ENV{PINTO_NO_CHECKSUMS}; return 0 if not -e $dir; # Would be fishy! my @children = $dir->children; return if not @children; my $cs_file = $dir->file('CHECKSUMS'); if ( -e $cs_file && @children == 1 ) { $self->remove_path( path => $cs_file ); return 0; } debug("Generating $cs_file"); try { CPAN::Checksums::updatedir($dir) } catch { throw "CHECKSUM generation failed for $dir: $_" }; return $self; } #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Store - Storage for distribution archives =head1 VERSION version 0.14 =head1 DESCRIPTION L is the base class for Pinto Stores. It provides the basic API for adding/removing distribution archives to the store. Subclasses implement the underlying logic by augmenting the methods declared here. =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Target/000755 000766 000024 00000000000 13141540305 015666 5ustar00jeffstaff000000 000000 Pinto-0.14/lib/Pinto/Target.pm000644 000766 000024 00000003552 13141540305 016231 0ustar00jeffstaff000000 000000 # ABSTRACT: Create Spec objects from strings package Pinto::Target; use strict; use warnings; use Class::Load; use Pinto::Exception; #------------------------------------------------------------------------------- our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------- sub new { my ( $class, $arg ) = @_; my $type = ref $arg; my $target_class; if ( not $type ) { $target_class = ( $arg =~ m{/}x ) ? 'Pinto::Target::Distribution' : 'Pinto::Target::Package'; } elsif ( ref $arg eq 'HASH' ) { $target_class = ( exists $arg->{author} ) ? 'Pinto::Target::Distribution' : 'Pinto::Target::Package'; } else { # I would just use throw() here, but I need to avoid # creating a circular dependency between this package, # Pinto::Types and Pinto::Util. my $message = "Don't know how to make target from $arg"; Pinto::Exception->throw( message => $message ); } Class::Load::load_class($target_class); return $target_class->new($arg); } #------------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Target - Create Spec objects from strings =head1 VERSION version 0.14 =head1 METHODS =head2 new( $string ) [Class Method] Returns either a L or L object constructed from the given C<$string>. =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Types.pm000644 000766 000024 00000017562 13141540305 016115 0ustar00jeffstaff000000 000000 # ABSTRACT: Moose types used within Pinto package Pinto::Types; use strict; use warnings; use version; use MooseX::Types -declare => [ qw( ANSIColor ANSIColorPalette AuthorID DiffStyle Dir DistributionTarget DistributionTargetList File FileList Io PackageTarget PackageTargetList PerlVersion PropertyName RevisionHead RevisionID StackAll StackDefault StackName StackObject Target TargetList Uri Username Version )]; use MooseX::Types::Moose qw( Str Num ScalarRef ArrayRef Undef HashRef FileHandle Object Int ); use URI; use Path::Class::Dir; use Path::Class::File; use Term::ANSIColor; use Module::CoreList; use IO::String; use IO::Handle; use IO::File; use Pinto::Target; use Pinto::Constants qw(:all); #----------------------------------------------------------------------------- our $VERSION = '0.14'; # VERSION #----------------------------------------------------------------------------- subtype AuthorID, as Str, where { $_ =~ $PINTO_AUTHOR_REGEX }, message { 'The author id (' . ( defined() ? $_ : 'undef' ) . ') must match /^[A-Z]{2}[-A-Z0-9]*$/' }; coerce AuthorID, from Str, via { uc $_ }; #----------------------------------------------------------------------------- subtype Username, as Str, where { $_ =~ $PINTO_USERNAME_REGEX }, message { 'The username (' . ( defined() ? $_ : 'undef' ) . ') must be alphanumeric' }; #----------------------------------------------------------------------------- subtype StackName, as Str, where { $_ =~ $PINTO_STACK_NAME_REGEX }, message { 'The stack name (' . ( defined() ? $_ : 'undef' ) . ') must be alphanumeric' }; #----------------------------------------------------------------------------- subtype StackAll, as Str, where { $_ eq $PINTO_STACK_NAME_ALL }, message {qq{The stack name must be '$PINTO_STACK_NAME_ALL'}}; #----------------------------------------------------------------------------- subtype StackDefault, as Undef; #----------------------------------------------------------------------------- class_type StackObject, { class => 'Pinto::Schema::Result::Stack' }; #----------------------------------------------------------------------------- subtype PropertyName, as Str, where { $_ =~ $PINTO_PROPERTY_NAME_REGEX }, message { 'The property name (' . ( defined() ? $_ : 'undef' ) . 'must be alphanumeric' }; #----------------------------------------------------------------------------- class_type Version, { class => 'version' }; coerce Version, from Str, via { version->parse($_) }; coerce Version, from Num, via { version->parse($_) }; #----------------------------------------------------------------------------- subtype PerlVersion, as Object, where { $_->isa('version') && exists $Module::CoreList::version{ $_->numify + 0 } }, message {"perl version ($_) is unknown to me; try updating Pinto's copy of Module::CoreList"}; coerce PerlVersion, from Str, via { version->parse($_) }; coerce PerlVersion, from Num, via { version->parse($_) }; #----------------------------------------------------------------------------- subtype ANSIColor, as Str, where { Term::ANSIColor::colorvalid($_) }, message { 'The color name (' . ( defined() ? $_ : 'undef' ) . 'is not valid' }; #----------------------------------------------------------------------------- subtype ANSIColorPalette, as ArrayRef[ANSIColor], where { @{$_} == 3 }, message {'Must be exactly three colors'}; #----------------------------------------------------------------------------- class_type Uri, { class => 'URI' }; coerce Uri, from Str, via { URI->new($_) }; #----------------------------------------------------------------------------- class_type Dir, { class => 'Path::Class::Dir' }; # file:/// URIs will be converted to plain paths coerce Dir, from Str, via { $_ =~ s{^file://}{}; Path::Class::Dir->new($_) }; #----------------------------------------------------------------------------- class_type File, { class => 'Path::Class::File' }; # file:/// URIs will be converted to plain paths coerce File, from Str, via { $_ =~ s{^file://}{}; Path::Class::File->new($_) }; #----------------------------------------------------------------------------- subtype FileList, as ArrayRef [File]; coerce FileList, from File, via { [ $_ ] }, from Str, via { s{^file://}{}; [ Path::Class::File->new($_) ] }, from ArrayRef[Str], via { [ map { s{^file://}{}; Path::Class::File->new($_) } @$_ ] }; #----------------------------------------------------------------------------- class_type PackageTarget, { class => 'Pinto::Target::Package' }; coerce PackageTarget, from Str, via { Pinto::Target->new($_) }, from HashRef, via { Pinto::Target->new($_) }; #----------------------------------------------------------------------------- class_type DistributionTarget, { class => 'Pinto::Target::Distribution' }; coerce DistributionTarget, from Str, via { Pinto::Target->new($_) }, from HashRef, via { Pinto::Target->new($_) }; #----------------------------------------------------------------------------- subtype TargetList, as ArrayRef [ PackageTarget | DistributionTarget ]; ## no critic qw(ProhibitBitwiseOperators); coerce TargetList, from PackageTarget, via { [ $_ ] }, from DistributionTarget, via { [ $_ ] }, from Str, via { [ Pinto::Target->new($_) ] }, from ArrayRef[Str], via { [ map { Pinto::Target->new($_) } @$_ ] }; #----------------------------------------------------------------------------- subtype DistributionTargetList, as ArrayRef [DistributionTarget]; ## no critic qw(ProhibitBitwiseOperators); coerce DistributionTargetList, from DistributionTarget, via { [$_] }, from Str, via { [ Pinto::Target::Distribution->new($_) ] }, from ArrayRef[Str], via { [ map { Pinto::Target::Distribution->new($_) } @$_ ] }; #----------------------------------------------------------------------------- subtype PackageTargetList, as ArrayRef [PackageTarget]; ## no critic qw(ProhibitBitwiseOperators); coerce PackageTargetList, from DistributionTarget, via { [ $_ ] }, from Str, via { [ Pinto::Target::Package->new($_) ] }, from ArrayRef[Str], via { [ map { Pinto::Target::Package->new($_) } @$_ ] }; #----------------------------------------------------------------------------- subtype Io, as Object; coerce Io, from Str, via { my $fh = IO::File->new(); $fh->open($_); return $fh }, from File, via { my $fh = IO::File->new(); $fh->open("$_"); return $fh }, from ArrayRef, via { IO::Handle->new_from_fd(@$_) }, from ScalarRef, via { IO::String->new( ${$_} ) }; #----------------------------------------------------------------------------- subtype RevisionID, as Str, where { $_ =~ $PINTO_REVISION_ID_REGEX and length($_) >= 4 }, message { 'The revision id (' . ( defined() ? $_ : 'undef' ) . ') must be a hexadecimal string of 4 or more chars' }; coerce RevisionID, from Str, via { lc $_ }; #----------------------------------------------------------------------------- subtype RevisionHead, as Undef; #----------------------------------------------------------------------------- enum DiffStyle, [$PINTO_DIFF_STYLE_CONCISE, $PINTO_DIFF_STYLE_DETAILED]; #----------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Types - Moose types used within Pinto =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Util.pm000644 000766 000024 00000042454 13141540305 015724 0ustar00jeffstaff000000 000000 # ABSTRACT: Static utility functions for Pinto package Pinto::Util; use strict; use warnings; use version; use base qw(Exporter); use URI; use URI::file; use Carp; use DateTime; use File::Temp; use Path::Class; use Digest::MD5; use Digest::SHA; use Scalar::Util; use UUID::Tiny; use Readonly; use Pinto::Globals; use Pinto::Constants qw(:all); use Pinto::Types qw(DiffStyle); #------------------------------------------------------------------------------- our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------- Readonly our @EXPORT_OK => qw( author_dir body_text current_author_id current_utc_time current_time_offset current_username debug decamelize default_diff_style indent_text interpolate is_blank is_not_blank is_interactive is_remote_repo is_system_prop isa_perl itis make_uri md5 mksymlink mtime parse_dist_path mask_uri_passwords sha256 tempdir title_text throw trim_text truncate_text user_palette uuid whine ); Readonly our %EXPORT_TAGS => ( all => \@EXPORT_OK ); #------------------------------------------------------------------------------- sub throw { my ($error) = @_; # Rethrowing... $error->throw if itis( $error, 'Pinto::Exception' ); require Pinto::Exception; Pinto::Exception->throw( message => "$error" ); return; # Should never get here } #------------------------------------------------------------------------------- sub debug { my ($it) = @_; # TODO: Use Carp instead? return 1 if not $ENV{PINTO_DEBUG}; $it = $it->() if ref $it eq 'CODE'; my ( $file, $line ) = (caller)[ 1, 2 ]; print {*STDERR} "$it in $file at line $line\n"; return 1; } #------------------------------------------------------------------------------- sub whine { my ($message) = @_; if ( $ENV{DEBUG} ) { Carp::cluck($message); return 1; } chomp $message; warn $message . "\n"; return 1; } #------------------------------------------------------------------------------- sub author_dir { ## no critic (ArgUnpacking) my $author = uc pop; my @base = @_; return dir( @base, substr( $author, 0, 1 ), substr( $author, 0, 2 ), $author ); } #------------------------------------------------------------------------------- sub itis { my ( $var, $class ) = @_; return ref $var && Scalar::Util::blessed($var) && $var->isa($class); } #------------------------------------------------------------------------------- sub parse_dist_path { my ($path) = @_; # eg: /yadda/authors/id/A/AU/AUTHOR/subdir1/subdir2/Foo-1.0.tar.gz # or: A/AU/AUTHOR/subdir/Foo-1.0.tar.gz if ( $path =~ s{^ (?:.*/authors/id/)? (.*) $}{$1}mx ) { # $path = 'A/AU/AUTHOR/subdir/Foo-1.0.tar.gz' my @path_parts = split m{ / }mx, $path; my $author = $path_parts[2]; # AUTHOR my $archive = $path_parts[-1]; # Foo-1.0.tar.gz return ( $author, $archive ); } throw "Unable to parse path: $path"; } #------------------------------------------------------------------------------- sub isa_perl { my ($path_or_uri) = @_; return $path_or_uri =~ m{ / perl-[\d.]+ \.tar \.(?: gz|bz2 ) $ }mx; } #------------------------------------------------------------------------------- sub mtime { my ($file) = @_; throw 'Must supply a file' if not $file; throw "$file does not exist" if not -e $file; return ( stat $file )[9]; } #------------------------------------------------------------------------------- sub md5 { my ($file) = @_; throw 'Must supply a file' if not $file; throw "$file does not exist" if not -e $file; my $fh = $file->openr(); my $md5 = Digest::MD5->new->addfile($fh)->hexdigest(); return $md5; } #------------------------------------------------------------------------------- sub sha256 { my ($file) = @_; throw 'Must supply a file' if not $file; throw "$file does not exist" if not -e $file; my $fh = $file->openr(); my $sha256 = Digest::SHA->new(256)->addfile($fh)->hexdigest(); return $sha256; } #------------------------------------------------------------------------------- sub validate_property_name { my ($prop_name) = @_; throw "Invalid property name $prop_name" if $prop_name !~ $PINTO_PROPERTY_NAME_REGEX; return $prop_name; } #------------------------------------------------------------------------------- sub validate_stack_name { my ($stack_name) = @_; throw "Invalid stack name $stack_name" if $stack_name !~ $PINTO_STACK_NAME_REGEX; return $stack_name; } #------------------------------------------------------------------------------- sub current_utc_time { ## no critic qw(PackageVars) return $Pinto::Globals::current_utc_time if defined $Pinto::Globals::current_utc_time; return time; } #------------------------------------------------------------------------------- sub current_time_offset { ## no critic qw(PackageVars) return $Pinto::Globals::current_time_offset if defined $Pinto::Globals::current_time_offset; my $now = current_utc_time; my $time = DateTime->from_epoch( epoch => $now, time_zone => 'local' ); return $time->offset; } #------------------------------------------------------------------------------- sub current_username { ## no critic qw(PackageVars) return $Pinto::Globals::current_username if defined $Pinto::Globals::current_username; my $username = $ENV{PINTO_USERNAME} || $ENV{USER} || $ENV{LOGIN} || $ENV{USERNAME} || $ENV{LOGNAME}; throw "Unable to determine your username. Set PINTO_USERNAME." if not $username; return $username; } #------------------------------------------------------------------------------- sub current_author_id { ## no critic qw(PackageVars) return $Pinto::Globals::current_author_id if defined $Pinto::Globals::current_author_id; my $author_id = $ENV{PINTO_AUTHOR_ID}; return uc $author_id if $author_id; my $username = current_username; $username =~ s/[^a-zA-Z0-9]//g; return uc $username; } #------------------------------------------------------------------------------- sub is_interactive { ## no critic qw(PackageVars) return $Pinto::Globals::is_interactive if defined $Pinto::Globals::is_interactive; return -t STDOUT; } #------------------------------------------------------------------------------- sub interpolate { my $string = shift; return eval qq{"$string"}; ## no critic qw(Eval) } #------------------------------------------------------------------------------- sub trim_text { my $string = shift; $string =~ s/^ \s+ //x; $string =~ s/ \s+ $//x; return $string; } #------------------------------------------------------------------------------- sub title_text { my $string = shift; my $nl = index $string, "\n"; return $nl < 0 ? $string : substr $string, 0, $nl; } #------------------------------------------------------------------------------- sub body_text { my $string = shift; my $nl = index $string, "\n"; return '' if $nl < 0 or $nl == length $string; return substr $string, $nl + 1; } #------------------------------------------------------------------------------- sub truncate_text { my ( $string, $max_length, $elipses ) = @_; return $string if not $max_length; return $string if length $string <= $max_length; $elipses = '...' if not defined $elipses; my $truncated = substr $string, 0, $max_length; return $truncated . $elipses; } #------------------------------------------------------------------------------- sub decamelize { my $string = shift; return if not defined $string; $string =~ s/ ([a-z]) ([A-Z]) /$1_$2/xg; return lc $string; } #------------------------------------------------------------------------------- sub indent_text { my ( $string, $spaces ) = @_; return $string if not $spaces; return $string if not $string; my $indent = ' ' x $spaces; $string =~ s/^ /$indent/xmg; return $string; } #------------------------------------------------------------------------------- sub mksymlink { my ( $from, $to ) = @_; # TODO: Try to add Win32 support here, somehow. debug "Linking $to to $from"; symlink $to, $from or throw "symlink to $to from $from failed: $!"; return 1; } #------------------------------------------------------------------------------- sub is_system_prop { my $string = shift; return 0 if not $string; return $string =~ m/^ pinto- /x; } #------------------------------------------------------------------------------- sub uuid { return UUID::Tiny::create_uuid_as_string(UUID::Tiny::UUID_V4); } #------------------------------------------------------------------------------- sub user_palette { my $palette = $ENV{PINTO_PALETTE} || $ENV{PINTO_COLORS} || $ENV{PINTO_COLOURS}; # For backcompat return $PINTO_DEFAULT_PALETTE if not $palette; return [ split m/\s* , \s*/x, $palette ]; } #------------------------------------------------------------------------------- sub is_blank { my ($string) = @_; return 1 if not $string; return 0 if $string =~ m/ \S /x; return 1; } #------------------------------------------------------------------------------- sub is_not_blank { my ($string) = @_; return !is_blank($string); } #------------------------------------------------------------------------------- sub mask_uri_passwords { my ($uri) = @_; $uri =~ s{ (https?://[^:/@]+ :) [^@/]+@}{$1*password*@}gx; return $uri; } #------------------------------------------------------------------------------- sub is_remote_repo { my ($uri) = @_; return if not $uri; return $uri =~ m{^https?://}x; } #------------------------------------------------------------------------------- sub tempdir { return Path::Class::dir(File::Temp::tempdir(CLEANUP => 1)); } #------------------------------------------------------------------------------- sub default_diff_style { if (my $style = $ENV{PINTO_DIFF_STYLE}) { throw "PINTO_DIFF_STYLE ($style) is invalid. Must be one of (@PINTO_DIFF_STYLES)" unless DiffStyle->check($style); return $style; } return $PINTO_DIFF_STYLE_CONCISE; } #------------------------------------------------------------------------------- sub make_uri { my ($it) = @_; return $it if itis( $it, 'URI' ); return URI::file->new( $it->absolute ) if itis( $it, 'Path::Class::File' ); return URI::file->new( file($it)->absolute ) if -e $it; return URI->new($it); } #------------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Util - Static utility functions for Pinto =head1 VERSION version 0.14 =head1 DESCRIPTION This is a private module for internal use only. There is nothing for you to see here (yet). All API documentation is purely for my own reference. =head1 FUNCTIONS =head2 throw($message) =head2 throw($exception_object) Throws a L with the given message. If given a reference to a L object, then it just throws it again. =head2 debug( $message ) =head2 debug( sub {...} ) Writes the message on STDERR if the C environment variable is true. If the argument is a subroutine, it will be invoked and its output will be written instead. Always returns true. =head2 whine( $message ) Just calls warn(), but always appends the newline so that line numbers are suppressed. =head2 author_dir( @base, $author ) Given the name of an C<$author>, returns the directory where the distributions for that author belong (as a L). The optional C<@base> can be a series of L or path parts (as strings). If C<@base> is given, it will be prepended to the directory that is returned. =head2 itis( $var, $class ) Asserts whether var is a blessed reference and is an instance of the C<$class>. =head2 parse_dist_path( $path ) Parses a path like the ones you would see in a full URI to a distribution in a CPAN repository, or the URI fragment you would see in a CPAN index. Returns the author and file name of the distribution. Subdirectories between the author name and the file name are discarded. =head2 isa_perl( $path_or_uri ) Return true if C<$path_or_uri> appears to point to a release of perl itself. This is based on some file naming patterns that I've seen in the wild. It may not be completely accurate. =head2 mtime( $file ) Returns the last modification time (in epoch seconds) for the C. The argument is required and the file must exist or an exception will be thrown. =head2 md5( $file ) Returns the C digest (as a hex string) for the C<$file>. The argument is required and the file must exist on an exception will be thrown. =head2 sha256( $file ) Returns the C digest (as a hex string) for the C<$file>. The argument is required and the file must exist on an exception will be thrown. =head2 validate_property_name( $prop_name ) Throws an exception if the property name is invalid. Currently, property names must be alphanumeric plus any underscores or hyphens. =head2 validate_stack_name( $stack_name ) Throws an exception if the stack name is invalid. Currently, stack names must be alphanumeric plus underscores or hyphens. =head2 current_utc_time() Returns the current time (in epoch seconds) unless the current time has been overridden by C<$Pinto::Globals::current_utc_time>. =head2 current_time_offset() Returns the offset between current UTC time and the local time in seconds, unless overridden by C<$Pinto::Globals::current_time_offset>. The C function is used to determine the current UTC time. =head2 current_username() Returns the username of the current user unless it has been overridden by C<$Pinto::Globals::current_username>. The username can be defined through a number of environment variables. Throws an exception if no username can be determined. =head2 current_author_id() Returns the author id of the current user unless it has been overridden by C<$Pinto::Globals::current_author_id>. The author id can be defined through environment variables. Otherwise it defaults to the upper-case form of the C. And since PAUSE only allows letters and numbers in the author id, then we remove all of those from the C too. =head2 is_interactive() Returns true if the process is connected to an interactive terminal (i.e. a keyboard & screen) unless it has been overridden by C<$Pinto::Globals::is_interactive>. =head2 interpolate($string) Performs interpolation on a literal string. The string should not include anything that looks like a variable. Only metacharacters (like \n) will be interpolated correctly. =head2 trim_text($string) Returns the string with all leading and trailing whitespace removed. =head2 title_text($string) Returns all the characters in C<$string> before the first newline. If there is no newline, returns the entire C<$string>. =head2 body_text($string) Returns all the characters in C<$string> after the first newline. If there is no newline, returns an empty string. =head2 truncate_text($string, $length, $elipses) Truncates the C<$string> and appends C<$elipses> if the C<$string> is longer than C<$length> characters. C<$elipses> defaults to '...' if not specified. =head2 decamelize($string) Returns the string forced to lower case and words separated by underscores. For example C becomes C. =head2 indent_text($string, $n) Returns a copy of C<$string> with each line indented by C<$n> spaces. In other words, it puts C<4n> spaces immediately after each newline in C<$string>. The original C<$string> is not modified. =head2 mksymlink($from => $to) Creates a symlink between the two files. No checks are performed to see if either path is valid or already exists. Throws an exception if the operation fails or is not supported. =head2 is_system_prop($string) Returns true if C<$string> is the name of a system property. =head2 uuid() Returns a UUID as a string. Currently, the UUID is derived from random numbers. =head2 user_palette() Returns a reference to an array containing the names of the colors pinto can use. This can be influenced by setting the C environment variable. =head2 is_blank($string) Returns true if the string is undefined, empty, or contains only whitespace. =head2 is_not_blank($string) Returns true if the string contains any non-whitespace characters. =head2 mask_uri_passwords($string) Masks the parts the string that look like a password embedded in an http or https URI. For example, C would return C =head2 is_remote_repo { Returns true if the argument looks like a URI to a remote repository =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Target/Distribution.pm000644 000766 000024 00000005701 13141540305 020706 0ustar00jeffstaff000000 000000 # ABSTRACT: Specifies a distribution by author and archive package Pinto::Target::Distribution; use Moose; use MooseX::MarkAsMethods ( autoclean => 1 ); use MooseX::Types::Moose qw(ArrayRef Str); use Pinto::Types qw(AuthorID); use Pinto::Util qw(throw author_dir); use overload ( '""' => 'to_string' ); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ has author => ( is => 'ro', isa => AuthorID, coerce => 1, required => 1, ); has archive => ( is => 'ro', isa => Str, required => 1, ); has subdirs => ( is => 'ro', isa => ArrayRef[Str], default => sub { [] }, ); #------------------------------------------------------------------------------ around BUILDARGS => sub { my $orig = shift; my $class = shift; my @args = @_; if ( @args == 1 and not ref $args[0] ) { my @path_parts = split m{/+}x, $args[0]; my $author = shift @path_parts; # First element my $archive = pop @path_parts; # Last element my $subdirs = [@path_parts]; # Everything else throw "Invalid distribution target: $args[0]" if not( $author and $archive ); @args = ( author => $author, subdirs => $subdirs, archive => $archive ); } return $class->$orig(@args); }; #------------------------------------------------------------------------------ sub path { my ($self) = @_; my $author_dir = author_dir($self->author); my @subdirs = @{ $self->subdirs }; my $archive = $self->archive; return join '/', $author_dir, @subdirs, $archive; } #------------------------------------------------------------------------------ sub to_string { my ($self) = @_; my $author = $self->author; my @subdirs = @{ $self->subdirs }; my $archive = $self->archive; return join '/', $author, @subdirs, $archive; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Target::Distribution - Specifies a distribution by author and archive =head1 VERSION version 0.14 =head1 METHODS =head2 path() Returns the canonical string form of this DistributionSpec, which is suitable for constructing a URI. =head2 to_string Serializes this Target to its string form. This method is called whenever the Target is evaluated in string context. =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Target/Package.pm000644 000766 000024 00000012570 13141540305 017564 0ustar00jeffstaff000000 000000 # ABSTRACT: Specifies a package by name and version package Pinto::Target::Package; use Moose; use MooseX::MarkAsMethods ( autoclean => 1 ); use MooseX::Types::Moose qw(Str); use Try::Tiny; use Module::CoreList; use CPAN::Meta::Requirements; use Pinto::Types qw(Version); use Pinto::Util qw(throw trim_text); use version; use overload ( '""' => 'to_string'); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ has name => ( is => 'ro', isa => Str, required => 1, ); has version => ( is => 'ro', isa => Str | Version, default => '0', coerce => 1, ); has _vreq => ( is => 'ro', isa => 'CPAN::Meta::Requirements', writer => '_set_vreq', init_arg => undef, ); #------------------------------------------------------------------------------ around BUILDARGS => sub { my $orig = shift; my $class = shift; my @args = @_; if ( @args == 1 and not ref $args[0] ) { throw "Invalid package specification: $_[0]" unless $_[0] =~ m{^ ([A-Z0-9_:]+) (?:~)? (.*)}ix; my ($name, $version) = ($1, $2); $version =~ s/^\@/==/; # Allow "@" as a synonym for "==" @args = ( name => $name, version => trim_text($version) || 0 ); } return $class->$orig(@args); }; #------------------------------------------------------------------------------ sub BUILD { my $self = shift; # We want to construct the C::M::Requirements object right away to ensure # $self->version is a valid string. But if we do this in a builder, it # has to be lazy because it depends on other attributes. So instead, we # construct it during the BUILD and use a private writer to set it. my $args = {$self->name => $self->version}; my $req = try { CPAN::Meta::Requirements->from_string_hash( $args) } catch { throw "Invalid package target ($self): $_" }; $self->_set_vreq($req); return $self; } #------------------------------------------------------------------------------ sub is_core { my ( $self, %args ) = @_; ## no critic qw(PackageVar); # Note: $PERL_VERSION is broken on old perls, so we must make # our own version object from the old $] variable my $pv = version->parse( $args{in} ) || version->parse($]); # If it ain't in here, it ain't in the core my $core_modules = $Module::CoreList::version{ $pv->numify + 0 }; throw "Invalid perl version $pv" if not $core_modules; return 0 if not exists $core_modules->{ $self->name }; # We treat deprecated modules as if they have already been removed my $deprecated_modules = $Module::CoreList::deprecated{ $pv->numify + 0 }; return 0 if $deprecated_modules && exists $deprecated_modules->{ $self->name }; # on some perls, we'll get an 'uninitialized' warning when # the $core_version is undef. So force to zero in that case my $core_version = $core_modules->{ $self->name } || 0; return 1 if $self->is_satisfied_by( $core_version ); return 0; } #------------------------------------------------------------------------------- sub is_perl { my ($self) = @_; return $self->name eq 'perl'; } #------------------------------------------------------------------------------- sub is_satisfied_by { my ($self, $version) = @_; return $self->_vreq->accepts_module($self->name => $version); } #------------------------------------------------------------------------------- sub unversioned { my ($self) = @_; return (ref $self)->new(name => $self->name); } #------------------------------------------------------------------------------- sub to_string { my ($self) = @_; my $format = $self->version =~ m/^ [=<>!\@] /x ? '%s%s' : '%s~%s'; return sprintf $format, $self->name, $self->version; } #------------------------------------------------------------------------------ # XXX Are we using this? sub gte { my ($self, $other, $flip) = @_; return $self->is_satisfied_by($other) if not $flip; return $other->is_satisfied_by($self) if $flip; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Target::Package - Specifies a package by name and version =head1 VERSION version 0.14 =head1 METHODS =head2 is_core =head2 is_core(in => $version) Returns true if this Target is satisfied by the perl core as-of a particular version. If the version is not specified, it defaults to whatever version you are using now. =head2 is_perl() Returns true if this Target is a perl version of perl itself. =head2 is_satisfied_by($version) Returns true if this Target is satisfied by version C<$version> of the package. =head2 to_string() Serializes this Target to its string form. This method is called whenever the Target is evaluated in string context. =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Server/Responder/000755 000766 000024 00000000000 13141540305 017647 5ustar00jeffstaff000000 000000 Pinto-0.14/lib/Pinto/Server/Responder.pm000644 000766 000024 00000002755 13141540305 020216 0ustar00jeffstaff000000 000000 # ABSTRACT: Base class for responders package Pinto::Server::Responder; use Moose; use Carp; use Pinto::Types qw(Dir); #------------------------------------------------------------------------------- our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------- has request => ( is => 'ro', isa => 'Plack::Request', required => 1, ); has root => ( is => 'ro', isa => Dir, required => 1, ); #------------------------------------------------------------------------------- sub respond { croak 'abstract method' } #------------------------------------------------------------------------------- __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer responders =head1 NAME Pinto::Server::Responder - Base class for responders =head1 VERSION version 0.14 =head1 METHODS =head2 respond( $request ) Given a L, responds with the appropriate PSGI-compatible response. This is an abstract method. It is your job to implement it in a concrete subclass. =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Server/Router.pm000644 000766 000024 00000004770 13141540305 017534 0ustar00jeffstaff000000 000000 # ABSTRACT: Routes server requests package Pinto::Server::Router; use Moose; use Scalar::Util; use Plack::Request; use Router::Simple; #------------------------------------------------------------------------------- our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------- has route_handler => ( is => 'ro', isa => 'Router::Simple', default => sub { Router::Simple->new }, ); #------------------------------------------------------------------------------- sub BUILD { my ($self) = @_; my $r = $self->route_handler; $r->connect( '/action/{action}', { responder => 'Action' }, { method => 'POST' } ); $r->connect( '/*', { responder => 'File' }, { method => [ 'GET', 'HEAD' ] } ); return $self; } #------------------------------------------------------------------------------- sub route { my ( $self, $env, $root ) = @_; my $p = $self->route_handler->match($env) or return [ 404, [], ['Not Found'] ]; my $responder_class = 'Pinto::Server::Responder::' . $p->{responder}; Class::Load::load_class($responder_class); my $request = Plack::Request->new($env); my $responder = $responder_class->new( request => $request, root => $root ); # HACK: Plack-1.02 calls URI::Escape::uri_escape() with arguments # that inadvertently cause $_ to be compiled into a regex. This # will emit warning if $_ is undef, or may blow up if it contains # certain stuff. To avoid this, just make sure $_ is empty for # now. A patch has been sent to Miyagawa. local $_ = ''; return $responder->respond; } #------------------------------------------------------------------------------- __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer responder =head1 NAME Pinto::Server::Router - Routes server requests =head1 VERSION version 0.14 =head1 METHODS =head2 route( $env, $root ) Given the request environment and the path to the repository root, dispatches the request to the appropriate responder and returns the response. =for Pod::Coverage BUILD =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Server/Responder/Action.pm000644 000766 000024 00000013570 13141540305 021430 0ustar00jeffstaff000000 000000 # ABSTRACT: Responder for action requests package Pinto::Server::Responder::Action; use Moose; use Carp; use JSON; use IO::Pipe; use IO::Select; use Try::Tiny; use File::Temp; use File::Copy; use Proc::Fork; use Path::Class; use Proc::Terminator; use Plack::Response; use HTTP::Status qw(:constants); use Pinto; use Pinto::Result; use Pinto::Chrome::Net; use Pinto::Constants qw(:protocol); #------------------------------------------------------------------------------- our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------- extends qw(Pinto::Server::Responder); #------------------------------------------------------------------------------- sub respond { my ($self) = @_; my $error_response = $self->check_protocol_version; return $error_response if $error_response; # path_info always has a leading slash, e.g. /action/list my ( undef, undef, $action_name ) = split '/', $self->request->path_info; my %params = %{ $self->request->parameters }; # Copying my $chrome_args = $params{chrome} ? decode_json( $params{chrome} ) : {}; my $pinto_args = $params{pinto} ? decode_json( $params{pinto} ) : {}; my $action_args = $params{action} ? decode_json( $params{action} ) : {}; for my $upload_name ( $self->request->uploads->keys ) { my $upload = $self->request->uploads->{$upload_name}; my $basename = $upload->filename; my $localfile = file( $upload->path )->dir->file($basename); File::Copy::move( $upload->path, $localfile ); #TODO: autodie $action_args->{$upload_name} = $localfile; } my $response; my $pipe = IO::Pipe->new; run_fork { child { $self->child_proc( $pipe, $chrome_args, $pinto_args, $action_name, $action_args ) } parent { my $child_pid = shift; $response = $self->parent_proc( $pipe, $child_pid ) } error { croak "Failed to fork: $!" }; }; return $response; } #------------------------------------------------------------------------------- sub check_protocol_version { my ($self) = @_; # NB: Format derived from GitHub: https://developer.github.com/v3/media my $media_type_rx = qr{^ application / vnd [.] pinto [.] v(\d+) (?:[+] .+)? $}ix; my $accept = $self->request->header('Accept') || ''; my $version = $accept =~ $media_type_rx ? $1 : 0; return unless my $cmp = $version <=> $PINTO_PROTOCOL_VERSION; my $fmt = 'Your client is too %s for this server. You must upgrade %s.'; my ($age, $component) = $cmp > 0 ? qw(new pintod) : qw(old pinto); my $msg = sprintf $fmt, $age, $component; return [ HTTP_UNSUPPORTED_MEDIA_TYPE, [], [$msg] ]; } #------------------------------------------------------------------------------- sub child_proc { my ( $self, $pipe, $chrome_args, $pinto_args, $action_name, $action_args ) = @_; my $writer = $pipe->writer; $writer->autoflush; # I'm not sure why, but cleanup isn't happening when we get # a TERM signal from the parent process. I suspect it # has something to do with File::NFSLock messing with %SIG local $SIG{TERM} = sub { File::Temp::cleanup; die $@ }; ## no critic qw(PackageVar) local $Pinto::Globals::current_username = delete $pinto_args->{username}; local $Pinto::Globals::current_time_offset = delete $pinto_args->{time_offset}; ## use critic; $chrome_args->{stdout} = $writer; $chrome_args->{stderr} = $writer; my $chrome = Pinto::Chrome::Net->new($chrome_args); my $pinto = Pinto->new( chrome => $chrome, root => $self->root ); my $result = try { $pinto->run( ucfirst $action_name => %{$action_args} ) } catch { print {$writer} $_; Pinto::Result->new->failed }; print {$writer} $PINTO_PROTOCOL_STATUS_OK . "\n" if $result->was_successful; exit $result->was_successful ? 0 : 1; } #------------------------------------------------------------------------------- sub parent_proc { my ( $self, $pipe, $child_pid ) = @_; my $reader = $pipe->reader; my $select = IO::Select->new($reader); $reader->blocking(0); my $response = sub { my $responder = shift; my $headers = ['Content-Type' => 'text/plain']; my $writer = $responder->( [ HTTP_OK, $headers ] ); my $socket = $self->request->env->{'psgix.io'}; my $nullmsg = $PINTO_PROTOCOL_NULL_MESSAGE . "\n"; while (1) { my $input; if ( $select->can_read(1) ) { $input = <$reader>; # Will block until \n last if not defined $input; # We reached eof } my $ok = eval { local $SIG{ALRM} = sub { die "Write timed out" }; alarm(3); $writer->write( $input || $nullmsg ); 1; # Write succeeded }; alarm(0); unless ( $ok && ( !$socket || getpeername($socket) ) ) { proc_terminate( $child_pid, max_wait => 10 ); last; } } $writer->close if not $socket; # Hangs otherwise! waitpid $child_pid, 0; }; return $response; } #------------------------------------------------------------------------------- __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Server::Responder::Action - Responder for action requests =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Server/Responder/File.pm000644 000766 000024 00000006172 13141540305 021072 0ustar00jeffstaff000000 000000 # ABSTRACT: Responder for static files package Pinto::Server::Responder::File; use Moose; use Plack::Response; use Plack::MIME; use HTTP::Date (); #------------------------------------------------------------------------------- our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------- extends qw(Pinto::Server::Responder); #------------------------------------------------------------------------------- sub respond { my ($self) = @_; # e.g. /stack_name/modules/02packages.details.txt.gz my ( undef, @path_parts ) = split '/', $self->request->path_info; my $file = $self->root->file(@path_parts); return not_found($file) if not -f $file; return not_found($file) if index($file, '/../') > 0; my @stat = stat($file); my $modified_since = HTTP::Date::str2time( $self->request->env->{HTTP_IF_MODIFIED_SINCE} ); return [ 304, [], [] ] if $modified_since && $stat[9] <= $modified_since; my $response = Plack::Response->new; $response->content_type( Plack::MIME->mime_type($file) ); $response->content_length( $stat[7] ); $response->header( 'Last-Modified' => HTTP::Date::time2str( $stat[9] ) ); $response->header( 'Cache-Control' => 'no-cache' ) if $self->should_not_cache($file); $response->body( $file->openr ) unless $self->request->method eq "HEAD"; $response->status(200); return $response; } #------------------------------------------------------------------------------- #------------------------------------------------------------------------------- sub should_not_cache { my ( $self, $file ) = @_; # force caches to always revalidate the indices, i.e. # 01mailrc.txt.gz, 02packages.details.txt.gz, 03modlist.data.gz my $basename = $file->basename; return 1 if $basename eq '01mailrc.txt.gz'; return 1 if $basename eq '02packages.details.txt.gz'; return 1 if $basename eq '03modlist.data.gz'; return 0; } #------------------------------------------------------------------------------- sub not_found { my $file = shift; my $body = "File $file not found"; my $headers = [ 'Content-Type' => 'text/plain', 'Content-Length' => length($body) ]; return [ 404, $headers, [$body] ]; } #------------------------------------------------------------------------------- __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Server::Responder::File - Responder for static files =head1 VERSION version 0.14 =head1 METHODS =head2 should_not_cache($file) Returns true if the file should not be cached, and therefore the Cache-Control header should be set to 'no-cache' in the response. Currently, only the index files should not be cached. =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Schema/Result/000755 000766 000024 00000000000 13141540305 017116 5ustar00jeffstaff000000 000000 Pinto-0.14/lib/Pinto/Schema/ResultSet/000755 000766 000024 00000000000 13141540305 017572 5ustar00jeffstaff000000 000000 Pinto-0.14/lib/Pinto/Schema/ResultSet/Distribution.pm000644 000766 000024 00000002535 13141540305 022614 0ustar00jeffstaff000000 000000 # ABSTRACT: Common queries for Distributions use utf8; package Pinto::Schema::ResultSet::Distribution; use strict; use warnings; use base 'DBIx::Class::ResultSet'; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ sub with_packages { my ( $self, $where ) = @_; return $self->search( $where || {}, { prefetch => 'packages' } ); } #------------------------------------------------------------------------------ sub find_by_author_archive { my ( $self, $author, $archive ) = @_; my $where = { author => $author, archive => $archive }; my $attrs = { key => 'author_archive_unique' }; return $self->find( $where, $attrs ); } #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Schema::ResultSet::Distribution - Common queries for Distributions =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Schema/ResultSet/Package.pm000644 000766 000024 00000002032 13141540305 021460 0ustar00jeffstaff000000 000000 # ABSTRACT: Common queries for Packages use utf8; package Pinto::Schema::ResultSet::Package; use strict; use warnings; use base 'DBIx::Class::ResultSet'; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ sub with_distribution { my ( $self, $where ) = @_; return $self->search( $where || {}, { prefetch => 'distribution' } ); } #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Schema::ResultSet::Package - Common queries for Packages =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Schema/ResultSet/Registration.pm000644 000766 000024 00000003323 13141540305 022603 0ustar00jeffstaff000000 000000 # ABSTRACT: Common queries for Registrations use utf8; package Pinto::Schema::ResultSet::Registration; use strict; use warnings; use base 'DBIx::Class::ResultSet'; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ sub with_package { my ( $self, $where ) = @_; return $self->search( $where || {}, { prefetch => 'package' } ); } #------------------------------------------------------------------------------ sub with_distribution { my ( $self, $where ) = @_; return $self->search( $where || {}, { prefetch => 'distribution' } ); } #------------------------------------------------------------------------------ sub with_revision { my ( $self, $where ) = @_; return $self->search( $where || {}, { revision => 'distribution' } ); } #------------------------------------------------------------------------------ sub as_hash { my ( $self, $cb ) = @_; $cb ||= sub { return ( $_[0]->id => $_[0] ) }; my %hash = map { $cb->($_) } $self->all; return wantarray ? %hash : \%hash; } #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Schema::ResultSet::Registration - Common queries for Registrations =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Schema/Result/Ancestry.pm000644 000766 000024 00000005345 13141540305 021253 0ustar00jeffstaff000000 000000 use utf8; package Pinto::Schema::Result::Ancestry; # Created by DBIx::Class::Schema::Loader # DO NOT MODIFY THE FIRST PART OF THIS FILE use strict; use warnings; use Moose; use MooseX::NonMoose; use MooseX::MarkAsMethods autoclean => 1; extends 'DBIx::Class::Core'; __PACKAGE__->table("ancestry"); __PACKAGE__->add_columns( "id", { data_type => "integer", is_auto_increment => 1, is_nullable => 0 }, "parent", { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, "child", { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, ); __PACKAGE__->set_primary_key("id"); __PACKAGE__->belongs_to( "child", "Pinto::Schema::Result::Revision", { id => "child" }, { is_deferrable => 0, on_delete => "CASCADE", on_update => "NO ACTION" }, ); __PACKAGE__->belongs_to( "parent", "Pinto::Schema::Result::Revision", { id => "parent" }, { is_deferrable => 0, on_delete => "CASCADE", on_update => "NO ACTION" }, ); with 'Pinto::Role::Schema::Result'; # Created by DBIx::Class::Schema::Loader v0.07033 @ 2013-02-27 14:20:24 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:NAFcD1cZ00q/UhZ15CEYUg #------------------------------------------------------------------------------- # ABSTRACT: Represents the relationship between revisions #----------------------------------------------------------------------------- our $VERSION = '0.14'; # VERSION #----------------------------------------------------------------------------- __PACKAGE__->meta->make_immutable; #----------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Schema::Result::Ancestry - Represents the relationship between revisions =head1 VERSION version 0.14 =head1 NAME Pinto::Schema::Result::Ancestry =head1 TABLE: C =head1 ACCESSORS =head2 id data_type: 'integer' is_auto_increment: 1 is_nullable: 0 =head2 parent data_type: 'integer' is_foreign_key: 1 is_nullable: 0 =head2 child data_type: 'integer' is_foreign_key: 1 is_nullable: 0 =head1 PRIMARY KEY =over 4 =item * L =back =head1 RELATIONS =head2 child Type: belongs_to Related object: L =head2 parent Type: belongs_to Related object: L =head1 L ROLES APPLIED =over 4 =item * L =back =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Schema/Result/Distribution.pm000644 000766 000024 00000034365 13141540305 022146 0ustar00jeffstaff000000 000000 use utf8; package Pinto::Schema::Result::Distribution; # Created by DBIx::Class::Schema::Loader # DO NOT MODIFY THE FIRST PART OF THIS FILE use strict; use warnings; use Moose; use MooseX::NonMoose; use MooseX::MarkAsMethods autoclean => 1; extends 'DBIx::Class::Core'; __PACKAGE__->table("distribution"); __PACKAGE__->add_columns( "id", { data_type => "integer", is_auto_increment => 1, is_nullable => 0 }, "author", { data_type => "text", is_nullable => 0 }, "archive", { data_type => "text", is_nullable => 0 }, "source", { data_type => "text", is_nullable => 0 }, "mtime", { data_type => "integer", is_nullable => 0 }, "sha256", { data_type => "text", is_nullable => 0 }, "md5", { data_type => "text", is_nullable => 0 }, "metadata", { data_type => "text", is_nullable => 0 }, ); __PACKAGE__->set_primary_key("id"); __PACKAGE__->add_unique_constraint( "author_archive_unique", [ "author", "archive" ] ); __PACKAGE__->has_many( "packages", "Pinto::Schema::Result::Package", { "foreign.distribution" => "self.id" }, { cascade_copy => 0, cascade_delete => 0 }, ); __PACKAGE__->has_many( "prerequisites", "Pinto::Schema::Result::Prerequisite", { "foreign.distribution" => "self.id" }, { cascade_copy => 0, cascade_delete => 0 }, ); __PACKAGE__->has_many( "registrations", "Pinto::Schema::Result::Registration", { "foreign.distribution" => "self.id" }, { cascade_copy => 0, cascade_delete => 0 }, ); with 'Pinto::Role::Schema::Result'; # Created by DBIx::Class::Schema::Loader v0.07033 @ 2013-03-26 11:05:47 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:vQKIXXk8xddyMmBptwvpUg #------------------------------------------------------------------------------- # ABSTRACT: Represents a distribution archive #------------------------------------------------------------------------------- use URI; use CPAN::Meta; use Path::Class; use CPAN::DistnameInfo; use String::Format; use Pinto::Util qw(itis debug whine throw); use Pinto::Target::Distribution; use overload ( '""' => 'to_string', 'cmp' => 'string_compare' ); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ __PACKAGE__->inflate_column( 'metadata' => { inflate => sub { CPAN::Meta->load_json_string( $_[0] ) }, deflate => sub { $_[0]->as_string( { version => "2" } ) } } ); #------------------------------------------------------------------------------ sub FOREIGNBUILDARGS { my ( $class, $args ) = @_; $args ||= {}; $args->{source} ||= 'LOCAL'; return $args; } #------------------------------------------------------------------------------ sub register { my ( $self, %args ) = @_; my $stack = $args{stack}; my $force = $args{force} || 0; my $pin = $args{pin} || 0; my $can_intermingle = $stack->repo->config->intermingle; my $did_register = 0; $stack->assert_is_open; # TODO: This process makes a of trips to the database. You could # optimize this by fetching all the incumbents at once, checking # for pins, and then bulk-insert the new registrations. for my $pkg ($self->packages) { if (not $pkg->can_index) { my $file = $pkg->file || ''; debug( sub {"Package $pkg in file $file is not indexable. Skipping registration"} ); next; } my $where = {package_name => $pkg->name}; my $incumbent = $stack->head->find_related(registrations => $where); if (not defined $incumbent) { debug( sub {"Registering package $pkg on stack $stack"} ); $pkg->register(stack => $stack, pin => $pin); $did_register++; next; } elsif (not $can_intermingle) { # If the repository prohibits intermingled distributions, we can # assume all the apckages in the incumbent are already registered. my $dist = $incumbent->distribution; if ($dist->id == $self->id and $incumbent->is_pinned == $pin) { debug( sub {"Distribution $dist is already fully registered"} ); last; } } my $incumbent_pkg = $incumbent->package; if ( $incumbent_pkg == $pkg ) { debug( sub {"Package $pkg is already on stack $stack"} ); $incumbent->pin && $did_register++ if $pin and not $incumbent->is_pinned; next; } if ( $incumbent->is_pinned ) { my $pkg_name = $incumbent_pkg->name; my $dist = $incumbent->distribution; $force ? whine "Forcibly changing $dist to $self" : throw "Unable to register distribution $self: $pkg_name is pinned to $incumbent_pkg"; } whine "Downgrading package $incumbent_pkg to $pkg on stack $stack" if $incumbent_pkg > $pkg; if ( $can_intermingle ) { # If the repository allows intermingled distributions, then # remove only the incumbent package from the index. $incumbent->delete; } else { # Otherwise, remove all packages in the incumbent # distribution from the index. This is the default. $incumbent->distribution->unregister(stack => $stack, force => $force); } $pkg->register(stack => $stack, pin => $pin); $did_register++; } $stack->mark_as_changed if $did_register; return $did_register; } #------------------------------------------------------------------------------ sub unregister { my ( $self, %args ) = @_; my $stack = $args{stack}; my $force = $args{force}; my $did_unregister = 0; my $conflicts = 0; $stack->assert_is_open; $stack->assert_not_locked; my $rs = $self->registrations( { revision => $stack->head->id } ); for my $reg ( $rs->all ) { if ( $reg->is_pinned and not $force ) { my $pkg = $reg->package; whine "Cannot unregister package $pkg because it is pinned to stack $stack"; $conflicts++; next; } $did_unregister++; } throw "Unable to unregister distribution $self from stack $stack" if $conflicts; $rs->delete; $stack->mark_as_changed if $did_unregister; return $did_unregister; } #------------------------------------------------------------------------------ sub pin { my ( $self, %args ) = @_; my $stack = $args{stack}; $stack->assert_not_locked; my $rev = $stack->head; $rev->assert_is_open; my $where = { revision => $rev->id, is_pinned => 0 }; my $regs = $self->registrations($where); return 0 if not $regs->count; $regs->update( { is_pinned => 1 } ); $stack->mark_as_changed; return 1; } #------------------------------------------------------------------------------ sub unpin { my ( $self, %args ) = @_; my $stack = $args{stack}; $stack->assert_not_locked; my $rev = $stack->head; $rev->assert_is_open; my $where = { revision => $rev->id, is_pinned => 1 }; my $regs = $self->registrations($where); return 0 if not $regs->count; $regs->update( { is_pinned => 0 } ); $stack->mark_as_changed; return 1; } #------------------------------------------------------------------------------ has distname_info => ( isa => 'CPAN::DistnameInfo', init_arg => undef, handles => { name => 'dist', vname => 'distvname', version => 'version', maturity => 'maturity' }, default => sub { CPAN::DistnameInfo->new( $_[0]->path ) }, lazy => 1, ); #------------------------------------------------------------------------------ has is_devel => ( is => 'ro', isa => 'Bool', init_arg => undef, default => sub { $_[0]->maturity() eq 'developer' }, lazy => 1, ); #------------------------------------------------------------------------------ sub path { my ($self) = @_; return join '/', ( substr( $self->author, 0, 1 ), substr( $self->author, 0, 2 ), $self->author, $self->archive ); } #------------------------------------------------------------------------------ sub native_path { my ( $self, @base ) = @_; @base = ( $self->repo->config->authors_id_dir ) if not @base; return Path::Class::file( @base, substr( $self->author, 0, 1 ), substr( $self->author, 0, 2 ), $self->author, $self->archive ); } #------------------------------------------------------------------------------ sub uri { my ( $self, $base ) = @_; # TODO: Is there a sensible URI for local dists? return 'UNKNOWN' if $self->is_local; $base ||= $self->source; return URI->new( "$base/authors/id/" . $self->path )->canonical; } #------------------------------------------------------------------------------ sub is_local { my ($self) = @_; return $self->source eq 'LOCAL'; } #------------------------------------------------------------------------------ sub package { my ( $self, %args ) = @_; my $pkg_name = $args{name}; my $where = { name => $pkg_name }; my $attrs = { key => 'name_distribution_unique' }; my $pkg = $self->find_related( 'packages', $where, $attrs ) or return; if ( my $stk_name = $args{stack} ) { return $pkg->registration( stack => $stk_name ) ? $pkg : (); } return $pkg; } #------------------------------------------------------------------------------ sub registered_stacks { my ($self) = @_; my %stacks; for my $reg ( $self->registrations ) { # TODO: maybe use 'DISTICT' $stacks{ $reg->stack } = $reg->stack; } return values %stacks; } #------------------------------------------------------------------------------ sub main_module { my ($self) = @_; # We start by sorting packages by the length of their name. Most of # the time, the shorter one is more likely to be the main module name. my @pkgs = sort { length $a->name <=> length $b->name } $self->packages; # Transform the dist name into a package name my $dist_name = $self->name; $dist_name =~ s/-/::/g; # First, look for an indexable package that matches the dist name for my $pkg (@pkgs) { return $pkg if $pkg->can_index && $pkg->name eq $dist_name; } # Then, look for any indexable package for my $pkg (@pkgs) { return $pkg if $pkg->can_index; } # Then, just use the first package return $pkgs[0] if @pkgs; # There are no packages return undef; } #------------------------------------------------------------------------------ sub package_count { my ($self) = @_; return scalar $self->packages; } #------------------------------------------------------------------------------ sub prerequisite_specs { my ($self) = @_; return map { $_->as_target } $self->prerequisites; } #------------------------------------------------------------------------------ sub as_target { my ($self) = @_; return Pinto::Target::Distribution->new( path => $self->path ); } #------------------------------------------------------------------------------ sub string_compare { my ( $dist_a, $dist_b ) = @_; my $pkg = __PACKAGE__; throw "Can only compare $pkg objects" if not( itis( $dist_a, $pkg ) && itis( $dist_b, $pkg ) ); return 0 if $dist_a->id == $dist_b->id; my $r = ( $dist_a->archive cmp $dist_b->archive ); return $r; } #------------------------------------------------------------------------------ sub to_string { my ( $self, $format ) = @_; my %fspec = ( 'd' => sub { $self->name }, 'D' => sub { $self->vname }, 'V' => sub { $self->version }, 'm' => sub { $self->is_devel ? 'd' : 'r' }, 'M' => sub { my $m = $self->main_module; $m ? $m->name : '' }, 'h' => sub { $self->path }, 'H' => sub { $self->native_path }, 'f' => sub { $self->archive }, 's' => sub { $self->is_local ? 'l' : 'f' }, 'S' => sub { $self->source }, 'a' => sub { $self->author }, 'u' => sub { $self->uri }, 'c' => sub { $self->package_count }, ); $format ||= $self->default_format; return String::Format::stringf( $format, %fspec ); } #------------------------------------------------------------------------------- sub default_format { my ($self) = @_; return '%a/%f', # AUTHOR/Dist-Name-1.0.tar.gz } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Schema::Result::Distribution - Represents a distribution archive =head1 VERSION version 0.14 =head1 NAME Pinto::Schema::Result::Distribution =head1 TABLE: C =head1 ACCESSORS =head2 id data_type: 'integer' is_auto_increment: 1 is_nullable: 0 =head2 author data_type: 'text' is_nullable: 0 =head2 archive data_type: 'text' is_nullable: 0 =head2 source data_type: 'text' is_nullable: 0 =head2 mtime data_type: 'integer' is_nullable: 0 =head2 sha256 data_type: 'text' is_nullable: 0 =head2 md5 data_type: 'text' is_nullable: 0 =head2 metadata data_type: 'text' is_nullable: 0 =head1 PRIMARY KEY =over 4 =item * L =back =head1 UNIQUE CONSTRAINTS =head2 C =over 4 =item * L =item * L =back =head1 RELATIONS =head2 packages Type: has_many Related object: L =head2 prerequisites Type: has_many Related object: L =head2 registrations Type: has_many Related object: L =head1 L ROLES APPLIED =over 4 =item * L =back =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Schema/Result/Package.pm000644 000766 000024 00000024164 13141540305 021016 0ustar00jeffstaff000000 000000 use utf8; package Pinto::Schema::Result::Package; # Created by DBIx::Class::Schema::Loader # DO NOT MODIFY THE FIRST PART OF THIS FILE use strict; use warnings; use Moose; use MooseX::NonMoose; use MooseX::MarkAsMethods autoclean => 1; extends 'DBIx::Class::Core'; __PACKAGE__->table("package"); __PACKAGE__->add_columns( "id", { data_type => "integer", is_auto_increment => 1, is_nullable => 0 }, "name", { data_type => "text", is_nullable => 0 }, "version", { data_type => "text", is_nullable => 0 }, "file", { data_type => "text", default_value => \"null", is_nullable => 1 }, "sha256", { data_type => "text", default_value => \"null", is_nullable => 1 }, "distribution", { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, ); __PACKAGE__->set_primary_key("id"); __PACKAGE__->add_unique_constraint( "name_distribution_unique", [ "name", "distribution" ] ); __PACKAGE__->belongs_to( "distribution", "Pinto::Schema::Result::Distribution", { id => "distribution" }, { is_deferrable => 0, on_delete => "CASCADE", on_update => "NO ACTION" }, ); __PACKAGE__->has_many( "registrations", "Pinto::Schema::Result::Registration", { "foreign.package" => "self.id" }, { cascade_copy => 0, cascade_delete => 0 }, ); with 'Pinto::Role::Schema::Result'; # Created by DBIx::Class::Schema::Loader v0.07033 @ 2013-03-04 12:39:54 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:wYrDViIlHDocM5byRBn1Qg #------------------------------------------------------------------------------ # ABSTRACT: Represents a Package provided by a Distribution #------------------------------------------------------------------------------ use String::Format; use MooseX::Types::Moose qw(Bool); use Pinto::Target::Package; use Pinto::Util qw(itis throw); use overload ( '""' => 'to_string', '<=>' => 'numeric_compare', 'cmp' => 'string_compare', fallback => undef ); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ __PACKAGE__->inflate_column( 'version' => { inflate => sub { version->parse( $_[0] ) }, deflate => sub { $_[0]->stringify() }, } ); #------------------------------------------------------------------------------ # Schema::Loader does not create many-to-many relationships for us. So we # must create them by hand here... __PACKAGE__->many_to_many( revisions => 'registration', 'revision' ); #------------------------------------------------------------------------------ has is_main_module => ( is => 'ro', isa => Bool, init_arg => undef, default => sub { $_[0]->distribution->main_module->id eq $_[0]->id }, lazy => 1, ); #------------------------------------------------------------------------------ sub FOREIGNBUILDARGS { my ( $class, $args ) = @_; $args ||= {}; $args->{version} = 0 if not defined $args->{version}; # We're no longer storing the file path and sha digests of each package # because the paths in the META are often wrong anyway, and that would # cause Dist::Metadata to blow up. I had hoped this information would be # used to figure out which distribution a given file came from. But I've # decided that is out of scope for Pinto. Eventually, we'll remove # these from the schema entirely. $args->{file} ||= ''; $args->{sha256} ||= ''; return $args; } #------------------------------------------------------------------------------ sub register { my ( $self, %args ) = @_; my $stack = $args{stack}; my $pin = $args{pin}; my $struct = { revision => $stack->head->id, is_pinned => $pin, package_name => $self->name, distribution => $self->get_column('distribution') }; $self->create_related( registrations => $struct ); return $self; } #------------------------------------------------------------------------------ sub vname { my ($self) = @_; return $self->name . '~' . $self->version; } #------------------------------------------------------------------------------ sub as_target { my ($self) = @_; return Pinto::Target::Package->new( name => $self->name, version => $self->version ); } #------------------------------------------------------------------------------ sub is_simile { my($self) = @_; my $package = $self->name; my $file = $self->file; # Some older version of Pinto did not record the filename of each # package. In that case we must assume that it is a simile. return 1 if not $file; # The following code was taken from simile() in PAUSE/pmfile.pm # 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'; } return $ret; } #------------------------------------------------------------------------------ sub can_index { my ($self) = @_; # Workaround for Net::LibIDN (see GH #194) return 1 if $self->name eq 'Net::LibIDN' and $self->file eq '_LibIDN.pm'; # Workaround for FCGI return 1 if $self->name eq 'FCGI' and $self->file eq 'FCGI.PL'; return $self->is_simile; } #------------------------------------------------------------------------------ sub flags { my ($self) = @_; my $format = '%m%s?%x'; return $self->to_string($format); } #------------------------------------------------------------------------------ sub to_string { my ( $self, $format ) = @_; # my ($pkg, $file, $line) = caller; # warn __PACKAGE__ . " stringified from $file at line $line"; my %fspec = ( 'p' => sub { $self->name() }, 'P' => sub { $self->vname() }, 'x' => sub { $self->can_index ? 'x' : '-'}, 'M' => sub { $self->is_main_module ? 'm' : '-'}, 'v' => sub { $self->version->stringify() }, 'm' => sub { $self->distribution->is_devel() ? 'd' : 'r' }, 'h' => sub { $self->distribution->path() }, 'H' => sub { $self->distribution->native_path() }, 'f' => sub { $self->distribution->archive }, 's' => sub { $self->distribution->is_local() ? 'l' : 'f' }, 'S' => sub { $self->distribution->source() }, 'a' => sub { $self->distribution->author() }, 'd' => sub { $self->distribution->name() }, 'D' => sub { $self->distribution->vname() }, 'V' => sub { $self->distribution->version() }, 'u' => sub { $self->distribution->uri() }, 'F' => sub { $self->flags }, ); # Some attributes are just undefined, usually because of # oddly named distributions and other old stuff on CPAN. no warnings 'uninitialized'; ## no critic qw(NoWarnings); $format ||= $self->default_format(); return String::Format::stringf( $format, %fspec ); } #------------------------------------------------------------------------------- sub default_format { my ($self) = @_; return '%a/%D/%P'; # AUTHOR/DIST_VNAME/PKG_VNAME } #------------------------------------------------------------------------------- sub numeric_compare { my ( $pkg_a, $pkg_b ) = @_; my $pkg = __PACKAGE__; throw "Can only compare $pkg objects" if not( itis( $pkg_a, $pkg ) && itis( $pkg_b, $pkg ) ); return 0 if $pkg_a->id == $pkg_b->id; throw "Cannot compare packages with different names: $pkg_a <=> $pkg_b" if $pkg_a->name ne $pkg_b->name; my $r = ( $pkg_a->version <=> $pkg_b->version ) || ( $pkg_a->distribution->mtime <=> $pkg_b->distribution->mtime ); # No two non-identical packages can be considered equal! throw "Unable to determine ordering: $pkg_a <=> $pkg_b" if not $r; return $r; } #------------------------------------------------------------------------------- sub string_compare { my ( $pkg_a, $pkg_b ) = @_; my $pkg = __PACKAGE__; throw "Can only compare $pkg objects" if not( itis( $pkg_a, $pkg ) && itis( $pkg_b, $pkg ) ); return 0 if $pkg_a->id() == $pkg_b->id(); my $r = ( $pkg_a->name cmp $pkg_b->name ) || ( $pkg_a->version <=> $pkg_b->version ); return $r; } #------------------------------------------------------------------------------- __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Schema::Result::Package - Represents a Package provided by a Distribution =head1 VERSION version 0.14 =head1 NAME Pinto::Schema::Result::Package =head1 TABLE: C =head1 ACCESSORS =head2 id data_type: 'integer' is_auto_increment: 1 is_nullable: 0 =head2 name data_type: 'text' is_nullable: 0 =head2 version data_type: 'text' is_nullable: 0 =head2 file data_type: 'text' default_value: null is_nullable: 1 =head2 sha256 data_type: 'text' default_value: null is_nullable: 1 =head2 distribution data_type: 'integer' is_foreign_key: 1 is_nullable: 0 =head1 PRIMARY KEY =over 4 =item * L =back =head1 UNIQUE CONSTRAINTS =head2 C =over 4 =item * L =item * L =back =head1 RELATIONS =head2 distribution Type: belongs_to Related object: L =head2 registrations Type: has_many Related object: L =head1 L ROLES APPLIED =over 4 =item * L =back =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Schema/Result/Prerequisite.pm000644 000766 000024 00000010634 13141540305 022141 0ustar00jeffstaff000000 000000 use utf8; package Pinto::Schema::Result::Prerequisite; # Created by DBIx::Class::Schema::Loader # DO NOT MODIFY THE FIRST PART OF THIS FILE use strict; use warnings; use Moose; use MooseX::NonMoose; use MooseX::MarkAsMethods autoclean => 1; extends 'DBIx::Class::Core'; __PACKAGE__->table("prerequisite"); __PACKAGE__->add_columns( "id", { data_type => "integer", is_auto_increment => 1, is_nullable => 0 }, "phase", { data_type => "text", is_nullable => 0 }, "distribution", { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, "package_name", { data_type => "text", is_nullable => 0 }, "package_version", { data_type => "text", is_nullable => 0 }, ); __PACKAGE__->set_primary_key("id"); __PACKAGE__->add_unique_constraint( "distribution_phase_package_name_unique", [ "distribution", "phase", "package_name" ], ); __PACKAGE__->belongs_to( "distribution", "Pinto::Schema::Result::Distribution", { id => "distribution" }, { is_deferrable => 0, on_delete => "CASCADE", on_update => "NO ACTION" }, ); with 'Pinto::Role::Schema::Result'; # Created by DBIx::Class::Schema::Loader v0.07033 @ 2013-03-26 11:05:47 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:p++Wil511AYW5fZ8Xoe4Jg #------------------------------------------------------------------------------ # ABSTRACT: Represents a Distribution -> Package dependency #------------------------------------------------------------------------------ use Pinto::Target::Package; use overload ( '""' => 'to_string' ); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ # NOTE: We often convert a Prerequsite to/from a PackageSpec object. They don't # use quite the same names for their attributes, so we shuffle them around here. sub FOREIGNBUILDARGS { my ( $class, $args ) = @_; $args ||= {}; $args->{package_name} = delete $args->{name}; $args->{package_version} = delete $args->{version}; return $args; } #------------------------------------------------------------------------------ has as_target => ( is => 'ro', isa => 'Pinto::Target::Package', init_arg => undef, lazy => 1, handles => [qw(is_core is_perl)], default => sub { Pinto::Target::Package->new( name => $_[0]->package_name, version => $_[0]->package_version ); }, ); #------------------------------------------------------------------------------ sub to_string { my ($self) = @_; return $self->as_target->to_string; } #------------------------------------------------------------------------------ for my $phase ( qw(configure build test runtime develop) ) { no strict 'refs'; *{__PACKAGE__ . "::is_$phase"} = sub {shift->phase eq $phase}; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Schema::Result::Prerequisite - Represents a Distribution -> Package dependency =head1 VERSION version 0.14 =head1 NAME Pinto::Schema::Result::Prerequisite =head1 TABLE: C =head1 ACCESSORS =head2 id data_type: 'integer' is_auto_increment: 1 is_nullable: 0 =head2 phase data_type: 'text' is_nullable: 0 =head2 distribution data_type: 'integer' is_foreign_key: 1 is_nullable: 0 =head2 package_name data_type: 'text' is_nullable: 0 =head2 package_version data_type: 'text' is_nullable: 0 =head1 PRIMARY KEY =over 4 =item * L =back =head1 UNIQUE CONSTRAINTS =head2 C =over 4 =item * L =item * L =item * L =back =head1 RELATIONS =head2 distribution Type: belongs_to Related object: L =head1 L ROLES APPLIED =over 4 =item * L =back =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Schema/Result/Registration.pm000644 000766 000024 00000017216 13141540305 022135 0ustar00jeffstaff000000 000000 use utf8; package Pinto::Schema::Result::Registration; # Created by DBIx::Class::Schema::Loader # DO NOT MODIFY THE FIRST PART OF THIS FILE use strict; use warnings; use Moose; use MooseX::NonMoose; use MooseX::MarkAsMethods autoclean => 1; extends 'DBIx::Class::Core'; __PACKAGE__->table("registration"); __PACKAGE__->add_columns( "id", { data_type => "integer", is_auto_increment => 1, is_nullable => 0 }, "revision", { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, "package_name", { data_type => "text", is_nullable => 0 }, "package", { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, "distribution", { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, "is_pinned", { data_type => "boolean", is_nullable => 0 }, ); __PACKAGE__->set_primary_key("id"); __PACKAGE__->add_unique_constraint( "revision_package_name_unique", [ "revision", "package_name" ] ); __PACKAGE__->belongs_to( "distribution", "Pinto::Schema::Result::Distribution", { id => "distribution" }, { is_deferrable => 0, on_delete => "CASCADE", on_update => "NO ACTION" }, ); __PACKAGE__->belongs_to( "package", "Pinto::Schema::Result::Package", { id => "package" }, { is_deferrable => 0, on_delete => "CASCADE", on_update => "NO ACTION" }, ); __PACKAGE__->belongs_to( "revision", "Pinto::Schema::Result::Revision", { id => "revision" }, { is_deferrable => 0, on_delete => "CASCADE", on_update => "NO ACTION" }, ); with 'Pinto::Role::Schema::Result'; # Created by DBIx::Class::Schema::Loader v0.07033 @ 2013-03-04 12:39:54 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:AkBHZ7hQ0BdZdv0DoCJufA #------------------------------------------------------------------------------ # ABSTRACT: Represents the relationship between a Package and a Stack #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ use String::Format; use Pinto::Util qw(itis throw); use overload ( '""' => 'to_string', 'cmp' => 'string_compare', '<=>' => 'numeric_compare', fallback => undef ); #------------------------------------------------------------------------------- sub FOREIGNBUILDARGS { my ( $class, $args ) = @_; # Should we default these here or in the database? $args ||= {}; $args->{is_pinned} ||= 0; return $args; } #------------------------------------------------------------------------------- sub update { throw 'PANIC: Update to registrations are not allowed' } #------------------------------------------------------------------------------- sub pin { my ($self) = @_; throw "$self is already pinned" if $self->is_pinned; $self->delete; my $copy = $self->copy( { is_pinned => 1 } ); return $copy; } #------------------------------------------------------------------------------- sub unpin { my ($self) = @_; throw "$self is not pinned" if not $self->is_pinned; $self->delete; my $copy = $self->copy( { is_pinned => 0 } ); return $copy; } #------------------------------------------------------------------------------- sub numeric_compare { my ( $reg_a, $reg_b ) = @_; my $pkg = __PACKAGE__; throw "Can only compare $pkg objects" if not( itis( $reg_a, $pkg ) && itis( $reg_b, $pkg ) ); return 0 if $reg_a->id == $reg_b->id; return $reg_a->package <=> $reg_b->package; } #------------------------------------------------------------------------------ sub string_compare { my ( $reg_a, $reg_b ) = @_; my $class = __PACKAGE__; throw "Can only compare $class objects" if not( itis( $reg_a, $class ) && itis( $reg_b, $class ) ); return 0 if $reg_a->id == $reg_b->id; return ( $reg_a->package->distribution->author cmp $reg_b->package->distribution->author ) || ( $reg_a->package->distribution->vname cmp $reg_b->package->distribution->vname ) || ( $reg_a->package->vname cmp $reg_b->package->vname ); } #------------------------------------------------------------------------------ sub flags { my ($self) = @_; my $format = '%m%s%y'; return $self->to_string($format); } #------------------------------------------------------------------------------ sub to_string { my ( $self, $format ) = @_; # my ($pkg, $file, $line) = caller; # warn __PACKAGE__ . " stringified from $file at line $line"; my %fspec = ( p => sub { $self->package->name }, P => sub { $self->package->vname }, v => sub { $self->package->version }, M => sub { $self->package->is_main_module ? 'm' : '-'}, y => sub { $self->is_pinned ? '!' : '-' }, m => sub { $self->distribution->is_devel ? 'd' : 'r' }, h => sub { $self->distribution->path }, H => sub { $self->distribution->native_path }, f => sub { $self->distribution->archive }, s => sub { $self->distribution->is_local ? 'l' : 'f' }, S => sub { $self->distribution->source }, a => sub { $self->distribution->author }, d => sub { $self->distribution->name }, D => sub { $self->distribution->vname }, V => sub { $self->distribution->version }, u => sub { $self->distribution->uri }, i => sub { $self->revision->uuid_prefix }, F => sub { $self->flags }, ); # Some attributes are just undefined, usually because of # oddly named distributions and other old stuff on CPAN. no warnings 'uninitialized'; ## no critic qw(NoWarnings); $format ||= $self->default_format(); return String::Format::stringf( $format, %fspec ); } #------------------------------------------------------------------------------- sub default_format { return '%a/%D/%P/%y'; # AUTHOR/DIST_VNAME/PKG_VNAME/PIN_STATUS } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Schema::Result::Registration - Represents the relationship between a Package and a Stack =head1 VERSION version 0.14 =head1 NAME Pinto::Schema::Result::Registration =head1 TABLE: C =head1 ACCESSORS =head2 id data_type: 'integer' is_auto_increment: 1 is_nullable: 0 =head2 revision data_type: 'integer' is_foreign_key: 1 is_nullable: 0 =head2 package_name data_type: 'text' is_nullable: 0 =head2 package data_type: 'integer' is_foreign_key: 1 is_nullable: 0 =head2 distribution data_type: 'integer' is_foreign_key: 1 is_nullable: 0 =head2 is_pinned data_type: 'boolean' is_nullable: 0 =head1 PRIMARY KEY =over 4 =item * L =back =head1 UNIQUE CONSTRAINTS =head2 C =over 4 =item * L =item * L =back =head1 RELATIONS =head2 distribution Type: belongs_to Related object: L =head2 package Type: belongs_to Related object: L =head2 revision Type: belongs_to Related object: L =head1 L ROLES APPLIED =over 4 =item * L =back =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Schema/Result/Revision.pm000644 000766 000024 00000030404 13141540305 021253 0ustar00jeffstaff000000 000000 use utf8; package Pinto::Schema::Result::Revision; # Created by DBIx::Class::Schema::Loader # DO NOT MODIFY THE FIRST PART OF THIS FILE use strict; use warnings; use Moose; use MooseX::NonMoose; use MooseX::MarkAsMethods autoclean => 1; extends 'DBIx::Class::Core'; __PACKAGE__->table("revision"); __PACKAGE__->add_columns( "id", { data_type => "integer", is_auto_increment => 1, is_nullable => 0 }, "uuid", { data_type => "text", is_nullable => 0 }, "message", { data_type => "text", is_nullable => 0 }, "username", { data_type => "text", is_nullable => 0 }, "utc_time", { data_type => "integer", is_nullable => 0 }, "time_offset", { data_type => "integer", is_nullable => 0 }, "is_committed", { data_type => "boolean", is_nullable => 0 }, "has_changes", { data_type => "boolean", is_nullable => 0 }, ); __PACKAGE__->set_primary_key("id"); __PACKAGE__->add_unique_constraint( "uuid_unique", ["uuid"] ); __PACKAGE__->has_many( "ancestry_children", "Pinto::Schema::Result::Ancestry", { "foreign.child" => "self.id" }, { cascade_copy => 0, cascade_delete => 0 }, ); __PACKAGE__->has_many( "ancestry_parents", "Pinto::Schema::Result::Ancestry", { "foreign.parent" => "self.id" }, { cascade_copy => 0, cascade_delete => 0 }, ); __PACKAGE__->has_many( "registrations", "Pinto::Schema::Result::Registration", { "foreign.revision" => "self.id" }, { cascade_copy => 0, cascade_delete => 0 }, ); __PACKAGE__->has_many( "stacks", "Pinto::Schema::Result::Stack", { "foreign.head" => "self.id" }, { cascade_copy => 0, cascade_delete => 0 }, ); with 'Pinto::Role::Schema::Result'; # Created by DBIx::Class::Schema::Loader v0.07033 @ 2013-03-07 12:56:52 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:u3EeZBioyg8H9+azCHQYNA #------------------------------------------------------------------------------ # ABSTRACT: Represents a set of changes to a stack #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ use MooseX::Types::Moose qw(Str Bool); use DateTime; use DateTime::TimeZone; use DateTime::TimeZone::OffsetOnly; use String::Format; use Digest::SHA; use Pinto::Util qw(:all); use overload ( '""' => 'to_string', '<=>' => 'numeric_compare', 'cmp' => 'numeric_compare', 'eq' => 'equals' ); #------------------------------------------------------------------------------ has uuid_prefix => ( is => 'ro', isa => Str, default => sub { substr( $_[0]->uuid, 0, 8 ) }, init_arg => undef, lazy => 1, ); has message_title => ( is => 'ro', isa => Str, default => sub { trim_text( title_text( $_[0]->message ) ) }, init_arg => undef, lazy => 1, ); has message_body => ( is => 'ro', isa => Str, default => sub { trim_text( body_text( $_[0]->message ) ) }, init_arg => undef, lazy => 1, ); has is_root => ( is => 'ro', isa => Bool, default => sub { $_[0]->id == 1 }, init_arg => undef, lazy => 1, ); has datetime => ( is => 'ro', isa => 'DateTime', default => sub { DateTime->from_epoch( epoch => $_[0]->utc_time ) }, init_arg => undef, lazy => 1, ); has datetime_local => ( is => 'ro', isa => 'DateTime', default => sub { my $tz = DateTime::TimeZone->offset_as_string( $_[0]->repo->config->time_offset ); return DateTime->from_epoch( epoch => $_[0]->utc_time, time_zone => $tz ); }, init_arg => undef, lazy => 1, ); has datetime_user => ( is => 'ro', isa => 'DateTime', default => sub { DateTime->from_epoch( epoch => $_[0]->utc_time, time_zone => $_[0]->time_zone ) }, init_arg => undef, lazy => 1, ); has time_zone => ( is => 'ro', isa => 'DateTime::TimeZone', default => sub { my $offset = DateTime::TimeZone->offset_as_string( $_[0]->time_offset ); return DateTime::TimeZone::OffsetOnly->new( offset => $offset ); }, init_arg => undef, lazy => 1, ); #------------------------------------------------------------------------------ sub FOREIGNBUILDARGS { my ( $class, $args ) = @_; $args ||= {}; $args->{uuid} ||= uuid(); $args->{username} ||= ''; $args->{utc_time} ||= current_utc_time(); $args->{time_offset} ||= 0; $args->{is_committed} ||= 0; $args->{has_changes} ||= 0; $args->{message} ||= ''; return $args; } #------------------------------------------------------------------------------ sub add_parent { my ( $self, $parent ) = @_; # TODO: Figure out how to do merges $self->create_related( ancestry_children => { parent => $parent->id } ); return; } #------------------------------------------------------------------------------ sub add_child { my ( $self, $child ) = @_; # TODO: Figure out how to do merges $self->create_related( ancestry_parents => { child => $child->id } ); return; } #------------------------------------------------------------------------------ sub parents { my ($self) = @_; my $where = { child => $self->id }; my $attrs = { join => 'ancestry_parents', order_by => 'me.utc_time' }; return $self->result_source->resultset->search( $where, $attrs )->all; } #------------------------------------------------------------------------------ sub children { my ($self) = @_; my $where = { parent => $self->id }; my $attrs = { join => 'ancestry_children', order_by => 'me.utc_time' }; return $self->result_source->resultset->search( $where, $attrs )->all; } #------------------------------------------------------------------------------ sub is_ancestor_of { my ($self, $rev) = @_; my @ancestors = $rev->parents; while (my $ancestor = pop @ancestors) { return 1 if $ancestor->id == $self->id; push @ancestors, $ancestor->parents; } return 0; } #------------------------------------------------------------------------------ sub is_descendant_of { my ($self, $rev) = @_; my @descendants = $rev->children; while (my $descendant = pop @descendants) { return 1 if $descendant->id == $self->id; push @descendants, $descendant->children; } return 0; } #------------------------------------------------------------------------------ sub distributions { my ($self) = @_; my $rev_id = $self->id; my $subquery = "SELECT DISTINCT distribution FROM registration WHERE revision = $rev_id"; my $where = { 'me.id' => { in => \$subquery } }; my $attrs = { order_by => 'archive' }; return $self->result_source->schema->search_distribution( $where, $attrs ); } #------------------------------------------------------------------------------ sub packages { my ($self) = @_; my $rev_id = $self->id; my $subquery = "SELECT package FROM registration WHERE revision = $rev_id"; my $where = { 'me.id' => { in => \$subquery } }; my $attrs = { order_by => 'name' }; return $self->result_source->schema->search_package( $where, $attrs ); } #------------------------------------------------------------------------------ sub commit { my ( $self, %args ) = @_; throw "Must specify a message to commit" if not $args{message}; $args{is_committed} = 1; $args{has_changes} = 0; # XXX: Why reset this? $args{username} ||= $self->repo->config->username; $args{time_offset} ||= $self->repo->config->time_offset; $args{utc_time} ||= current_utc_time; $self->update( \%args ); return $self; } #------------------------------------------------------------------------------ sub assert_is_open { my ($self) = @_; # TODO: mark column dirty rather than refresh whole object. throw "PANIC: Revision $self is already committed" if $self->refresh->get_column('is_committed'); return $self; } #------------------------------------------------------------------------------- sub assert_is_committed { my ($self) = @_; # TODO: mark column dirty rather than refresh whole object. throw "PANIC: Revision $self is still open" if not $self->refresh->get_column('is_committed'); return $self; } #------------------------------------------------------------------------------- sub assert_has_changed { my ($self) = @_; # TODO: mark column dirty rather than refresh whole object. throw "PANIC: Revision $self has not changed" if not $self->refresh->get_column('has_changes'); return $self; } #------------------------------------------------------------------------------ sub diff { my ( $self, $other ) = @_; my $left = $other || ( $self->parents )[0]; my $right = $self; require Pinto::Difference; return Pinto::Difference->new( left => $left, right => $right ); } #------------------------------------------------------------------------------ sub numeric_compare { my ( $revision_a, $revision_b ) = @_; my $pkg = __PACKAGE__; throw "Can only compare $pkg objects" if not( itis( $revision_a, $pkg ) && itis( $revision_b, $pkg ) ); return 0 if $revision_a->id == $revision_b->id; my $r = ( $revision_a->utc_time <=> $revision_b->utc_time ); return $r; } #------------------------------------------------------------------------------ sub equals { my ( $revision_a, $revision_b ) = @_; my $pkg = __PACKAGE__; throw "Can only compare $pkg objects" if not( itis( $revision_a, $pkg ) && itis( $revision_b, $pkg ) ); return $revision_a->id == $revision_b->id; } #------------------------------------------------------------------------------ sub to_string { my ( $self, $format ) = @_; my %fspec = ( i => sub { $self->uuid_prefix }, I => sub { $self->uuid }, j => sub { $self->username }, u => sub { $self->datetime_local->strftime( $_[0] || '%c' ) }, g => sub { $self->message_body }, G => sub { indent_text( trim_text( $self->message ), $_[0] ) }, t => sub { $self->message_title }, T => sub { truncate_text( $self->message_title, $_[0] ) }, ); $format ||= $self->default_format; return String::Format::stringf( $format, %fspec ); } #------------------------------------------------------------------------------- sub default_format { my ($self) = @_; return '%i'; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Schema::Result::Revision - Represents a set of changes to a stack =head1 VERSION version 0.14 =head1 NAME Pinto::Schema::Result::Revision =head1 TABLE: C =head1 ACCESSORS =head2 id data_type: 'integer' is_auto_increment: 1 is_nullable: 0 =head2 uuid data_type: 'text' is_nullable: 0 =head2 message data_type: 'text' is_nullable: 0 =head2 username data_type: 'text' is_nullable: 0 =head2 utc_time data_type: 'integer' is_nullable: 0 =head2 time_offset data_type: 'integer' is_nullable: 0 =head2 is_committed data_type: 'boolean' is_nullable: 0 =head2 has_changes data_type: 'boolean' is_nullable: 0 =head1 PRIMARY KEY =over 4 =item * L =back =head1 UNIQUE CONSTRAINTS =head2 C =over 4 =item * L =back =head1 RELATIONS =head2 ancestry_children Type: has_many Related object: L =head2 ancestry_parents Type: has_many Related object: L =head2 registrations Type: has_many Related object: L =head2 stacks Type: has_many Related object: L =head1 L ROLES APPLIED =over 4 =item * L =back =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Schema/Result/Stack.pm000644 000766 000024 00000052063 13141540305 020527 0ustar00jeffstaff000000 000000 use utf8; package Pinto::Schema::Result::Stack; # Created by DBIx::Class::Schema::Loader # DO NOT MODIFY THE FIRST PART OF THIS FILE use strict; use warnings; use Moose; use MooseX::NonMoose; use MooseX::MarkAsMethods autoclean => 1; extends 'DBIx::Class::Core'; __PACKAGE__->table("stack"); __PACKAGE__->add_columns( "id", { data_type => "integer", is_auto_increment => 1, is_nullable => 0 }, "name", { data_type => "text", is_nullable => 0 }, "is_default", { data_type => "boolean", is_nullable => 0 }, "is_locked", { data_type => "boolean", is_nullable => 0 }, "properties", { data_type => "text", is_nullable => 0 }, "head", { data_type => "integer", is_foreign_key => 1, is_nullable => 0 }, ); __PACKAGE__->set_primary_key("id"); __PACKAGE__->add_unique_constraint( "name_unique", ["name"] ); __PACKAGE__->belongs_to( "head", "Pinto::Schema::Result::Revision", { id => "head" }, { is_deferrable => 0, on_delete => "RESTRICT", on_update => "NO ACTION" }, ); with 'Pinto::Role::Schema::Result'; # Created by DBIx::Class::Schema::Loader v0.07033 @ 2013-03-04 12:39:54 # DO NOT MODIFY THIS OR ANYTHING ABOVE! md5sum:+O/IwTdVRx98MHUkJ281lg #------------------------------------------------------------------------------- # ABSTRACT: Represents a named set of Packages #------------------------------------------------------------------------------- our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------- use MooseX::Types::Moose qw(Bool Str Undef); use String::Format; use File::Copy (); use JSON qw(encode_json decode_json); use Pinto::Util qw(:all); use Pinto::Types qw(Dir File Version); use version; use overload ( '""' => 'to_string', '<=>' => 'numeric_compare', 'cmp' => 'string_compare' ); #------------------------------------------------------------------------------ __PACKAGE__->inflate_column( 'properties' => { inflate => sub { decode_json( $_[0] || '{}' ) }, deflate => sub { encode_json( $_[0] || {} ) } } ); #------------------------------------------------------------------------------ has stack_dir => ( is => 'ro', isa => Dir, lazy => 1, default => sub { $_[0]->repo->config->stacks_dir->subdir( $_[0]->name ) }, ); has modules_dir => ( is => 'ro', isa => Dir, lazy => 1, default => sub { $_[0]->stack_dir->subdir('modules') }, ); has authors_dir => ( is => 'ro', isa => Dir, lazy => 1, default => sub { $_[0]->stack_dir->subdir('authors') }, ); has description => ( is => 'ro', isa => Str | Undef, lazy => 1, default => sub { $_[0]->get_property('description') }, init_arg => undef, ); has target_perl_version => ( is => 'ro', isa => Version, lazy => 1, default => sub { $_[0]->get_property('target_perl_version') or $_[0]->repo->config->target_perl_version; }, init_arg => undef, coerce => 1, ); #------------------------------------------------------------------------------ sub FOREIGNBUILDARGS { my ( $class, $args ) = @_; $args ||= {}; $args->{is_default} ||= 0; $args->{is_locked} ||= 0; $args->{properties} ||= '{}'; return $args; } #------------------------------------------------------------------------------ before is_default => sub { my ( $self, @args ) = @_; throw "Cannot directly set is_default. Use mark_as_default instead" if @args; }; #------------------------------------------------------------------------------ # TODO: All methods below that operate on the head should be moved into the # Revision class, since that is where the data actually is. For convenience, # the Stack class can have the same methods, but they should just delegate to # the Revision class. #------------------------------------------------------------------------------ sub get_distribution { my ( $self, %args ) = @_; my $cache = $args{cache}; my $target = $args{target} or throw 'Invalid arguments'; return $cache->{$target} if $cache && exists $cache->{$target}; my $dist; if ( itis( $target, 'Pinto::Target::Distribution' ) ) { my $attrs = { prefetch => 'distribution'}; my $where = {'distribution.author' => $target->author, 'distribution.archive' => $target->archive}; return unless my $reg = $self->head->search_related( registrations => $where, $attrs )->first; $dist = $reg->distribution; } elsif ( itis( $target, 'Pinto::Target::Package' ) ) { my $attrs = { prefetch => 'distribution' }; my $where = { package_name => $target->name }; return unless my $reg = $self->head->find_related( registrations => $where, $attrs ); return unless $target->is_satisfied_by($reg->package->version); $dist = $reg->distribution; } $cache->{$target} = $dist if $cache; return $dist; } #------------------------------------------------------------------------------ sub make_filesystem { my ($self) = @_; my $stack_dir = $self->stack_dir; debug "Making stack directory at $stack_dir"; $stack_dir->mkpath; my $stack_modules_dir = $self->modules_dir; debug "Making modules directory at $stack_modules_dir"; $stack_modules_dir->mkpath; my $stack_authors_dir = $self->authors_dir; my $shared_authors_dir = $self->repo->config->authors_dir->relative($stack_dir); mksymlink( $stack_authors_dir => $shared_authors_dir ); $self->write_modlist; return $self; } #------------------------------------------------------------------------------ sub rename_filesystem { my ( $self, %args ) = @_; my $new_name = $args{to}; $self->assert_not_locked; my $orig_dir = $self->stack_dir; throw "Directory $orig_dir does not exist" if not -e $orig_dir; my $new_dir = $self->repo->config->stacks_dir->subdir($new_name); throw "Directory $new_dir already exists" if -e $new_dir && (lc $new_dir ne lc $orig_dir); debug "Renaming directory $orig_dir to $new_dir"; File::Copy::move( $orig_dir, $new_dir ) or throw "Rename failed: $!"; return $self; } #------------------------------------------------------------------------------ sub kill_filesystem { my ($self) = @_; $self->assert_not_locked; my $stack_dir = $self->stack_dir; $stack_dir->rmtree or throw "Failed to remove $stack_dir: $!"; return $self; } #------------------------------------------------------------------------------ sub duplicate { my ( $self, %changes ) = @_; $changes{is_default} = 0; # Never duplicate the default flag return $self->copy( \%changes ); } #------------------------------------------------------------------------------ sub duplicate_registrations { my ( $self, %args ) = @_; my $new_rev = $args{to}; my $old_rev = $args{from} || $self->head; my $new_rev_id = $new_rev->id; my $old_rev_id = $old_rev->id; debug "Copying registrations for stack $self to $new_rev"; # This raw SQL is an optimization. I was using DBIC's HashReinflator # to fetch all the registrations, change the revision, and then reinsert # them as new records using populate(). But that was too slow if there # are lots of registrations. my $sql = qq{ INSERT INTO registration(revision, package, package_name, distribution, is_pinned) SELECT '$new_rev_id', package, package_name, distribution, is_pinned FROM registration WHERE revision = '$old_rev_id'; }; $self->result_source->storage->dbh->do($sql); return $self; } #------------------------------------------------------------------------------ sub rename { my ( $self, %args ) = @_; my $new_name = $args{to}; $self->assert_not_locked; $self->update( { name => $new_name } ); $self->refresh; # Causes moose attributes to be reinitialized $self->repo->link_modules_dir( to => $self->modules_dir ) if $self->is_default; return $self; } #------------------------------------------------------------------------------ sub kill { my ($self) = @_; $self->assert_not_locked; throw "Cannot kill the default stack" if $self->is_default; $self->delete; return $self; } #------------------------------------------------------------------------------ sub lock { my ($self) = @_; return $self if $self->is_locked; debug "Locking stack $self"; $self->update( { is_locked => 1 } ); return $self; } #------------------------------------------------------------------------------ sub unlock { my ($self) = @_; return $self if not $self->is_locked; debug "Unlocking stack $self"; $self->update( { is_locked => 0 } ); return $self; } #------------------------------------------------------------------------------ sub set_head { my ( $self, $revision ) = @_; debug sub {"Setting head of stack $self to revision $revision"}; $self->update( { head => $revision } ); return $self; } #------------------------------------------------------------------------------ sub start_revision { my ($self) = @_; debug "Starting revision on stack $self"; $self->assert_is_committed; my $old_head = $self->head; my $new_head = $self->result_source->schema->create_revision( {} ); $self->duplicate_registrations( to => $new_head ); $new_head->add_parent($old_head); $self->set_head($new_head); $self->assert_is_open; return $self; } #------------------------------------------------------------------------------ sub commit_revision { my ( $self, %args ) = @_; throw "Must specify a message to commit" if not( $args{message} or $self->head->message ); $self->assert_is_open; $self->assert_has_changed; $self->head->commit(%args); $self->write_index; $self->assert_is_committed; return $self; } #------------------------------------------------------------------------------- sub should_keep_history { my ($self) = @_; # Is this revision referenced by other stacks? return 1 if $self->head->stacks->count > 1; # Then do not keep history return 0; } #------------------------------------------------------------------------------- sub package_count { my ($self) = @_; return $self->head->registrations->count; } #------------------------------------------------------------------------------- sub distribution_count { my ($self) = @_; my $attrs = { select => 'distribution', distinct => 1 }; return $self->head->registrations( {}, $attrs )->count; } #------------------------------------------------------------------------------ sub assert_is_open { my ($self) = @_; return $self->head->assert_is_open; } #------------------------------------------------------------------------------ sub assert_is_committed { my ($self) = @_; return $self->head->assert_is_committed; } #------------------------------------------------------------------------------ sub assert_has_changed { my ($self) = @_; return $self->head->assert_has_changed; } #------------------------------------------------------------------------------ sub assert_not_locked { my ($self) = @_; throw "Stack $self is locked and cannot be modified or deleted" if $self->is_locked; return $self; } #------------------------------------------------------------------------------ sub set_description { my ( $self, $description ) = @_; $self->set_property( description => $description ); return $self; } #------------------------------------------------------------------------------ sub diff { my ( $self, $other ) = @_; my $left = $other || ( $self->head->parents )[0]; my $right = $self; require Pinto::Difference; return Pinto::Difference->new( left => $left, right => $right ); } #----------------------------------------------------------------------------- sub distributions { my ($self) = @_; return $self->head->distributions; } #----------------------------------------------------------------------------- sub packages { my ($self) = @_; return $self->head->packages; } #----------------------------------------------------------------------------- sub roots { my ($self) = @_; my @dists = $self->distributions->all; my $tpv = $self->target_perl_version; my %is_prereq_dist; my %cache; # Algorithm: Visit each distribution and resolve each of its # dependencies to the prerequisite distribution (if it exists). # Any distribution that is a prerequisite cannot be a root. for my $dist ( @dists ) { for my $prereq ($dist->prerequisites) { # TODO: When we support suggested/recommended prereqs # those will have to be skipped too. See here for more # discussion: https://github.com/thaljef/Pinto/issues/158 next if $prereq->is_test or $prereq->is_develop; next if $prereq->is_core(in => $tpv) or $prereq->is_perl; my %args = (target => $prereq->as_target, cache => \%cache); next unless my $prereq_dist = $self->get_distribution(%args); $is_prereq_dist{$prereq_dist} = 1; } } return grep { not $is_prereq_dist{$_} } @dists; } #----------------------------------------------------------------------------- sub mark_as_default { my ($self) = @_; return $self if $self->is_default; debug 'Marking all stacks as non-default'; my $rs = $self->result_source->resultset->search; $rs->update_all( { is_default => 0 } ); debug "Marking stack $self as default"; $self->update( { is_default => 1 } ); $self->repo->link_modules_dir( to => $self->modules_dir ); return 1; } #------------------------------------------------------------------------------ sub unmark_as_default { my ($self) = @_; return $self if not $self->is_default; debug "Unmarking stack $self as default"; $self->update( { is_default => 0 } ); $self->repo->unlink_modules_dir; return 1; } #------------------------------------------------------------------------------ sub mark_as_changed { my ($self) = @_; debug "Marking stack $self as changed"; $self->head->update( { has_changes => 1 } ); return $self; } #------------------------------------------------------------------------------ sub has_changed { my ($self) = @_; return $self->head->refresh->has_changes; } #------------------------------------------------------------------------------ sub has_not_changed { my ($self) = @_; return !$self->has_changed; } #------------------------------------------------------------------------------ sub write_index { my ($self) = @_; require Pinto::IndexWriter; my $writer = Pinto::IndexWriter->new( stack => $self ); $writer->write_index; return $self; } #------------------------------------------------------------------------------ sub write_modlist { my ($self) = @_; require Pinto::ModlistWriter; my $writer = Pinto::ModlistWriter->new( stack => $self ); $writer->write_modlist; return $self; } #------------------------------------------------------------------------------ sub get_property { my ( $self, @prop_keys ) = @_; my %props = %{ $self->get_properties }; return @props{ map {lc} @prop_keys }; } #------------------------------------------------------------------------------- sub get_properties { my ($self) = @_; my %props = %{ $self->properties }; # Making a copy! return \%props; } #------------------------------------------------------------------------------- sub set_property { my ( $self, $key, $value ) = @_; $self->set_properties( { $key => "$value" } ); return $self; } #------------------------------------------------------------------------------- sub set_properties { my ( $self, $new_props ) = @_; my $props = $self->properties; while ( my ( $key, $value ) = each %{$new_props} ) { Pinto::Util::validate_property_name($key); if ( defined $value && length "$value" ) { $props->{ lc $key } = "$value"; } else { delete $props->{ lc $key }; } } $self->update( { properties => $props } ); return $self; } #------------------------------------------------------------------------------- sub delete_property { my ( $self, @prop_keys ) = @_; my $props = $self->properties; delete $props->{ lc $_ } for @prop_keys; $self->update( { properties => $props } ); return $self; } #------------------------------------------------------------------------------- sub delete_properties { my ($self) = @_; self->update( { properties => {} } ); return $self; } #------------------------------------------------------------------------------- sub default_properties { my ($self) = @_; my $desc = sprintf( 'The %s stack', $self->name ); my $tpv = $self->repo->config->target_perl_version->stringify; return { description => $desc, target_perl_version => $tpv }; } #----------------------------------------------------------------------------- sub numeric_compare { my ( $stack_a, $stack_b ) = @_; my $pkg = __PACKAGE__; throw "Can only compare $pkg objects" if not( itis( $stack_a, $pkg ) && itis( $stack_b, $pkg ) ); return 0 if $stack_a->id == $stack_b->id; my $r = ( $stack_a->head <=> $stack_b->head ); return $r; } #----------------------------------------------------------------------------- sub string_compare { my ( $stack_a, $stack_b ) = @_; my $pkg = __PACKAGE__; throw "Can only compare $pkg objects" if not( itis( $stack_a, $pkg ) && itis( $stack_b, $pkg ) ); return 0 if $stack_a->id == $stack_b->id; my $r = ( $stack_a->name cmp $stack_b->name ); return $r; } #------------------------------------------------------------------------------ sub to_string { my ( $self, $format ) = @_; my %fspec = ( k => sub { $self->name }, M => sub { $self->is_default ? '*' : ' ' }, L => sub { $self->is_locked ? '!' : ' ' }, I => sub { $self->head->uuid }, i => sub { $self->head->uuid_prefix }, g => sub { $self->head->message }, G => sub { indent_text( trim_text( $self->head->message ), $_[0] ) }, t => sub { $self->head->message_title }, T => sub { truncate_text( $self->head->message_title, $_[0] ) }, b => sub { $self->head->message_body }, j => sub { $self->head->username }, u => sub { $self->head->datetime_local->strftime( $_[0] || '%c' ) }, ); $format ||= $self->default_format(); return String::Format::stringf( $format, %fspec ); } #------------------------------------------------------------------------------- sub default_format { my ($self) = @_; return '%k'; } #------------------------------------------------------------------------------- __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Schema::Result::Stack - Represents a named set of Packages =head1 VERSION version 0.14 =head1 METHODS =head2 get_distribution( target => $target ) Given a L, returns the L which contains the package with the same name as the target B. Returns nothing if no such distribution is found in this stack. Given a L, returns the L from this stack with the same author id and archive attributes as the target. Returns nothing if no such distribution is found in this stack. You can also pass a C argument that must be a reference to a hash. It will be used to cache results so that repeated calls to C require fewer trips to the database. It is up to you to decide when to expire the cache. =head1 NAME Pinto::Schema::Result::Stack =head1 TABLE: C =head1 ACCESSORS =head2 id data_type: 'integer' is_auto_increment: 1 is_nullable: 0 =head2 name data_type: 'text' is_nullable: 0 =head2 is_default data_type: 'boolean' is_nullable: 0 =head2 is_locked data_type: 'boolean' is_nullable: 0 =head2 properties data_type: 'text' is_nullable: 0 =head2 head data_type: 'integer' is_foreign_key: 1 is_nullable: 0 =head1 PRIMARY KEY =over 4 =item * L =back =head1 UNIQUE CONSTRAINTS =head2 C =over 4 =item * L =back =head1 RELATIONS =head2 head Type: belongs_to Related object: L =head1 L ROLES APPLIED =over 4 =item * L =back =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Role/Committable.pm000644 000766 000024 00000014147 13141540305 020146 0ustar00jeffstaff000000 000000 # ABSTRACT: Role for actions that commit changes to the repository package Pinto::Role::Committable; use Moose::Role; use MooseX::Types::Moose qw(Bool Str ArrayRef); use MooseX::MarkAsMethods ( autoclean => 1 ); use Try::Tiny; use List::MoreUtils qw(uniq); use Pinto::Constants qw(:lock); use Pinto::Types qw(StackName StackDefault StackObject DiffStyle); use Pinto::Util qw(is_interactive throw is_blank is_not_blank); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ with qw(Pinto::Role::Plated); #------------------------------------------------------------------------------ has stack => ( is => 'ro', isa => StackName | StackDefault | StackObject, writer => '_set_stack', default => undef, ); has dry_run => ( is => 'ro', isa => Bool, default => 0, ); has message => ( is => 'ro', isa => Str, predicate => 'has_message', ); has use_default_message => ( is => 'ro', isa => Bool, default => 0, ); has diff_style => ( is => 'ro', isa => DiffStyle, predicate => 'has_diff_style', ); has lock_type => ( is => 'ro', isa => Str, default => $PINTO_LOCK_TYPE_EXCLUSIVE, init_arg => undef, ); has affected => ( is => 'ro', isa => ArrayRef, default => sub { [] }, init_arg => undef, ); #------------------------------------------------------------------------------ requires qw( execute repo ); #------------------------------------------------------------------------------ around BUILD => sub { my ( $orig, $self ) = @_; # Inflate the stack into a real object. As a side # effect, this also verifies that the stack exists. my $stack = $self->repo->get_stack( $self->stack ); $self->_set_stack($stack); # Make sure we aren't locked if we intend to commit $self->stack->assert_not_locked unless $self->dry_run; return $self->$orig; }; #------------------------------------------------------------------------------ around execute => sub { my ( $orig, $self, @args ) = @_; try { $self->repo->txn_begin; $self->before_execute; $self->$orig(@args); $self->after_execute; } catch { $self->repo->txn_rollback; $self->repo->clean_files; throw $_; }; return $self->result; }; #------------------------------------------------------------------------------ sub before_execute { my ($self) = @_; $self->stack->start_revision; return $self; } #------------------------------------------------------------------------------ sub after_execute { my ($self, @dists) = @_; local $ENV{PINTO_DIFF_STYLE} = $self->diff_style if $self->has_diff_style; my $stack = $self->stack; if ( $self->dry_run ) { $stack->refresh->has_changed ? $self->show($stack->diff, {no_newline => 1}) : $self->notice('No changes were made'); $self->repo->txn_rollback; $self->repo->clean_files; } elsif ( $stack->refresh->has_not_changed ) { $self->diag('No changes were made'); $self->repo->txn_rollback; } else { my $msg = $self->compose_message; $stack->commit_revision( message => $msg ); $self->result->changed; $self->repo->txn_commit; } # Release the exclusive lock and just use a shared lock, since # we won't be writing to the repository at this point. $self->repo->unlock; $self->repo->lock($PINTO_LOCK_TYPE_SHARED); return $self; } #------------------------------------------------------------------------------ sub compose_message { my ($self) = @_; my $stack = $self->stack; my $title = $self->generate_message_title; return $self->message if $self->has_message and is_not_blank( $self->message ); return $title if $self->has_message and is_blank( $self->message ); return $title if $self->use_default_message; return $title if not is_interactive; my $template = $self->generate_message_template($title); my $message = $self->chrome->edit( $template ); $message =~ s/^ [#] .* $//gmsx; # Strip comments throw 'Aborting due to empty commit message' if is_blank($message); return $message; } #------------------------------------------------------------------------------ sub generate_message_title { my ( $self, $extra ) = @_; my $class = ref $self; my ($action) = $class =~ m/ ( [^:]* ) $/x; my @dists = uniq( sort @{$self->affected} ); my $title = "$action " . join( ', ', @dists ) . ( $extra ? " $extra" : '' ); return $title; } #------------------------------------------------------------------------------ sub generate_message_template { my ( $self, $title ) = @_; my $stack = $self->stack; my $diff = $stack->diff; # Prepend "#" to each line of the diff, # so they are treated as comments. $diff =~ s/^/# /gm; my $msg = <<"END_MESSAGE"; $title #------------------------------------------------------------------------------- # Please edit or amend the message above as you see fit. The first line of the # message will be used as the title. Any line that starts with a "#" will be # ignored. To abort the commit, delete the entire message above, save the file, # and close the editor. # # Changes to be committed to stack $stack: # $diff END_MESSAGE chomp $msg; return $msg; } #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Role::Committable - Role for actions that commit changes to the repository =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Role/Installer.pm000644 000766 000024 00000006622 13141540305 017642 0ustar00jeffstaff000000 000000 # ABSTRACT: Something that installs packages package Pinto::Role::Installer; use Moose::Role; use MooseX::Types::Moose qw(Str HashRef Maybe); use MooseX::MarkAsMethods ( autoclean => 1 ); use Path::Class qw(dir); use File::Which qw(which); use Pinto::Util qw(throw mask_uri_passwords); use Pinto::Constants qw($PINTO_MINIMUM_CPANM_VERSION); #----------------------------------------------------------------------------- our $VERSION = '0.14'; # VERSION #----------------------------------------------------------------------------- has cpanm_options => ( is => 'ro', isa => HashRef [ Maybe [Str] ], default => sub { {} }, lazy => 1, ); has cpanm_exe => ( is => 'ro', isa => Str, builder => '_build_cpanm_exe', lazy => 1, ); #----------------------------------------------------------------------------- requires qw( execute targets mirror_uri ); #----------------------------------------------------------------------------- with qw( Pinto::Role::Plated ); #----------------------------------------------------------------------------- sub _build_cpanm_exe { my ($self) = @_; return dir( $ENV{PINTO_HOME} )->subdir('sbin')->file('cpanm')->stringify if $ENV{PINTO_HOME}; my $cpanm_exe = which('cpanm') or throw 'Could not find cpanm in PATH'; my $cpanm_version_cmd = "$cpanm_exe --version"; my $cpanm_version_cmd_output = qx{$cpanm_version_cmd}; ## no critic qw(Backtick) throw "Could not learn version of cpanm: $!" if $?; my ($cpanm_version) = $cpanm_version_cmd_output =~ m{version ([\d.]+)} or throw "Could not parse cpanm version number from $cpanm_version_cmd_output"; if ( $cpanm_version < $PINTO_MINIMUM_CPANM_VERSION ) { throw "Your cpanm ($cpanm_version) is too old. Must have $PINTO_MINIMUM_CPANM_VERSION or newer"; } return $cpanm_exe; } #----------------------------------------------------------------------------- after execute => sub { my ($self) = @_; # Wire cpanm to our repo my $opts = $self->cpanm_options; $opts->{mirror} = $self->mirror_uri; $opts->{'mirror-only'} = ''; # Process other cpanm options my @cpanm_opts; for my $opt ( keys %{$opts} ) { my $dashes = ( length $opt == 1 ) ? '-' : '--'; my $dashed_opt = $dashes . $opt; my $opt_value = $opts->{$opt}; push @cpanm_opts, $dashed_opt; push @cpanm_opts, $opt_value if defined $opt_value && length $opt_value; } # Scrub passwords from the command so they don't appear in the logs my @sanitized_cpanm_opts = map { mask_uri_passwords($_) } @cpanm_opts; $self->info( join ' ', 'Running:', $self->cpanm_exe, @sanitized_cpanm_opts ); # Run cpanm 0 == system( $self->cpanm_exe, @cpanm_opts, $self->targets ) or throw "Installation failed. See the cpanm build log for details"; }; #----------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Role::Installer - Something that installs packages =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Role/PauseConfig.pm000644 000766 000024 00000004540 13141540305 020105 0ustar00jeffstaff000000 000000 # ABSTRACT: Something that has a pause config attribute package Pinto::Role::PauseConfig; use Moose::Role; use MooseX::Types::Moose qw(HashRef); use Pinto::Globals; use Pinto::Types qw(File); use Pinto::Util qw(current_author_id); use Path::Class; use File::HomeDir; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ has pauserc => ( is => 'ro', isa => File, lazy => 1, coerce => 1, builder => '_build_pauserc', ); #------------------------------------------------------------------------------ has pausecfg => ( is => 'ro', isa => HashRef, lazy => 1, init_arg => undef, builder => '_build_pausecfg', ); #------------------------------------------------------------------------------ sub _build_pauserc { my ($self) = @_; return file( File::HomeDir->my_home, '.pause' ); } #------------------------------------------------------------------------------ sub _build_pausecfg { my ($self) = @_; my $cfg = {}; return $cfg if $Pinto::Globals::current_author_id; return $cfg if not -e $self->pauserc(); my $fh = $self->pauserc->openr(); # basically taken from the parsing code used by cpan-upload # (maybe this should be part of the CPAN::Uploader api?) while (<$fh>) { next if /^ \s* (?: [#].*)? $/x; my ( $k, $v ) = /^ \s* (\w+) \s+ (.+?) \s* $/x; next unless $k; $cfg->{$k} = $v; } return $cfg; } #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer pauserc pausecfg =head1 NAME Pinto::Role::PauseConfig - Something that has a pause config attribute =head1 VERSION version 0.14 =head1 ATTRIBUTES =head2 pauserc The path to your PAUSE config file. By default, this is F<~/.pause>. =head1 METHODS =head2 pausecfg Returns a hashref representing the data of the PAUSE config file. =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Role/Plated.pm000644 000766 000024 00000002021 13141540305 017103 0ustar00jeffstaff000000 000000 # ABSTRACT: Something that has chrome plating package Pinto::Role::Plated; use Moose::Role; use MooseX::MarkAsMethods ( autoclean => 1 ); #----------------------------------------------------------------------------- our $VERSION = '0.14'; # VERSION #----------------------------------------------------------------------------- has chrome => ( is => 'ro', isa => 'Pinto::Chrome', handles => [qw(show diag info notice warning error)], required => 1, ); #----------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Role::Plated - Something that has chrome plating =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Role/Puller.pm000644 000766 000024 00000014141 13141540305 017143 0ustar00jeffstaff000000 000000 # ABSTRACT: Something pulls packages to a stack package Pinto::Role::Puller; use Moose::Role; use MooseX::Types::Moose qw(ArrayRef Bool Str); use MooseX::MarkAsMethods ( autoclean => 1 ); use List::MoreUtils qw(any); use Pinto::Util qw(throw whine); #----------------------------------------------------------------------------- our $VERSION = '0.14'; # VERSION #----------------------------------------------------------------------------- with qw( Pinto::Role::Plated ); #----------------------------------------------------------------------------- has recurse => ( is => 'ro', isa => Bool, default => sub { shift->stack->repo->config->recurse }, lazy => 1, ); has cascade => ( is => 'ro', isa => Bool, default => 0, ); has pin => ( is => 'ro', isa => Bool, default => 0, ); has force => ( is => 'ro', isa => Bool, default => 0, ); has skip_missing_prerequisite => ( is => 'ro', isa => ArrayRef[Str], default => sub { [] }, ); has skip_all_missing_prerequisites => ( is => 'ro', isa => Bool, default => 0, ); has with_development_prerequisites => ( is => 'ro', isa => Bool, default => 0, ); #----------------------------------------------------------------------------- # We should require a stack() attribute here, but Moose can't properly # resolve attributes that are composed from other roles. For more info # see https://rt.cpan.org/Public/Bug/Display.html?id=46347 # requires qw(stack); #----------------------------------------------------------------------------- sub pull { my ( $self, %args ) = @_; my $target = $args{target}; my $stack = $self->stack; my $did_register = 0; my $did_register_prereqs = 0; my $dist; if ( $target->isa('Pinto::Schema::Result::Distribution') ) { $dist = $target; } elsif ( $target->isa('Pinto::Target::Distribution') ) { $dist = $self->find( target => $target ); } elsif ( $target->isa('Pinto::Target::Package') ) { my $tpv = $stack->target_perl_version; if ( $target->is_core( in => $tpv ) ) { $self->warning("Skipping $target: included in perl $tpv core"); return (undef, 0, 0); # Nothing was pulled } $dist = $self->find( target => $target ); } else { throw "Illeagal arguments"; } $did_register = $dist->register( stack => $stack, pin => $self->pin, force => $self->force ); $did_register_prereqs = $self->do_recursion( start => $dist ) if $self->recurse; return ($dist, $did_register, $did_register_prereqs); } #----------------------------------------------------------------------------- sub find { my ( $self, %args ) = @_; my $target = $args{target}; my $stack = $self->stack; my $dist; my $msg; if ( $dist = $stack->get_distribution( target => $target ) ) { $msg = "Found $target on stack $stack in $dist"; } elsif ( $dist = $stack->repo->get_distribution( target => $target ) ) { $msg = "Found $target in $dist"; } elsif ( $dist = $stack->repo->ups_distribution( target => $target, cascade => $self->cascade ) ) { $msg = "Found $target in " . $dist->source; } elsif ( $self->should_skip_missing_prerequisite($target) ) { whine "Cannot find $target anywhere. Skipping it"; return; } else { throw "Cannot find $target anywhere"; } $self->chrome->show_progress; $self->info($msg) if defined $msg; return $dist; } #----------------------------------------------------------------------------- sub do_recursion { my ( $self, %args ) = @_; my $dist = $args{start}; my $stack = $self->stack; my %last_seen; my $did_register = 0; my $cb = sub { my ($prereq) = @_; my $target = $prereq->as_target; my $pkg_name = $target->name; my $pkg_vers = $target->version; # version sees undef and 0 as equal, so must also check definedness # when deciding if we've seen this version (or newer) of the package return if defined( $last_seen{$pkg_name} ) && $target->is_satisfied_by( $last_seen{$pkg_name} ); return if not my $dist = $self->find( target => $target ); $did_register += $dist->register( stack => $stack, force => $self->force); # Record the most recent version of the packages that has # been registered, so we don't need to find it again. $last_seen{$_->name} = $_->version for $dist->packages; return $dist; }; # Exclude perl itself, and prereqs that are satisfied by the core my @filters = ( sub { $_[0]->is_perl || $_[0]->is_core( in => $stack->target_perl_version ) } ); # Exlucde develop-time dependencies, unless asked not to push @filters, sub { $_[0]->phase eq 'develop' } unless $self->with_development_prerequisites; require Pinto::PrerequisiteWalker; my $walker = Pinto::PrerequisiteWalker->new( start => $dist, callback => $cb, filters => \@filters ); $self->notice("Descending into prerequisites for $dist"); while ( $walker->next ) { }; # Just want the callback side effects return $did_register; } #----------------------------------------------------------------------------- sub should_skip_missing_prerequisite { my ($self, $target) = @_; return 1 if $self->skip_all_missing_prerequisites; return 0 unless my @skips = @{ $self->skip_missing_prerequisite }; return 1 if any { $target->name eq $_ } @skips; return 0; } #----------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Role::Puller - Something pulls packages to a stack =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Role/Schema/000755 000766 000024 00000000000 13141540305 016541 5ustar00jeffstaff000000 000000 Pinto-0.14/lib/Pinto/Role/Transactional.pm000644 000766 000024 00000002456 13141540305 020510 0ustar00jeffstaff000000 000000 # ABSTRACT: Role for actions that are transactional package Pinto::Role::Transactional; use Moose::Role; use MooseX::MarkAsMethods ( autoclean => 1 ); use Try::Tiny; use Pinto::Util qw(throw); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ requires qw( execute repo ); #------------------------------------------------------------------------------ around execute => sub { my ( $orig, $self, @args ) = @_; $self->repo->txn_begin; my $result = try { $self->$orig(@args); $self->repo->txn_commit } catch { $self->repo->txn_rollback; throw $_ }; return $self->result; }; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Role::Transactional - Role for actions that are transactional =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Role/UserAgent.pm000644 000766 000024 00000006401 13141540305 017575 0ustar00jeffstaff000000 000000 # ABSTRACT: Something that makes network requests package Pinto::Role::UserAgent; use Moose::Role; use MooseX::MarkAsMethods ( autoclean => 1 ); use URI; use Path::Class; use LWP::UserAgent; use HTTP::Status qw(:constants); use Pinto::Globals; use Pinto::Util qw(debug throw tempdir make_uri); #----------------------------------------------------------------------------- our $VERSION = '0.14'; # VERSION #----------------------------------------------------------------------------- sub mirror { my ( $self, $from, $to ) = @_; $from = make_uri($from); $to = file($to); $to->parent->mkpath if not -e $to->parent; my $response = $Pinto::Globals::UA->mirror( $from => $to ); return 1 if $response->is_success; return 0 if $response->code == HTTP_NOT_MODIFIED; throw "Failed to mirror $from: " . $response->status_line; } #------------------------------------------------------------------------------ sub mirror_temporary { my ( $self, $uri ) = @_; $uri = URI->new( $uri )->canonical; my $path = file( $uri->path ); return $path if $uri->scheme() eq 'file'; my $base = $path->basename; my $tempfile = file( tempdir, $base ); $self->mirror( $uri => $tempfile ); return file($tempfile); } #------------------------------------------------------------------------------ # TODO: Consider a better interface to the UA sub head { my ($self, @args) = @_; # TODO: Argument check? debug sub { $args[0]->as_string(0) }; return $Pinto::Globals::UA->head(@args); } #------------------------------------------------------------------------------ # TODO: Consider a better interface to the UA sub request { my ($self, @args) = @_; # TODO: Argument check? debug sub { $args[0]->as_string(0) }; return $Pinto::Globals::UA->request(@args); } #----------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Role::UserAgent - Something that makes network requests =head1 VERSION version 0.14 =head1 METHODS =head2 mirror(RESOURCE => PATH) Mirrors the resource located at C to the file located at PATH, if the RESOURCE is newer than the file at PATH. If the intervening directories do not exist, they will be created for you. Returns a true value if the file has changed, returns false if it has not changed. Throws an exception if anything goes wrong. The RESOURCE can be either a L or L object, or a string that represents either of those. The PATH can be a L object or a string that represents one. =head2 mirror_temporary(RESOURCE) Mirrors RESOURCE to a file in a temporary directory. The file will have the same basename as the RESOURCE. Returns a L that points to the new file. Throws and exception if anything goes wrong. Note the temporary directory and all its contents will be deleted when the process terminates. =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Role/Schema/Result.pm000644 000766 000024 00000003623 13141540305 020361 0ustar00jeffstaff000000 000000 # ABSTRACT: Attributes and methods for all Schema::Result objects package Pinto::Role::Schema::Result; use Moose::Role; use MooseX::MarkAsMethods ( autoclean => 1 ); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ has repo => ( is => 'ro', isa => 'Pinto::Repository', default => sub { $_[0]->result_source->schema->repo }, init_arg => undef, lazy => 1, ); #------------------------------------------------------------------------------ sub refresh { my ($self) = @_; $self->discard_changes; return $self; } #------------------------------------------------------------------------------ sub refresh_column { my ( $self, $column ) = @_; $self->mark_column_dirty($column); return $self->get_column($column); } #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Role::Schema::Result - Attributes and methods for all Schema::Result objects =head1 VERSION version 0.14 =head1 DESCRIPTION This role adds a L attributes. It should only be applied to L subclasses, as it will reach into the underlying L object to get at the repo. This gives us a back door for injecting additional attributes into L objects, since those are usually created by L and we don't have control over the construction process. =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Remote/Action/000755 000766 000024 00000000000 13141540305 017110 5ustar00jeffstaff000000 000000 Pinto-0.14/lib/Pinto/Remote/Action.pm000644 000766 000024 00000012506 13141540305 017452 0ustar00jeffstaff000000 000000 # ABSTRACT: Base class for remote Actions package Pinto::Remote::Action; use Moose; use MooseX::StrictConstructor; use MooseX::MarkAsMethods ( autoclean => 1 ); use MooseX::Types::Moose qw(Str Maybe); use URI; use JSON; use HTTP::Request::Common; use Pinto::Result; use Pinto::Constants qw(:protocol); use Pinto::Util qw(current_time_offset); use Pinto::Types qw(Uri); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ with qw(Pinto::Role::Plated Pinto::Role::UserAgent); #------------------------------------------------------------------------------ has name => ( is => 'ro', isa => Str, required => 1, ); has root => ( is => 'ro', isa => Uri, required => 1, ); has args => ( is => 'ro', isa => 'HashRef', default => sub { {} }, ); has username => ( is => 'ro', isa => Str, required => 1 ); has password => ( is => 'ro', isa => Maybe [Str], required => 1, ); #------------------------------------------------------------------------------ sub execute { my ($self) = @_; my $request = $self->_make_request; my $result = $self->_send_request( req => $request ); return $result; } #------------------------------------------------------------------------------ sub _make_request { my ( $self, %args ) = @_; my $action_name = $args{name} || $self->name; my $request_body = $args{body} || $self->_make_request_body; my $uri = URI->new( $self->root ); $uri->path_segments( '', 'action', lc $action_name ); my $request = POST( $uri, Accept => $PINTO_PROTOCOL_ACCEPT, Content => $request_body, Content_Type => 'form-data', ); if ( defined $self->password ) { $request->authorization_basic( $self->username, $self->password ); } return $request; } #------------------------------------------------------------------------------ sub _make_request_body { my ($self) = @_; return [ $self->_chrome_args, $self->_pinto_args, $self->_action_args ]; } #------------------------------------------------------------------------------ sub _chrome_args { my ($self) = @_; my $chrome_args = { verbose => $self->chrome->verbose, color => $self->chrome->color, palette => $self->chrome->palette, quiet => $self->chrome->quiet }; return ( chrome => encode_json($chrome_args) ); } #------------------------------------------------------------------------------ sub _pinto_args { my ($self) = @_; my $pinto_args = { username => $self->username, time_offset => current_time_offset, }; return ( pinto => encode_json($pinto_args) ); } #------------------------------------------------------------------------------ sub _action_args { my ($self) = @_; my $action_args = $self->args; return ( action => encode_json($action_args) ); } #------------------------------------------------------------------------------ sub _send_request { my ( $self, %args ) = @_; my $request = $args{req} || $self->_make_request; my $status = 0; my $buffer = ''; # Currying in some extra args to the callback... my $callback = sub { $self->_response_callback( \$status, \$buffer, @_ ) }; my $response = $self->request( $request, $callback ); if ( not $response->is_success ) { $self->error( $response->content ); return Pinto::Result->new( was_successful => 0 ); } return Pinto::Result->new( was_successful => $status ); } #------------------------------------------------------------------------------ sub _response_callback { my ( $self, $status, $buffer, $data ) = @_; $data = ${$buffer}.$data; while($data =~ /\G([^\n]*)\n/gc) { my $line = $1; if ( $line eq $PINTO_PROTOCOL_STATUS_OK ) { ${$status} = 1; } elsif ( $line eq $PINTO_PROTOCOL_PROGRESS_MESSAGE ) { $self->chrome->show_progress; } elsif ( $line eq $PINTO_PROTOCOL_NULL_MESSAGE ) { # Do nothing, discard message } elsif ( $line =~ m{^ \Q$PINTO_PROTOCOL_DIAG_PREFIX\E (.*)}x ) { $self->chrome->diag($1); } else { $self->chrome->show($line); } } #Save leftovers, use them in next packet (${$buffer}) = ($data =~ /\G(.*)$/g); return 1; } #----------------------------------------------------------------------------- __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Remote::Action - Base class for remote Actions =head1 VERSION version 0.14 =head1 METHODS =head2 execute Runs this Action on the remote server by serializing itself and sending a POST request to the server. Returns a L. =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Remote/Result.pm000644 000766 000024 00000002521 13141540305 017507 0ustar00jeffstaff000000 000000 # ABSTRACT: The result from running a remote Action package Pinto::Remote::Result; use Moose; use MooseX::Types::Moose qw(Bool); #----------------------------------------------------------------------------- our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ has was_successful => ( is => 'ro', isa => Bool, default => 0, ); #----------------------------------------------------------------------------- sub exit_status { my ($self) = @_; return $self->was_successful ? 0 : 1; } #----------------------------------------------------------------------------- __PACKAGE__->meta->make_immutable; #----------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Remote::Result - The result from running a remote Action =head1 VERSION version 0.14 =head1 METHODS =head2 exit_status() Returns 0 if this result was successful. Otherwise, returns 1. =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Remote/Action/Add.pm000644 000766 000024 00000004371 13141540305 020143 0ustar00jeffstaff000000 000000 # ABSTRACT: Add a distribution to a the repository package Pinto::Remote::Action::Add; use Moose; use MooseX::MarkAsMethods ( autoclean => 1 ); use JSON; use Pinto::Util qw(throw); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Remote::Action ); #------------------------------------------------------------------------------ around BUILDARGS => sub { my $orig = shift; my $class = shift; my $args = $class->$orig(@_); # I don't have a separate attribute for each action argument, # so I need to wedge in the default author identity somehow. # And if PINTO_AUTHOR_ID isn't defined either, then the server # will fall back to using the username. Perhaps I could also # do the same thing here just to make it clear what's going on. $args->{args}->{author} ||= $ENV{PINTO_AUTHOR_ID} if $ENV{PINTO_AUTHOR_ID}; return $args; }; #------------------------------------------------------------------------------ sub BUILD { my ($self) = @_; throw 'Only one archive can be remotely added at a time' if @{ $self->args->{archives} || [] } > 1; return $self; } #------------------------------------------------------------------------------ override _make_request_body => sub { my ($self) = @_; my $body = super; my $archive = ( delete $self->args->{archives} )->[0]; push @{$body}, ( archives => [$archive] ); return $body; }; #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Remote::Action::Add - Add a distribution to a the repository =head1 VERSION version 0.14 =for Pod::Coverage BUILD =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Remote/Action/Install.pm000644 000766 000024 00000006327 13141540305 021064 0ustar00jeffstaff000000 000000 # ABSTRACT: Install packages from the repository package Pinto::Remote::Action::Install; use Moose; use MooseX::MarkAsMethods ( autoclean => 1 ); use MooseX::Types::Moose qw(Undef Bool HashRef ArrayRef Maybe Str); use File::Temp; use File::Which qw(which); use Pinto::Result; use Pinto::Util qw(throw); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Remote::Action ); #------------------------------------------------------------------------------ has targets => ( isa => ArrayRef [Str], traits => ['Array'], handles => { targets => 'elements' }, default => sub { $_[0]->args->{targets} || [] }, lazy => 1, ); has do_pull => ( is => 'ro', isa => Bool, default => 0, ); has mirror_uri => ( is => 'ro', isa => Str, builder => '_build_mirror_uri', lazy => 1, ); #------------------------------------------------------------------------------ sub _build_mirror_uri { my ($self) = @_; my $stack = $self->args->{stack}; my $stack_dir = defined $stack ? "/stacks/$stack" : ''; my $mirror_uri = $self->root . $stack_dir; if ( defined $self->password ) { # Squirt username and password into URI my $credentials = $self->username . ':' . $self->password; $mirror_uri =~ s{^ (https?://) }{$1$credentials\@}mx; } return $mirror_uri; } #------------------------------------------------------------------------------ around BUILDARGS => sub { my $orig = shift; my $class = shift; my $args = $class->$orig(@_); # Intercept attributes from the action "args" hash $args->{do_pull} = delete $args->{args}->{do_pull} || 0; $args->{cpanm_options} = delete $args->{args}->{cpanm_options} || {}; return $args; }; #------------------------------------------------------------------------------ override execute => sub { my ($self) = @_; my $result; if ( $self->do_pull ) { my $request = $self->_make_request( name => 'pull' ); $result = $self->_send_request( req => $request ); throw 'Failed to pull packages' if not $result->was_successful; } # Pinto::Role::Installer will handle installation after execute() return defined $result ? $result : Pinto::Result->new; }; #------------------------------------------------------------------------------ with qw( Pinto::Role::Installer ); #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #----------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Remote::Action::Install - Install packages from the repository =head1 VERSION version 0.14 =for Pod::Coverage BUILD =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Manual/Installing.pod000644 000766 000024 00000013003 13141540305 020462 0ustar00jeffstaff000000 000000 # ABSTRACT: Tips for installing Pinto package Pinto::Manual::Installing; #------------------------------------------------------------------------------ # VERSION #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Manual::Installing - Tips for installing Pinto =head1 VERSION version 0.14 =head1 SYNOPSIS For the impatient... curl -L http://getpinto.stratopan.com | bash source ~/opt/local/pinto/etc/bashrc And then possibly... echo source ~/opt/local/pinto/etc/bashrc >> ~/.bashrc =head1 APPLICATION VERSUS LIBRARY VERSUS SERVER For most situations, Pinto is more like an I than a I. It is a tool that you use to develop and manage your code, but Pinto itself is not I your code. Pinto also has a lot of dependencies, some of which may conflict with or complicate your code. Pinto can also serve as the backend supporting a daemonized Starman server exposed to the wilds of the internet. Doing so opens the door to many additional security concerns. We suggest below some practices we hope will serve to minimize the risks of doing so. =head1 INSTALLING AS AN APPLICATION For the reasons above, I recommend installing Pinto as a stand-alone application in its own sandbox. That way, it doesn't pollute your environment with its dependencies. Nor will you pollute Pinto with changes to your environment, so Pinto will function even when your other environment dependencies are broken. And hopefully, you can use Pinto to help fix whatever broke! =head2 Step 1: Run the pinto installer script The installer script at L is mostly just a wrapper around L, which installs pinto in a self-contained directory: # If you use curl... curl -L http://getpinto.stratopan.com | bash # If you use wget... wget -O - http://getpinto.stratopan.com | bash All the dependent modules will come from a curated repository on L. These aren't always the latest versions of things, but they are versions that I know will work. =head2 Step 2: Set up the pinto environment The pinto installer generates a setup script for you. By default, it is located at F<~/opt/local/pinto/etc/bashrc>. To load that setup into your current shell, just give this command: source ~/opt/local/pinto/etc/bashrc To make these settings part of your everyday shell environment, just add that last command to your F<~/.profile> or F<~/.bashrc> or whatever setup file is appropriate for your shell. If you wish to customize any of the other environment variables that pinto uses, you can place those commands in F<~/.pintorc>. If that file exists, the setup script will source them as well. See L for a list of the relevant environment variables. =head1 INSTALLING AS A SERVER If you will be running the pintod daemon exposed to the internet, it is suggested that you assume root privileges and proceed as follows: (1) create a pinto user like so: adduser --system --home /opt/local/pinto --shell /bin/false \ --disabled-login --group pinto (2) set some environmental variables: export PINTO_HOME=/opt/local/pinto export PINTO_REPOSITORY_ROOT=/var/pinto check that the exports took with `env`. (3) run the installer as described above, and source the environmental variables to facilitate the steps of setting up the repository. (4) choose an authentication backend and install it like so: cpanm -L $PINTO_HOME Authen::Simple::Kerberos to review your options see L. (5) choose an appropriate startup script and install it: cp $PINTO_HOME/etc/init.d/pintod.debian /etc/init.d/pintod update-rc.d pintod start 50 2 3 4 5 . stop 20 0 1 6 . =head2 AN IMPORTANT NOTE ABOUT SECURITY Currently daemonizing the pintod server will run the starman workers as root. We hope to soon have the pintod daemon drop its privileges after initiating the master and before spawning the workers, so that the workers will run as the pinto user. Until that feature is in place, pinto repository administrators are urged to keep their installations safely behind firewalls, protected from the potentially hostile user. =head1 INSTALLING AS A LIBRARY If you're going to be hacking on Pinto itself, or want to try building on the API directly, then you can install Pinto straight into your development environment, just like you would do for any other module. Just beware that Pinto has lots of dependencies. And if you subsequently upgrade any of those dependencies to something that breaks Pinto, then you might find yourself in a pickle. The whole point of Pinto is to help you manage your dependencies, so if you break Pinto, it won't be able to help you. =head1 OTHER INSTALLATION OPTIONS Naturally, installation procedures will vary from one environment to another. If this procedure doesn't work for you, or if you'd like to suggest a procedure for a different environment (e.g. Windows, Perlbrew, Strawberry Perl, etc.), then please contact me. Your contributions would be greatly appreciated. =head1 SEE ALSO L L L (the library) L (the command) =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Manual/Introduction.pod000644 000766 000024 00000013667 13141540305 021057 0ustar00jeffstaff000000 000000 # ABSTRACT: Why Pinto exists package Pinto::Manual::Introduction; #------------------------------------------------------------------------------ # VERSION #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer Wes =head1 NAME Pinto::Manual::Introduction - Why Pinto exists =head1 VERSION version 0.14 =head1 GOALS Pinto has two primary goals. First, Pinto seeks to address the problem of instability in the CPAN mirrors. Distribution archives are constantly added and removed from the CPAN, so if you use it to build a system or application, you may not get the same result twice. Second, Pinto seeks to encourage developers to use the CPAN toolchain for building, testing, and dependency management of their own local software, even if they never plan to release it to the CPAN. Pinto accomplishes these goals by providing tools for creating and managing your own custom repositories of distribution archives. These repositories can contain any distribution archives you like, and can be used with the standard CPAN toolchain. The tools also support various operations that enable you to deal with common problems that arise during the development process. =head1 PRIOR ART Over the last few years, I personally used various combinations of those modules to create custom repositories at several organizations. But they always required some wrapping and/or glue to make them usable in the development process. And none of them seemed to be designed for extension. I wanted a tool that would work out-of-the-box, would accommodate a wide range of use cases, would scale to a large number of users, and could grow in unexpected directions. And so, Pinto was born. =head1 COMPONENTS The Pinto suite consists of several components, which are all included in this distribution. For most use cases, you should treat Pinto as an external application rather than a library that is integrated with your own application code. I strongly recommend reading L for tips on installing Pinto in the manner that is most appropriate for your needs. =head2 L L is a command line application for creating and managing a Pinto repository. It works transparently with both remote and local repositories. However, repositories can only be created locally. =head2 L L provides a web service interface to your Pinto repository. This allows multiple (possibly remote) developers to manage a central repository. L also functions as the back end HTTP server for installer clients like L, L, and L. =head2 L and L L and L are the backend libraries for the L application. These are fairly stable, but not officially public and not documented. If you want to hack on Pinto's internals, or create a new application around Pinto, you should start looking at these. =head2 L L is the backend library for the L server application. It is still immature, and subject to radical change. It is based on raw L, so if you are brave you could wrap it with various middlewares to do interesting things. =head1 TERMINOLOGY Some of the terminology related to the CPAN is overloaded, which can lead to some confusion. So I'll try to define some of the key terms that I use throughout the documentation and the code. =head2 Archive An "archive" is the file that developers ship, which contains all their application/library code, test cases, build scripts etc. Conversely, the archive is the file that users must fetch to install the application/library. Sometimes I also refer to these as "distributions". =head2 Package A "package" is something inside a distribution archive that provides some unit of functionality. In Perl, packages are declared with the C keyword. Some folks call these "modules" but I try to avoid that term because it is frequently misused. =head2 Prerequisite A "prerequisite" is a package that must be installed for the sake of another distribution archive. Sometimes I call these "dependencies". Pinto does not currently distinguish between different flavors of prerequisites, such as "build-time" or "run-time" prerequisites. =head1 CONCEPTS =head2 Stack All CPAN-like repositories have an index which maps the latest version of each package to the archive that contains it. Usually, there is only one such index. But with Pinto, there can be many indexes. Each of these indexes is called a "stack". This allows you to create different stacks of dependencies within a single repository. So you could have a "development" stack and a "production" stack. Whenever you add a distribution or upgrade a prerequisite, it only affects one stack. =head2 Pin Only one version of a package can exist within a stack. So when you upgrade a package in a stack, the newer version replaces the older one. But sometimes, you discover that a newer version of package is incompatible with your application, and you want to stay with the older version until you have an opportunity to fix the problem. In those situations, Pinto allows you to "pin" a particular version of a package to the stack. This prevents the package from being upgraded (either directly or as a prerequisite for some other package). =head1 WHY IS IT CALLED PINTO Pinto is a name that I sometimes use for my son Wesley (as in "pinto bean"). Daddy loves you, Wes! =head1 SEE ALSO =over 4 =item L Presents a narrative explanation of how to use L. =item L Presents a condensed summary of L commands. =back =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Manual/QuickStart.pod000644 000766 000024 00000012244 13141540305 020456 0ustar00jeffstaff000000 000000 # ABSTRACT: A condensed summary of Pinto package Pinto::Manual::QuickStart; #------------------------------------------------------------------------------ # VERSION #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Manual::QuickStart - A condensed summary of Pinto =head1 VERSION version 0.14 =head1 INSTALLING PINTO curl -L http://getpinto.stratopan.com | bash source ~/opt/local/pinto/etc/bashrc =head1 CREATING A REPOSITORY # A new repository with default stack named "master" pinto -r /repo/dir init pinto init /repo/dir # A new repository with default stack named "dev" pinto -r /repo/dir init --stack dev =head1 BROWSING A REPOSITORY # See all packages in the default stack pinto -r /repo/dir list # See all packages in the default stack matching m/Foo::Bar/i pinto -r /repo/dir list -P Foo::Bar # See all packages in the default stack by author "JOE" pinto -r /repo/dir list -A JOE # See all packages in the "dev" stack pinto -r /repo/dir list --stack dev pinto -r /repo/dir list dev =head1 PULLING UPSTREAM DISTRIBUTIONS # Pull any version of Foo::Bar pinto -r /repo/dir pull Foo::Bar # Pull version 2.4 or newer of Foo::Bar pinto -r /repo/dir pull Foo~2.4 # Pull exactly version 2.4 of Foo::Bar pinto -r /repo/dir pull Foo==2.4 # Pull a specific distribution pinto -r /repo/dir pull AUTHOR/Foo-Bar-1.9.tar.gz # Pull and pin at the same time pinto -r /repo/dir pull --pin Foo::Bar~2.4 # Pull many packages or distributions pinto -r /repo/dir pull Foo::Bar Baz::Qux ... pinto -r /repo/dir pull < LIST_OF_PACKAGES # Pull everything for a Dist::Zilla project dzil listdeps | pinto -r /repo/dir pull # Pull onto the "dev" stack pinto -r /repo/dir pull --stack dev Foo::Bar =head1 ADDING LOCAL DISTRIBUTIONS # Add a local dist to the default stack pinto -r /repo/dir add My-Dist-1.0.tar.gz # Assign to a different author pinto -r /repo/dir add --author SHAKESPEARE My-Dist-1.0.tar.gz # Add and pin at the same time pinto -r /repo/dir add --pin My-Dist-1.0.tar.gz # Add to the "dev" stack pinto -r /repo/dir add --stack dev My-Dist-1.0.tar.gz =head1 INSTALLING THINGS # Install from the default stack using cpanm cpanm --mirror file:///repo/dir --mirror-only Foo::Bar # Install from the "dev" stack using cpanm cpanm --mirror file:///repo/dir/stacks/dev --mirror-only Foo::Bar # Install from the default stack using pinto pinto -r /repo/dir install Foo::Bar # Install from the "dev" stack using pinto pinto -r /repo/dir --stack dev install Foo::Bar # Install and populate the repository with missing prereqs pinto -r /repo/dir install --do-pull Foo::Bar =head1 MANAGING STACKS # Create an empty stack named "qa" pinto -r /repo/dir new qa # Create a stack by copying "dev" to "qa" pinto -r /repo/dir copy dev qa # Delete the dev stack pinto -r /repo/dir kill dev # Rename the "dev" stack to "prod" pinto -r /repo/dir rename dev prod # Mark the "qa" stack as the default pinto -r /repo/dir default qa # Show config properties of the default stack pinto -r /repo/dir props # Set config properties of the default stack pinto -r /repo/dir props --property NAME=VALUE # Show all the existing stacks pinto -r /repo/dir stacks =head1 USING PINS # Pin a package on the default stack pinto -r /repo/dir pin Foo::Bar # Pin a package on the "dev" stack pinto -r /repo/dir pin --stack dev Foo::Bar # Pin a distribution pinto -r /repo/dir pin AUTHOR/Foo-Bar-1.0.tar.gz # Unpin a package from the default stack pinto -r /repo/dir unpin Fo::Bar # Unpin a package from the "dev" stack pinto -r /repo/dir unpin --stack dev Foo::Bar # Unpin a distribution pinto -r /repo/dir unpin AUTHOR/Foo-Bar-1.0.tar.gz =head1 VERSION CONTROL # View commit messages for the default stack pinto -r /repo/dir log # View commit messages for the "dev" stack pinto -r /repo/dir log dev # Compare the heads of the default and "qa" stacks pinto -r /repo/dir diff qa # Compare the heads of the "dev" and "qa" stacks pinto -r /repo/dir diff dev qa # Merge "dev" stack into the "qa" stack (fast-forward only) pinto -r /repo/dir merge dev qa =head1 MISCELLANY # Report missing distribution archives pinto -r /repo/dir verify # Report repo statistics pinto -r /repo/dir stats # Remove orphan files and tune the database pinto -r /repo/dir clean # Report top-level distributions of the default stack pinto -r /repo/dir roots =head1 GETTING MORE HELP # Show a list of pinto commands pinto commands # Show a brief summary of a COMMAND pinto help COMMAND # Show the manual for a COMMAND pinto manual COMMAND =head1 SEE ALSO L L L (the library) L (the command) =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Manual/Thanks.pod000644 000766 000024 00000011016 13141540305 017610 0ustar00jeffstaff000000 000000 # ABSTRACT: Thanking the Pinto supporters package Pinto::Manual::Thanks; #------------------------------------------------------------------------------ # VERSION #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Manual::Thanks - Thanking the Pinto supporters =head1 VERSION version 0.14 =head1 THANK YOU In April of 2013, brian d foy organized a L to finance further development of Pinto. To my knowledge, this was the first and (so far) largest crowdfunding campaign for an open source Perl project. Thanks to the hard work of numerous individuals, the campaign ultimately exceeded its goals and raised $4,620.12 from 128 contributors (listed below). I am truly grateful to each and every one of them. Because of their generous support, I can continue doing the work I love most. jrw 32982 Nathan Glenn Ekki Plicht Olaf Alders Michael Gregorowicz Steve Purkis Mark Allen Jason Harlan Sean Quinlan Rohan Almeida George Hartzell Michael Rasmussen Pat And Don John Haugeland Will Redd Ross Attrill Sherry Heinz Jozef Reisinger Renee B Khaled Hussein Dan Risse John Bales Toby Inkster Michel Rodriguez Michiel Beijen Infinity Interactive Daniel Ruoso Alan Berndt Perl Is Fun Bill Ruppert James Beshara Chris Jack Timothy Sailer Neil Bowers Paul Johnson Jorge Sainz Norbert Brandl Prakash Kailasa Moosa Salem Philippe Bruhat Alexander Karelas Conrad Schneiker Lee Carmichael Aydar Khabibullin Clayton Scott Yanick Champoux Andrey Khozov Craig Scrivner Gustavo Chaves Wolfgang Kinkeldei Li Sen Peter Chines Yaroslav Korshak Michael South Adam Clarke Damien Krotkine Tadeusz Sosnierz Olav Cleemann Michael Kröll Marc St Raymond Jody Clements Tom Legrady Seth Surchin Greg Cole Felipe Leprevost Gabor Szabo Montgomery Conner Hermen Lesscher Christopher Taranto Tudor Constantin Vladimir Lettiev Jan Thorsen Anon Contrib Carlos Lima Viacheslav Tykhanovskyi Anonymous Contributor Nick Logan A Sinan Unur Justin Cook Søren Lund Bruce Van Allen Dave Cross Jim Martinez Todd Wade Tomasz Czepiel Naveed Massjouni Brian Wisti Seth Daniel Vyacheslav Matyukhin John Wittkoski Robert Debowski Gabriel Munoz William Wolf Gautam Dey Kamen Naydenov Chisel Wright José Diaz Seng Al Newkirk Sawyer X Boris Däppen T Nishimura Andy Yates Magnus Enger Ryan Olson Doyle Young Hugh Esco Marco Palma Marek Zareba Roman F Karen Pauley Kev Zettler David Farrell Bryan Paxton j0e axford Eric Folley Emil Perhinschi dagur Mike Friedman Matt Perry brian d foy Wolf Gang Dimitar Petrov del skorch Greg Gerke Jamie Pitts Allen van der Ross I also thank L for graciously allowing us to use their fundraising platform free of charge, and for providing such excellent customer support during our campaign. =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Manual/Tutorial.pod000644 000766 000024 00000041743 13141540305 020175 0ustar00jeffstaff000000 000000 # ABSTRACT: A narrative introduction to Pinto package Pinto::Manual::Tutorial; #------------------------------------------------------------------------------ # VERSION #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Manual::Tutorial - A narrative introduction to Pinto =head1 VERSION version 0.14 =head1 INTRODUCTION This tutorial walks you through some of the typical use cases for a L repository. Along the way, it demonstrates most of the L commands. You are encouraged to try the commands as you read along. If you would prefer to get a more condensed summary of features and commands, please read the L. For detailed instructions on installing the software read L. =head1 BASIC OPERATIONS =head2 Creating a repository The first step in using Pinto is to create a repository, using the L command like this: pinto --root ~/repo init This will create a new repository in the F<~/repo> directory. If that directory does not exist, it will be created for you. If it already does exist, then it must be empty. The C<--root> (or C<-r>) option specifies where the repository is. This argument is required for every L command. But if you get tired of typing it, you can set the C environment variable to point to your repository instead. The repository is created with a stack called "master" which is also marked as the default stack. We'll talk more about stacks and default stack later. =head2 Inspecting the repository Now that you have a repository, let's look inside it. To see the contents of a repository, use the L command: pinto --root ~/repo list You will use the L command quite often. But at this point, the listing will be empty because there is nothing in the repository. So let's go ahead and add something... =head2 Adding dependencies Suppose we are working on an application called My-App that contains a package called C. The application also depends on the L package. Using the L command, you can bring the URI package into your repository: pinto --root ~/repo pull URI You will be prompted to enter a log message that describes why this change is happening. The message template will include a semi-informative generated message. Feel free to edit this message as you see fit. Save the file and close your editor when you are done. Now, you should have URI in your local repository. So lets look and see what we really got. Once again, you use the L command to see inside the repository: pinto --root ~/repo list This time, the listing will look something like this: rf URI 1.60 GAAS/URI-1.60.tar.gz rf URI::Escape 3.31 GAAS/URI-1.60.tar.gz rf URI::Heuristic 4.20 GAAS/URI-1.60.tar.gz ... You can see that the URI package has been added to the repository, as well as all the prerequisites for URI, and all of their prerequisites, and so on. =head2 Adding your own distributions Now suppose that you've finished work on My-App and your ready to release the first version. Using your preferred build tool (L, L, L etc.) you package a release as F. Now put the distribution into the repository with the L command: pinto --root ~/repo add path/to/My-App-1.0.tar.gz When you list the repository contents now, it will include the C package and show you as the author of the distribution: rl My::App 1.0 JEFF/My-App-1.0.tar.gz rf URI 1.60 GAAS/URI-1.60.tar.gz rf URI::Escape 3.31 GAAS/URI-1.60.tar.gz rf URI::Heuristic 4.20 GAAS/URI-1.60.tar.gz ... =head2 Installing packages Now the repository contains both your application and all of its prerequisites, so you can install it into your environment using the L command: pinto --root ~/repo install My::App When C is installed, it will only use the prerequisites that are in your repository. Even if a newer version of URI is released to the CPAN in the future, C will always be built with the same versions of the same prerequisites that you developed and tested against. This ensures your application builds will be stable and predictable. On the surface, a Pinto repository looks like an ordinary CPAN, so you can also install packages from it using L directly. All you have to do is point them at the URI of your repository (under the hood, this is all the L command is really doing anyway). For example: cpanm --mirror file:///home/jeff/repo --mirror-only My::App The C<--mirror-only> flag is important because it tells L to B use the C to resolve packages. Instead you only want to use the index from B repository. You can do the same thing with L and L as well. See their documentation for information on how to set the URI of the repository. =head2 Upgrading a dependency Suppose that several weeks have passed since you first released My-App and now URI version 1.62 is available on the CPAN. It has some bug critical fixes that you'd like to get. Again, we can bring that into the repository using the L command. But since your repository already contains a version of URI, you must indicate that you want a *newer* one by specifying the minimum version that you want: pinto --root ~/repo pull URI~1.62 If you look at the listing again, this time you'll see the newer version of URI (and possibly other packages as well): rl My::App 1.0 JEFF/My-App-1.0.tar.gz rf URI 1.62 GAAS/URI-1.62.tar.gz rf URI::Escape 3.38 GAAS/URI-1.62.tar.gz rf URI::Heuristic 4.20 GAAS/URI-1.62.tar.gz ... If the new version of URI requires any new prerequisites, those will be in the repository too. Now when you install C, you'll get version 1.62 of URI. =head1 WORKING WITH STACKS So far in this tutorial, we've treated the repository as a singular resource. For example, when we upgraded URI in the last section, it impacted every person and every application that might have been using the repository. But this kind of broad impact is undesirable. You would prefer to make those kinds of changes in isolation and test them before forcing everyone else to upgrade. This is what stacks are designed for. =head2 What is a stack All CPAN-like repositories have an index which maps the latest version of each package to the archive that contains it. Usually, there is only one such index per repository. But with Pinto, there can be many indexes. Each of these indexes is called a "stack". This allows you to create different stacks of dependencies within a single repository. So you could have a C stack and a C stack. Whenever you add a distribution or upgrade a prerequisite, it only affects one stack. =head2 The default stack Before getting into the gory details, you first need to know about the default stack. For most operations, the name of the stack is an optional parameter. So if you do not specify a stack explicitly, then the operation is applied to whichever stack is marked as the default. In any repository, there is never more than one default stack. When we created this repository, the C stack was marked as the default. You can also change the default stack or change the name of a stack, but we won't go into that here. See the L command to learn more about that. Just remember that C is the name of the stack that was created when the repository was first initialized. =head2 Creating a stack Suppose your repository contains version 1.60 of URI, but version 1.62 has been released to the CPAN, just like in the earlier section. You want to try upgrading, but this time you're going to do it on a separate stack. Thus far, everything you've added or pulled into the repository has gone onto the C stack. You could create an entirely new stack, but the C stack already has the prerequisites for My-App, so we're just going to make a clone using the L command: pinto --root ~/repo copy master uri_upgrade This creates a new stack called C. If you want to see the contents of that stack, just use the L command with the C<--stack> option: pinto --root ~/repo list --stack uri_upgrade The listing should be identical to the C stack: rl My::App 1.0 JEFF/My-App-1.0.tar.gz rf URI 1.60 GAAS/URI-1.60.tar.gz ... =head2 Upgrading a stack Now that you've got a separate stack, you can try upgrading URI. Just as before, you'll use the L command. But this time, you'll tell Pinto that you want the packages to be pulled onto the C stack: pinto --root ~/repo pull --stack uri_upgrade URI~1.62 Now lets compare the C and C stacks using the L command: pinto --root ~/repo diff master uri_upgrade +rf URI 1.62 GAAS/URI-1.62.tar.gz +rf URI::Escape 3.31 GAAS/URI-1.62.tar.gz +rf URI::Heuristic 4.20 GAAS/URI-1.62.tar.gz ... -rf URI 1.60 GAAS/URI-1.60.tar.gz -rf URI::Escape 3.31 GAAS/URI-1.60.tar.gz -rf URI::Heuristic 4.20 GAAS/URI-1.60.tar.gz The output is similar to the diff(1) command. Records starting with a "+" were added and those starting with a "-" have been removed. =head2 Installing from a stack With URI upgraded on the C stack, you can now try building and testing our application. All you have to do is run the L command and point to the right stack: pinto --root ~/repo install --stack uri_upgrade My::App This will build My::App using only the prerequisites that are on the C stack. If the tests pass, then you can confidently upgrade URI on the C stack as well. As mentioned earlier, you can also use L to install modules from your repository. But when installing from a stack other than the default, you must append "stacks/stack_name" to the URI. For example: cpanm --mirror file:///home/jeff/repo/stacks/uri_upgrade --mirror-only My::App =head1 USING PINS In the last section, we used a stack to experiment with upgrading a dependency. Fortunately, all the tests passed. But what if the tests didn't pass? If the problem lies within My-App and you can quickly correct it, you might just modify your code, release version 2.0 of My-App, and then proceed to upgrade URI on the C stack. But if the issue is a bug in URI or it will take a long time to fix My-App, then you have a real problem. You don't want someone else to upgrade URI, nor do you want it to be upgraded inadvertently to satisfy some other prerequisite that My-App may have. Until the bug is fixed (in either URI or My-App) you need to prevent URI from being upgraded. This is what pins are for. =head2 Pinning a package When you pin a package, that version of the package is forced to stay in a stack. Any attempt to upgrade it (either directly or via another prerequisite) will fail. To pin a package, use the L command like this: pinto --root ~/repo pin URI If you look at the listing for the C stack again, you'll see something like this: ... rl My::App 1.0 JEFF/My-App-1.0.tar.gz rf! URI 1.60 GAAS/URI-1.60.tar.gz rf! URI::Escape 3.31 GAAS/URI-1.60.tar.gz ... The "!" near the beginning of the line indicates the package has been pinned. Notice every package in the F distribution has been pinned, so it is impossible to partially upgrade a distribution (this situation could happen when a package moves into a different distribution). =head2 Unpinning a packages After a while, suppose you fix the problem in My-App or a new version of URI is released that fixes the bug. When that happens, you can unpin URI from the stack using the L command: pinto --root ~/repo unpin URI At this point you're free to upgrade URI to the latest version whenever you're ready. Just as with pinning, when you unpin a package, it unpins every other package it that distribution as well. =head1 USING PINS AND STACKS TOGETHER Pins and stacks are used together to help manage change during the development cycle. For example, you could create a stack called C that contains your known-good dependencies. Likewise, you could create a stack called C that contains experimental dependencies for your next release. Initially, the C stack is just a copy of the C stack. As development proceeds, you may upgrade or add several packages on the C stack. If an upgraded package breaks your application, then you'll place a pin in that package on the C stack to signal that it shouldn't be upgraded. =head2 Pins and Patches Sometimes you may find that a new version of a CPAN distribution has a bug but the author is unable or unwilling to fix it (at least not before your next release is due). In that situation, you may elect to make a local patch of the CPAN distribution. So suppose that you forked the code for L and made a local version of the distribution called F. You can add it to your repository using the L command: pinto --root ~/repo add path/to/URI-1.60_PATCHED.tar.gz In this situation, it is wise to pin the package as well, since you do not want it to be updated until you are sure that the new release includes your patch or the author has fixed the bug by other means. pinto --root ~/repo pin URI When the author of URI releases version 1.62 with your patch, you'll want to try it before deciding to unpin from your locally patched version. Just as before, this can be done by cloning the stack with the L command. Let's call it the C stack this time: pinto --root ~/repo copy master trial But before you can update URI on the C stack, you'll have to unpin it there: pinto --root ~/repo unpin --stack trial URI Now you can proceed to update URI on the stack and try building C like this: pinto --root ~/repo update --stack trial URI pinto --root ~/repo install --stack trial My::App If all the tests pass, then you can merge the changes back to the C stack: pinto --root ~/repo merge trial master =head2 Reviewing Past Changes As you've noticed by now, each command that changes the state of a stack requires a log message to describe it. You can review those messages using the L command: pinto --root ~/repo log That should display something like this: revision 4a62d7ce-245c-45d4-89f8-987080a90112 Date: Mar 15, 2013 1:58:05 PM User: jeff Pin GAAS/URI-1.59.tar.gz Pinning URI because it is not causes our foo.t script to fail revision 4a62d7ce-245c-45d4-89f8-987080a90112 Date: Mar 15, 2013 1:58:05 PM User: jeff Pull GAAS/URI-1.59.tar.gz URI is required for HTTP support in our application ... The header for each message shows who made the change and when it happened. It also has a unique identifier similar to Git's SHA-1 digests. You can use these identifiers to see the diffs between different revisions or to reset the stack back to a prior revision [NB: this feature is not actually implemented yet]. =head1 CONCLUSION In this tutorial, you've seen the basic L commands for pulling dependencies into the repository, and adding your own distributions to the repository. You've also seen how to use stacks and pins to manage your dependencies in the face of some common development obstacles. Each command has several options that were not discussed in this tutorial, and there are some commands that were not mentioned here at all. So you are encouraged to explore the manual pages for each command and learn more. =head1 SEE ALSO L L L (the library) L (the application) =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Locator/Mirror.pm000644 000766 000024 00000010271 13141540305 017654 0ustar00jeffstaff000000 000000 # ABSTRACT: The package index of a repository package Pinto::Locator::Mirror; use Moose; use MooseX::StrictConstructor; use MooseX::Types::Moose qw(HashRef); use MooseX::MarkAsMethods (autoclean => 1); use URI; use URI::Escape; use Pinto::Types qw(Uri File); use Pinto::Util qw(throw debug); use Pinto::IndexReader; use version; #------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------ extends qw(Pinto::Locator); #------------------------------------------------------------------------ with qw(Pinto::Role::UserAgent); #------------------------------------------------------------------------ has index_file => ( is => 'ro', isa => File, builder => '_build_index_file', clearer => '_clear_index_file', lazy => 1, ); has reader => ( is => 'ro', isa => 'Pinto::IndexReader', default => sub { Pinto::IndexReader->new(index_file => $_[0]->index_file)}, clearer => '_clear_reader', lazy => 1, ); #------------------------------------------------------------------------------ sub _build_index_file { my ($self) = @_; my $uri = $self->uri->canonical->as_string; $uri =~ s{ /*$ }{}mx; # Remove trailing slash $uri = URI->new($uri); # Reconstitute as URI object (why?) my $details_filename = '02packages.details.txt.gz'; my $cache_dir = $self->cache_dir->subdir( URI::Escape::uri_escape($uri) ); my $destination = $cache_dir->file($details_filename); my $source = URI->new( "$uri/modules/$details_filename" ); $self->mirror($source => $destination); return $destination; } #------------------------------------------------------------------------ sub locate_package { my ($self, %args) = @_; my $target = $args{target}; return unless my $found = $self->reader->packages->{$target->name}; return unless $target->is_satisfied_by( $found->{version} ); # Indexes from a Pinto repository have fake records for core modules, so # installers can decide if they need to update a dual-life module. If we # get one of those fake records, then we pretend we didn't see it. So if # we really do need a perl, some other upstream source will provide it. if ( $found->{path} =~ m{^F/FA/FAKE/perl} ) { my ($uri, $path) = ($self->uri, $found->{path}); debug "Skipping fake perl found on $uri at $path"; return; } $found = { %$found }; # Shallow clone $found->{package} = delete $found->{name}; $found->{uri} = URI->new($self->uri . "/authors/id/$found->{path}"); $found->{version} = version->parse($found->{version}); delete $found->{path}; return $found; } #------------------------------------------------------------------------ sub locate_distribution { my ($self, %args) = @_; my $target = $args{target}; my $path = $target->path; my @extensions = qw(tar.gz tar.bz2 tar gz tgz bz2 zip z); my $has_extension = $path =~ m/[.](?:tar|gz|tgz|zip|z|bz2)$/i; my @paths_to_try = $has_extension ? ($path) : map { "$path.$_" } @extensions; for my $path (@paths_to_try) { my $uri = URI->new($self->uri . '/authors/id/' . $path); return {uri => $uri} if $self->head($uri)->is_success; } return; } #------------------------------------------------------------------------ sub refresh { my ($self) = @_; $self->index_file->remove; $self->_clear_index_file; $self->_clear_reader; return $self; } #------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Locator::Mirror - The package index of a repository =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Locator/Multiplex.pm000644 000766 000024 00000006231 13141540305 020366 0ustar00jeffstaff000000 000000 # ABSTRACT: Find a package/distribution target among CPAN-like repositories package Pinto::Locator::Multiplex; use Moose; use MooseX::Types::Moose qw(ArrayRef); use MooseX::MarkAsMethods (autoclean => 1); use Pinto::Locator::Mirror; use Pinto::Locator::Stratopan; use Pinto::Constants qw(:stratopan); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #----------------------------------------------------------------------------- extends qw(Pinto::Locator); #------------------------------------------------------------------------------ has locators => ( is => 'ro', isa => ArrayRef['Pinto::Locator'], writer => '_set_locators', default => sub { [] }, lazy => 1, ); #------------------------------------------------------------------------------ sub assemble { my ($self, @uris) = @_; my @locators; for my $uri (@uris) { my $class = $self->locator_class_for_uri($uri); # Ick: This assumes all Locators have same attribute interface my %args = ( uri => $uri, cache_dir => $self->cache_dir ); push @locators, $class->new( %args ); } $self->_set_locators(\@locators); return $self; } #------------------------------------------------------------------------------ sub locate_package { my ($self, %args) = @_; my @all_found; for my $locator ( @{ $self->locators } ) { next unless my $found = $locator->locate_package(%args); push @all_found, $found; last unless $args{cascade}; } return if not @all_found; @all_found = reverse sort {$a->{version} <=> $b->{version}} @all_found; return $all_found[0]; } #------------------------------------------------------------------------------ sub locate_distribution { my ($self, %args) = @_; for my $locator ( @{ $self->locators } ) { next unless my $found = $locator->locate_distribution(%args); return $found; } return; } #------------------------------------------------------------------------------ sub locator_class_for_uri { my ($self, $uri) = @_; my $baseclass = 'Pinto::Locator'; my $subclass = $uri eq $PINTO_STRATOPAN_CPAN_URI ? 'Stratopan' : 'Mirror'; return $baseclass . '::' . $subclass; } #------------------------------------------------------------------------------ sub refresh { my ($self) = @_; $_->refresh for @{ $self->locators }; return $self; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Locator::Multiplex - Find a package/distribution target among CPAN-like repositories =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Locator/Stratopan.pm000644 000766 000024 00000004476 13141540305 020367 0ustar00jeffstaff000000 000000 # ABSTRACT: Locate targets using Stratopan services package Pinto::Locator::Stratopan; use Moose; use MooseX::StrictConstructor; use MooseX::MarkAsMethods ( autoclean => 1 ); use URI; use JSON qw(decode_json); use HTTP::Request::Common qw(GET); use Pinto::Util qw(whine); use Pinto::Constants qw(:stratopan); #----------------------------------------------------------------------------- our $VERSION = '0.14'; # VERSION #----------------------------------------------------------------------------- extends qw(Pinto::Locator); #----------------------------------------------------------------------------- sub locate_package { my ($self, %args) = @_; return $self->_locate_any(%args); } #----------------------------------------------------------------------------- sub locate_distribution { my ($self, %args) = @_; return $self->_locate_any(%args); } #----------------------------------------------------------------------------- sub _locate_any { my ($self, %args) = @_; my $uri = $PINTO_STRATOPAN_LOCATOR_URI->clone; $uri->query_form(q => $args{target}->to_string); my $response = $self->request(GET($uri)); if (!$response->is_success) { my $status = $response->status_line; whine "Stratopan is not responding: $status"; return; } my $structs = eval { decode_json($response->content) }; whine "Invalid response from Stratopan: $@" and return if $@; return unless my $latest = $structs->[0]; # Avoid autovivification here... $latest->{version} = version->parse($latest->{version}) if exists $latest->{version}; # Avoid autovivification here... $latest->{uri} = URI->new($latest->{uri}) if exists $latest->{uri}; return $latest; } #----------------------------------------------------------------------------- __PACKAGE__->meta->make_immutable; #----------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Locator::Stratopan - Locate targets using Stratopan services =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Editor/Clip.pm000644 000766 000024 00000017272 13141540305 017124 0ustar00jeffstaff000000 000000 # ABSTRACT: Internal class for Pinto::Editor package Pinto::Editor::Clip; use Moose; #----------------------------------------------------------------------------- our $VERSION = '0.14'; # VERSION #----------------------------------------------------------------------------- has data => qw/ reader data writer _data required 1 /; has [qw/ start head tail mhead mtail /] => qw/ is rw required 1 isa Int default 0 /; has _parent => qw/ is ro isa Maybe[Pinto::Editor::Clip] init_arg parent /; has found => qw/ is ro required 1 isa Str /, default => ''; has content => qw/ is ro required 1 isa Str /, default => ''; has _matched => qw/ init_arg matched is ro isa ArrayRef /, default => sub { [] }; sub matched { return @{ $_[0]->matched } } has matcher => qw/ is ro /, default => undef; has default => qw/ is ro lazy_build 1 isa HashRef /; #----------------------------------------------------------------------------- sub _build_default { { slurp => '[)', } } #----------------------------------------------------------------------------- sub BUILD { my $self = shift; my $data = $self->data; if ( ref $data ne 'SCALAR' ) { chomp $data; $data .= "\n" if length $data; $self->_data( \$data ); } } #----------------------------------------------------------------------------- sub _fhead ($$) { my ( $data, $from ) = @_; my $i0 = rindex $$data, "\n", $from; return $i0 + 1 unless -1 == $i0; return 0; } #----------------------------------------------------------------------------- sub _ftail ($$) { my ( $data, $from ) = @_; my $i0 = index $$data, "\n", $from; return $i0 unless -1 == $i0; return -1 + length $$data; } #----------------------------------------------------------------------------- sub parent { my $self = shift; if ( my $parent = $self->_parent ) { return $parent } return $self; # We are the base (root) split } #----------------------------------------------------------------------------- sub is_root { my $self = shift; return ! $self->_parent; } #----------------------------------------------------------------------------- sub _strip_edness ($) { my $slurp = $_[0]; $slurp->{chomp} = delete $slurp->{chomped} if exists $slurp->{chomped} && not exists $slurp->{chomp}; $slurp->{trim} = delete $slurp->{trimmed} if exists $slurp->{trimmed} && not exists $slurp->{trim}; } #----------------------------------------------------------------------------- sub _parse_slurp ($@) { my $slurp = shift; my %slurp = @_; # Can/will be overidden _strip_edness \%slurp; if ( ref $slurp eq 'HASH' ) { $slurp = { %$slurp }; _strip_edness $slurp; %slurp = ( %slurp, %$slurp ); } else { $slurp =~ m{^ ([\@\$])? ([\(\[]) ([\)\]]) (/)? }x or die "Invalid slurp pattern ($slurp)"; $slurp{wantlist} = $1 eq '@' ? 1 : 0 if $1; $slurp{slurpl} = $2 eq '[' ? 1 : 0; $slurp{slurpr} = $3 eq ']' ? 1 : 0; $slurp{chomp} = 1 if $4; } return %slurp; } #----------------------------------------------------------------------------- sub find { return shift->split( @_ ); } #----------------------------------------------------------------------------- sub split { my $self = shift; my $matcher; $matcher = shift if @_ % 2; # Odd number of arguments my %given = @_; my $data = $self->data; my $length = length $$data; return unless $length; # Nothing to split my $from = $self->_parent ? $self->tail + 1 : 0; return if $length <= $from; # Was already at end of data pos $data = $from; return unless $$data =~ m/\G[[:ascii:]]*?($matcher)/mgc; my @match = map { substr $$data, $-[$_], $+[$_] - $-[$_] } ( 0 .. -1 + scalar @- ); shift @match; my $found = shift @match; my ( $mhead, $mtail ) = ( $-[1], $+[1] - 1 ); my $head = _fhead $data, $mhead; my $tail = _ftail $data, $mtail; # TODO This is hacky my @matched = @match; my $content = substr $$data, $head, 1 + $tail - $head; my $split = __PACKAGE__->new( data => $data, parent => $self, start => $from, mhead => $mhead, mtail => $mtail, head => $head, tail => $tail, matcher => $matcher, found => $found, matched => \@matched, content => $content, default => $self->default, ); return $split unless wantarray && ( my $slurp = delete $given{slurp} ); return ( $split, $split->slurp( $slurp, %given ) ); } #----------------------------------------------------------------------------- sub slurp { my $self = shift; my $slurp = 1; $slurp = shift if @_ % 2; # Odd number of arguments my %given = @_; my $split = $self; _strip_edness \%given; my %slurp = _parse_slurp $self->default->{slurp}; exists $given{$_} and $slurp{$_} = $given{$_} for qw/ chomp trim /; %slurp = _parse_slurp $slurp, %slurp unless $slurp eq 1; my @content; push @content, $self->parent->content if $slurp{slurpl}; push @content, $split->preceding; push @content, $split->content if $slurp{slurpr}; my $content = join '', @content; if ( $slurp{trim} ) { s/^\s*//, s/\s*$//, for $content; } if ( wantarray && $slurp{wantlist} ) { @content = grep { $_ ne "\n" } split m/(\n)/, $content; @content = map { "$_\n" } @content unless $slurp{chomp}; return @content; } else { return $content; } } #----------------------------------------------------------------------------- sub preceding { my $self = shift; my $data = $self->data; my $length = $self->head - $self->start; return '' unless $length; return substr $$data, $self->start, $length; } #----------------------------------------------------------------------------- sub pre { return shift->preceding( @_ ) } #----------------------------------------------------------------------------- sub remaining { my $self = shift; my $data = $self->data; return $$data if $self->is_root; my $from = $self->tail + 1; my $length = length( $$data ) - $from + 1; return '' unless $length; return substr $$data, $from, $length; } #----------------------------------------------------------------------------- sub re { return shift->remaining( @_ ) } #----------------------------------------------------------------------------- sub match { my $self = shift; my $ii = shift; return $self->found if $ii == -1; return $self->_matched->[$ii]; } #----------------------------------------------------------------------------- sub is { my $self = shift; my $ii = shift; my $is = shift; return unless defined ( my $match = $self->match( $ii ) ); if ( ref $is eq 'Regexp' ) { $match =~ $is } else { return $match eq $is } } #----------------------------------------------------------------------------- 1; =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Editor::Clip - Internal class for Pinto::Editor =head1 VERSION version 0.14 =head1 DESCRIPTION This is a forked version of L which does not use the deprecated module L. My thanks to Robert Krimen for authoring the original. No user-servicable parts in here. =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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__ #----------------------------------------------------------------------------- Pinto-0.14/lib/Pinto/Editor/Edit.pm000644 000766 000024 00000017073 13141540305 017121 0ustar00jeffstaff000000 000000 # ABSTRACT: Internal class for Pinto::Editor package Pinto::Editor::Edit; use Moose; use Try::Tiny; use IO::File; use Pinto::Editor::Clip; #----------------------------------------------------------------------------- our $VERSION = '0.14'; # VERSION #----------------------------------------------------------------------------- our $EDITOR = 'Pinto::Editor'; our $RETRY = "__Pinto_Editor_retry__\n"; our $Test_edit; #----------------------------------------------------------------------------- has process => qw/ is ro isa Maybe[CodeRef] /; has separator => qw/ is rw /; has file => qw/ is ro required 1 /; has document => qw/ is rw isa Str required 1 /; has $_ => reader => $_, writer => "_$_", isa => 'Str' for qw/ initial_document /; has preamble => qw/ is rw isa Maybe[Str] /; has $_ => reader => $_, writer => "_$_", isa => 'Maybe[Str]' for qw/ initial_preamble /; has content => qw/ is rw isa Str /; has $_ => reader => $_, writer => "_$_", isa => 'Str' for qw/ initial_content /; #----------------------------------------------------------------------------- sub BUILD { my $self = shift; my $document = $self->document; $self->_initial_document( $document ); my ( $preamble, $content ) = $self->split( $document ); $self->preamble( $preamble ); $self->_initial_preamble( $preamble ); $self->content( $content ); $self->_initial_content( $content ); } #----------------------------------------------------------------------------- sub edit { my $self = shift; my $file = $self->file; my $tmp; if ( blessed $file ) { if ( $file->isa( 'IO::Handle' ) ) { $tmp = $file; } elsif ( $file->isa( 'Path::Class::File' ) ) { $tmp = $file->open( 'w' ) or die "Unable to open $file: $!"; } else { die "Invalid file: $file"; } } else { $file = '' unless defined $file; if ( ref $file ) { die "Invalid file: $file"; } elsif ( length $file ) { $tmp = IO::File->new( $file, 'w' ) or die "Unable to open $file: $!"; } else { die "Missing file"; } } $tmp->autoflush( 1 ); while ( 1 ) { $tmp->seek( 0, 0 ) or die "Unable to seek on tmp ($tmp): $!"; $tmp->truncate( 0 ) or die "Unable to truncate on tmp ($tmp): $!"; $tmp->print( $self->join( $self->preamble, $self->content ) ); if ( $Test_edit ) { $Test_edit->( $tmp ); } else { try { $EDITOR->edit_file( $tmp->filename ); } catch { my $error = $_[0]; warn "$error"; warn "*** There was an error editing ", $tmp->filename, "\n"; while ( 1 ) { print STDERR "Do you want to (c)ontinue, (a)bort, or (s)ave? "; my $input = ; chomp $input; die $error unless defined $input; if ( 0 ) { } elsif ( $input eq 'c' ) { last; } elsif ( $input eq 'a' ) { die $error; } elsif ( $input eq 's' ) { my $save; unless ( $save = File::Temp->new( dir => '.', template => 'PintoEditor.XXXXXX', unlink => 0 ) ) { warn "Unable to create temporary file: $!" and next; } my $tmp_filename = $tmp->filename; my $tmpr; unless ( $tmpr = IO::File->new( $tmp_filename, 'r' ) ) { warn "Unable to open ($tmp_filename): $!" and next; } $save->print( join '', <$tmpr> ); $save->close; warn "Saved to: ", $save->filename, " ", ( -s $save->filename ), "\n"; } else { warn "I don't understand ($input)\n"; } } }; } my $document; { my $filename = $tmp->filename; my $tmpr = IO::File->new( $filename, 'r' ) or die "Unable to open ($filename): $!"; $document = join '', <$tmpr>; $tmpr->close; undef $tmpr; } $self->document( $document ); my ( $preamble, $content ) = $self->split( $document ); $self->preamble( $preamble ); $self->content( $content ); if ( my $process = $self->process ) { my ( @result, $retry ); try { @result = $process->( $self ); } catch { die $_ unless $_ eq $RETRY; $retry = 1; }; next if $retry; return $result[0] if defined $result[0]; } return $content; } } #----------------------------------------------------------------------------- sub first_line_blank { my $self = shift; return $self->document =~ m/\A\s*$/m; } #----------------------------------------------------------------------------- sub line0_blank { return $_[0]->first_line_blank } #----------------------------------------------------------------------------- sub preamble_from_initial { my $self = shift; my @preamble; for my $part ( "$_[0]", $self->initial_preamble ) { next unless defined $part; chomp $part; push @preamble, $part; } $self->preamble( join "\n", @preamble, '' ) if @preamble; } #----------------------------------------------------------------------------- sub retry { my $self = shift; die $RETRY; } #----------------------------------------------------------------------------- sub split { my $self = shift; my $document = shift; return ( undef, $document ) unless my $separator = $self->separator; die "Invalid separator ($separator)" if ref $separator; if ( my $mark = Text::Clip->new( data => $document )->find( qr/^\s*$separator\s*$/m ) ) { return ( $mark->preceding, $mark->remaining ); } return ( undef, $document ); } #----------------------------------------------------------------------------- sub join { my $self = shift; my $preamble = shift; my $content = shift; return $content unless defined $preamble; chomp $preamble; my $separator = $self->separator; unless ( defined $separator ) { return $content unless length $preamble; return join "\n", $preamble, $content; } return join "\n", $separator, $content unless length $preamble; return join "\n", $preamble, $separator, $content; } #----------------------------------------------------------------------------- 1; =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Editor::Edit - Internal class for Pinto::Editor =head1 VERSION version 0.14 =head1 DESCRIPTION This is a forked version of L which does not use the deprecated module L. My thanks to Robert Krimen for authoring the original. No user-servicable parts in here. =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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__ #----------------------------------------------------------------------------- Pinto-0.14/lib/Pinto/Chrome/Net.pm000644 000766 000024 00000005543 13141540305 016750 0ustar00jeffstaff000000 000000 # ABSTRACT: Interface for network-based interaction package Pinto::Chrome::Net; use Moose; use MooseX::StrictConstructor; use MooseX::MarkAsMethods ( autoclean => 1 ); use Pinto::Types qw(Io); use Pinto::Util qw(itis); use Pinto::Constants qw(:protocol); #----------------------------------------------------------------------------- our $VERSION = '0.14'; # VERSION #----------------------------------------------------------------------------- extends qw( Pinto::Chrome::Term ); #----------------------------------------------------------------------------- has stdout => ( is => 'ro', isa => Io, required => 1, coerce => 1, ); has stderr => ( is => 'ro', isa => Io, required => 1, coerce => 1, ); #----------------------------------------------------------------------------- sub diag { my ( $self, $msg, $opts ) = @_; $opts ||= {}; $msg = $msg->() if ref $msg eq 'CODE'; if ( itis( $msg, 'Pinto::Exception' ) ) { # Show full stack trace if we are debugging $msg = $ENV{PINTO_DEBUG} ? $msg->as_string : $msg->message; } chomp $msg; $msg = $self->colorize( $msg, $opts->{color} ); $msg .= "\n" unless $opts->{no_newline}; # Prepend prefix to each line (not just at the start of the message) # The prefix is used by Pinto::Remote to distinguish between # messages that go to stderr and those that should go to stdout $msg =~ s/^/$PINTO_PROTOCOL_DIAG_PREFIX/gmx; print { $self->stderr } $msg or croak $!; } #----------------------------------------------------------------------------- sub show_progress { my ($self) = @_; return if not $self->should_render_progress; $self->stderr->autoflush; # Make sure pipes are hot print { $self->stderr } $PINTO_PROTOCOL_PROGRESS_MESSAGE . "\n" or croak $!; } #----------------------------------------------------------------------------- sub should_render_progress { my ($self) = @_; return 0 if $self->verbose; return 0 if $self->quiet; return 1; } #----------------------------------------------------------------------------- sub edit { my ( $self, $document ) = @_; return $document; # TODO! } #----------------------------------------------------------------------------- __PACKAGE__->meta->make_immutable; #----------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Chrome::Net - Interface for network-based interaction =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Chrome/Term.pm000644 000766 000024 00000014735 13141540305 017134 0ustar00jeffstaff000000 000000 # ABSTRACT: Interface for terminal-based interaction package Pinto::Chrome::Term; use Moose; use MooseX::StrictConstructor; use MooseX::Types::Moose qw(Bool ArrayRef Str); use MooseX::MarkAsMethods ( autoclean => 1 ); use Term::ANSIColor; use File::Which qw(which); use Pinto::Editor; use Pinto::Types qw(Io ANSIColorPalette); use Pinto::Util qw(user_palette itis throw is_interactive); #----------------------------------------------------------------------------- our $VERSION = '0.14'; # VERSION #----------------------------------------------------------------------------- extends qw( Pinto::Chrome ); #----------------------------------------------------------------------------- has color => ( is => 'ro', isa => Bool, default => sub { !$ENV{PINTO_NO_COLOR} }, ); has palette => ( is => 'ro', isa => ANSIColorPalette, default => sub { user_palette() }, lazy => 1, ); has stdout => ( is => 'ro', isa => Io, builder => '_build_stdout', coerce => 1, lazy => 1, ); has stderr => ( is => 'ro', isa => Io, default => sub { [ fileno(*STDERR), '>' ] }, coerce => 1, lazy => 1, ); has has_made_progress => ( is => 'rw', isa => Bool, default => 0, ); #----------------------------------------------------------------------------- sub _build_stdout { my ($self) = @_; my $pager = $ENV{PINTO_PAGER} || $ENV{PAGER}; my $stdout = [ fileno(*STDOUT), '>' ]; return $stdout if not -t STDOUT; return $stdout if not $pager; my @pager_options = $ENV{PINTO_PAGER_OPTIONS} ? ( $ENV{PINTO_PAGER_OPTIONS} ) : (); open my $pager_fh, q<|->, $pager, @pager_options or throw "Failed to open pipe to pager $pager: $!"; my $io = bless $pager_fh, 'IO::Handle'; # HACK! $io->autoflush(1); return $io; } #------------------------------------------------------------------------------ sub show { my ( $self, $msg, $opts ) = @_; $opts ||= {}; $msg = $self->colorize( $msg, $opts->{color} ); $msg .= "\n" unless $opts->{no_newline}; print { $self->stdout } $msg or croak $!; return $self; } #----------------------------------------------------------------------------- sub diag { my ( $self, $msg, $opts ) = @_; $opts ||= {}; return if $self->quiet; $msg = $msg->() if ref $msg eq 'CODE'; if ( itis( $msg, 'Pinto::Exception' ) ) { # Show full stack trace if we are debugging $msg = $ENV{PINTO_DEBUG} ? $msg->as_string : $msg->message; } chomp $msg; $msg = $self->colorize( $msg, $opts->{color} ); $msg .= "\n" unless $opts->{no_newline}; print { $self->stderr } $msg or croak $!; } #----------------------------------------------------------------------------- sub show_progress { my ($self) = @_; return if not $self->should_render_progress; $self->stderr->autoflush; # Make sure pipes are hot print { $self->stderr } '.' or croak $!; $self->has_made_progress(1); } #----------------------------------------------------------------------------- sub progress_done { my ($self) = @_; return unless $self->has_made_progress; return unless $self->should_render_progress; print { $self->stderr } "\n" or croak $!; } #----------------------------------------------------------------------------- sub should_render_progress { my ($self) = @_; return 0 if $self->verbose; return 0 if $self->quiet; return 0 if not is_interactive; return 1; } #----------------------------------------------------------------------------- sub edit { my ( $self, $document ) = @_; local $ENV{VISUAL} = $self->find_editor or throw 'Unable to find an editor. Please set PINTO_EDITOR'; # If this command is reading input from a pipe or file, then # STDIN will not be connected to a terminal. This causes vim # and emacs to behave oddly (or even segfault). After searching # the internets, this seems to a portable way to reconnect STDIN # to the actual terminal. I haven't actually tried it on Windows. # I'm not sure if/how I should be localizing STDIN here. my $term = ( $^O eq 'MSWin32' ) ? 'CON' : '/dev/tty'; open( STDIN, '<', $term ) or throw $!; return Pinto::Editor->edit( document => $document ); } #----------------------------------------------------------------------------- sub colorize { my ( $self, $string, $color_number ) = @_; return '' if not $string; return $string if not defined $color_number; return $string if not $self->color; my $color = $self->get_color($color_number); return $color . $string . Term::ANSIColor::color('reset'); } #----------------------------------------------------------------------------- sub get_color { my ( $self, $color_number ) = @_; return '' if not defined $color_number; my $color = $self->palette->[$color_number]; throw "Invalid color number: $color_number" if not defined $color; return Term::ANSIColor::color($color); } #----------------------------------------------------------------------------- sub find_editor { my ($self) = @_; # Try unsing environment variables first for my $env_var (qw(PINTO_EDITOR VISUAL EDITOR)) { return $ENV{$env_var} if $ENV{$env_var}; } # Then try typical editor commands for my $cmd (qw(nano pico vi)) { my $found_cmd = which($cmd); return $found_cmd if $found_cmd; } return; } #----------------------------------------------------------------------------- my %color_map = ( warning => 1, error => 2 ); while ( my ( $level, $color ) = each %color_map ) { around $level => sub { my ( $orig, $self, $msg, $opts ) = @_; $opts ||= {}; $opts->{color} = $color; return $self->$orig( $msg, $opts ); }; } #----------------------------------------------------------------------------- __PACKAGE__->meta->make_immutable; #----------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Chrome::Term - Interface for terminal-based interaction =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Action/Add.pm000644 000766 000024 00000012016 13141540305 016703 0ustar00jeffstaff000000 000000 # ABSTRACT: Add a local distribution into the repository package Pinto::Action::Add; use Moose; use MooseX::StrictConstructor; use MooseX::Types::Moose qw(Bool ArrayRef Str); use MooseX::MarkAsMethods ( autoclean => 1 ); use Try::Tiny; use Pinto::Util qw(sha256 current_author_id throw); use Pinto::Types qw(AuthorID FileList); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ has author => ( is => 'ro', isa => AuthorID, default => sub { $_[0]->pausecfg->{user} || current_author_id }, coerce => 1, lazy => 1, ); has archives => ( isa => FileList, traits => [qw(Array)], handles => { archives => 'elements' }, required => 1, coerce => 1, ); has no_fail => ( is => 'ro', isa => Bool, default => 0, ); has no_index => ( is => 'ro', isa => ArrayRef [Str], default => sub { [] } ); #------------------------------------------------------------------------------ with qw( Pinto::Role::PauseConfig Pinto::Role::Committable Pinto::Role::Puller ); #------------------------------------------------------------------------------ sub BUILD { my ( $self, $args ) = @_; my @missing = grep { not -e $_ } $self->archives; $self->error("Archive $_ does not exist") for @missing; my @unreadable = grep { -e $_ and not -r $_ } $self->archives; $self->error("Archive $_ is not readable") for @unreadable; throw "Some archives are missing or unreadable" if @missing or @unreadable; return $self; } #------------------------------------------------------------------------------ sub execute { my ($self) = @_; for my $archive ( $self->archives ) { try { $self->repo->svp_begin; my $dist = $self->_add($archive); push @{$self->affected}, $dist if $dist; } catch { throw $_ unless $self->no_fail; $self->result->failed( because => $_ ); $self->repo->svp_rollback; $self->error("$_"); $self->error("Archive $archive failed...continuing anyway"); } finally { my ($error) = @_; $self->repo->svp_release unless $error; }; } $self->chrome->progress_done; return $self; } #------------------------------------------------------------------------------ sub _add { my ( $self, $archive ) = @_; my $dist; if ( my $dupe = $self->_check_for_duplicate($archive) ) { $self->warning("$archive is the same as $dupe -- using $dupe instead"); $dist = $dupe; } else { $self->info("Adding $archive to the repository"); $dist = $self->repo->add_distribution( archive => $archive, author => $self->author ); $self->_apply_exclusions($dist); } $self->notice( "Registering $dist on stack " . $self->stack ); ($dist, undef, undef) = $self->pull( target => $dist ); # Registers dist and pulls prereqs return $dist; } #------------------------------------------------------------------------------ sub _check_for_duplicate { my ( $self, $archive ) = @_; my $sha256 = sha256($archive); my $dupe = $self->repo->db->schema->search_distribution( { sha256 => $sha256 } )->first; return if not defined $dupe; return $dupe if $archive->basename eq $dupe->archive; throw "Archive $archive is the same as $dupe but with different name"; } #----------------------------------------------------------------------------- sub _apply_exclusions { my ( $self, $dist ) = @_; my @rules = map { s/^\/// ? qr/$_/ : $_ } @{ $self->no_index }; my $matcher = sub { my ( $rule, $pkg ) = @_; return ref $rule eq 'Regexp' ? $pkg->name =~ $rule : $pkg->name eq $rule; }; my @pkgs = $dist->packages; for my $rule (@rules) { for my $pkg (@pkgs) { next unless $matcher->( $rule, $pkg ); $self->warning("Excluding matching package $pkg from index"); $pkg->delete; } } throw "Distribution $dist has no packages left" if $dist->packages->count == 0; return $self; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #----------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Action::Add - Add a local distribution into the repository =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Action/Clean.pm000644 000766 000024 00000002451 13141540305 017237 0ustar00jeffstaff000000 000000 # ABSTRACT: Remove orphaned archives package Pinto::Action::Clean; use Moose; use MooseX::StrictConstructor; use MooseX::MarkAsMethods ( autoclean => 1 ); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ sub execute { my ($self) = @_; $self->repo->optimize_database; my $did_delete = $self->repo->clean_files; $self->result->changed if $did_delete; return $self->result; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #----------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Action::Clean - Remove orphaned archives =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Action/Copy.pm000644 000766 000024 00000004534 13141540305 017133 0ustar00jeffstaff000000 000000 # ABSTRACT: Create a new stack by copying another package Pinto::Action::Copy; use Moose; use MooseX::StrictConstructor; use MooseX::Types::Moose qw(Bool Str); use MooseX::MarkAsMethods ( autoclean => 1 ); use Pinto::Types qw(StackName StackObject); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ with qw( Pinto::Role::Transactional ); #------------------------------------------------------------------------------ has stack => ( is => 'ro', isa => StackName | StackObject, required => 1, ); has to_stack => ( is => 'ro', isa => StackName, required => 1, ); has default => ( is => 'ro', isa => Bool, default => 0, ); has lock => ( is => 'ro', isa => Bool, default => 0, ); has description => ( is => 'ro', isa => Str, predicate => 'has_description', ); #------------------------------------------------------------------------------ sub execute { my ($self) = @_; my %changes = ( name => $self->to_stack ); my $orig = $self->repo->get_stack( $self->stack ); my $copy = $self->repo->copy_stack( stack => $orig, %changes ); my $description = $self->has_description ? $self->description : "Copy of stack $orig"; $copy->set_description($description); $copy->mark_as_default if $self->default; $copy->lock if $self->lock; return $self->result->changed; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Action::Copy - Create a new stack by copying another =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Action/Default.pm000644 000766 000024 00000003677 13141540305 017614 0ustar00jeffstaff000000 000000 # ABSTRACT: Set the default stack package Pinto::Action::Default; use Moose; use MooseX::StrictConstructor; use MooseX::Types::Moose qw(Bool); use MooseX::MarkAsMethods ( autoclean => 1 ); use Pinto::Types qw(StackName StackObject); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ with qw( Pinto::Role::Transactional ); #------------------------------------------------------------------------------ has stack => ( is => 'ro', isa => StackName | StackObject, ); has none => ( is => 'ro', isa => Bool, default => 0, ); #------------------------------------------------------------------------------ sub execute { my ($self) = @_; if ( $self->none ) { my $default_stack = $self->repo->get_stack; return $self->result if not defined $default_stack; $default_stack->unmark_as_default; } else { my $stack = $self->repo->get_stack( $self->stack ); return $self->result if $stack->is_default; $stack->mark_as_default; } return $self->result->changed; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Action::Default - Set the default stack =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Action/Delete.pm000644 000766 000024 00000004130 13141540305 017413 0ustar00jeffstaff000000 000000 # ABSTRACT: Delete archives from the repository package Pinto::Action::Delete; use Moose; use MooseX::StrictConstructor; use MooseX::Types::Moose qw(Bool); use MooseX::MarkAsMethods ( autoclean => 1 ); use Pinto::Util qw(throw); use Pinto::Types qw(DistributionTargetList); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ with qw( Pinto::Role::Transactional ); #------------------------------------------------------------------------------ has targets => ( isa => DistributionTargetList, traits => [qw(Array)], handles => { targets => 'elements' }, required => 1, coerce => 1, ); has force => ( is => 'ro', isa => Bool, default => 0, ); #------------------------------------------------------------------------------ sub execute { my ($self) = @_; for my $target ( $self->targets ) { my $dist = $self->repo->get_distribution( target => $target ); throw "Distribution $target is not in the repository" if not defined $dist; $self->notice("Deleting $dist from the repository"); $self->repo->delete_distribution( dist => $dist, force => $self->force ); } return $self->result->changed; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Action::Delete - Delete archives from the repository =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Action/Diff.pm000644 000766 000024 00000006624 13141540305 017073 0ustar00jeffstaff000000 000000 # ABSTRACT: Show the difference between stacks or revisions package Pinto::Action::Diff; use Moose; use MooseX::Aliases; use MooseX::StrictConstructor; use MooseX::MarkAsMethods ( autoclean => 1 ); use MooseX::Types::Moose qw(Bool Str); use Pinto::Difference; use Pinto::Constants qw(:color :diff); use Pinto::Types qw(StackName StackDefault StackObject RevisionID DiffStyle); use Pinto::Util qw(throw default_diff_style); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ has left => ( is => 'ro', isa => StackName | StackObject | StackDefault | RevisionID, default => undef, ); has right => ( is => 'ro', isa => StackName | StackObject | RevisionID, required => 1, ); has style => ( is => 'ro', isa => DiffStyle, alias => 'diff_style', default => \&default_diff_style, lazy => 1, ); has format => ( is => 'ro', isa => Str, builder => '_build_format', ); sub _build_format { my ($self) = @_; return $self->style eq $PINTO_DIFF_STYLE_DETAILED ? '%o[%F] %-40p %12v %a/%f' : '%o[%F] %a/%f'; } #------------------------------------------------------------------------------ sub execute { my ($self) = @_; my $error_message = qq{"%s" does not match any stack or revision}; my $left = $self->repo->get_stack_maybe( $self->left ) || $self->repo->get_revision_maybe( $self->left ) || throw sprintf $error_message, $self->left; my $right = $self->repo->get_stack_maybe( $self->right ) || $self->repo->get_revision_maybe( $self->right ) || throw sprintf $error_message, $self->right; my $diff = Pinto::Difference->new( left => $left, right => $right, style => $self->style ); # TODO: Extract the colorizing & formatting code into a separate # class that can be reused. Maybe subclassed for HTML and text. if ( $diff->is_different ) { $self->show( "--- $left", { color => $PINTO_PALETTE_COLOR_1 } ); $self->show( "+++ $right", { color => $PINTO_PALETTE_COLOR_1 } ); } for my $entry ( $diff->entries ) { my $color = $entry->is_addition ? $PINTO_PALETTE_COLOR_0 : $PINTO_PALETTE_COLOR_2; my $string = $entry->to_string( $self->format ); $self->show( $string, { color => $color } ); } $self->notice('No difference') if not $diff->is_different; return $self->result; } #------------------------------------------------------------------------------- __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Action::Diff - Show the difference between stacks or revisions =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Action/Install.pm000644 000766 000024 00000004737 13141540305 017634 0ustar00jeffstaff000000 000000 # ABSTRACT: Install packages from the repository package Pinto::Action::Install; use Moose; use MooseX::StrictConstructor; use MooseX::Types::Moose qw(Bool ArrayRef Str); use MooseX::MarkAsMethods ( autoclean => 1 ); use Pinto::Target; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ has targets => ( isa => ArrayRef [Str], traits => ['Array'], handles => { targets => 'elements' }, required => 1, ); has do_pull => ( is => 'ro', isa => Bool, default => 0, ); has mirror_uri => ( is => 'ro', isa => Str, builder => '_build_mirror_uri', lazy => 1, ); #------------------------------------------------------------------------------ with qw( Pinto::Role::Committable Pinto::Role::Puller Pinto::Role::Installer); #------------------------------------------------------------------------------ sub _build_mirror_uri { my ($self) = @_; my $stack = $self->stack; my $stack_dir = defined $stack ? "/stacks/$stack" : ''; my $mirror_uri = 'file://' . $self->repo->root->absolute . $stack_dir; return $mirror_uri; } #------------------------------------------------------------------------------ sub execute { my ($self) = @_; my @dists; if ( $self->do_pull ) { for my $target ( $self->targets ) { next if -d $target or -f $target; require Pinto::Target; $target = Pinto::Target->new($target); my $dist = $self->pull( target => $target ); push @dists, $dist ? $dist : (); } } return @dists; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #----------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Action::Install - Install packages from the repository =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Action/Kill.pm000644 000766 000024 00000003447 13141540305 017116 0ustar00jeffstaff000000 000000 # ABSTRACT: Permanently delete a stack package Pinto::Action::Kill; use Moose; use MooseX::StrictConstructor; use MooseX::Types::Moose qw(Bool); use MooseX::MarkAsMethods ( autoclean => 1 ); use Pinto::Types qw(StackName StackObject); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ with qw( Pinto::Role::Transactional ); #------------------------------------------------------------------------------ has stack => ( is => 'ro', isa => StackName | StackObject, required => 1, ); has force => ( is => 'ro', isa => Bool, default => 0, ); #------------------------------------------------------------------------------ sub execute { my ($self) = @_; my $stack = $self->repo->get_stack( $self->stack ); $stack->unlock if $stack->is_locked && $self->force; $self->repo->kill_stack( stack => $stack ); return $self->result->changed; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Action::Kill - Permanently delete a stack =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Action/List.pm000644 000766 000024 00000010540 13141540305 017126 0ustar00jeffstaff000000 000000 # ABSTRACT: List the contents of a stack package Pinto::Action::List; use Moose; use MooseX::StrictConstructor; use MooseX::MarkAsMethods ( autoclean => 1 ); use MooseX::Types::Moose qw(Str Bool); use Pinto::Constants qw(:color); use Pinto::Types qw(StackName StackDefault StackObject); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ has stack => ( is => 'ro', isa => StackName | StackDefault | StackObject, default => undef, ); has pinned => ( is => 'ro', isa => Bool, ); has authors => ( is => 'ro', isa => Str, ); has packages => ( is => 'ro', isa => Str, ); has distributions => ( is => 'ro', isa => Str, ); has all => ( is => 'ro', isa => Bool, default => 0, ); has format => ( is => 'ro', isa => Str, default => '[%F] %-40p %12v %a/%f', lazy => 1, ); #------------------------------------------------------------------------------ sub _where { my ($self) = @_; my $where = {}; if ($self->all) { if ( my $pkg_name = $self->packages ) { $where->{'me.name'} = {regexp => qr/$pkg_name/ }; } if ( my $dist_name = $self->distributions ) { $where->{'distribution.archive'} = {regexp => qr/$dist_name/}; } if ( my $authors = $self->authors ) { $where->{'distribution.author'} = {regexp => qr/$authors/i}; } } else { my $stack = $self->repo->get_stack( $self->stack ); $where = {revision => $stack->head->id}; if ( my $pkg_name = $self->packages ) { $where->{'package.name'} = {regexp => qr/$pkg_name/}; } if ( my $dist_name = $self->distributions ) { $where->{'distribution.archive'} = {regexp => qr/$dist_name/}; } if ( my $authors = $self->authors ) { $where->{'distribution.author'} = {regexp => qr/$authors/i}; } if ( my $pinned = $self->pinned ) { $where->{is_pinned} = 1; } } return $where; } #------------------------------------------------------------------------------ sub _attrs { my ($self) = @_; my $attrs = {}; if ($self->all) { $attrs = { prefetch => [qw(distribution)], order_by => ['me.name'] }; } else { $attrs = { prefetch => [qw(package distribution)] }; } return $attrs; } #------------------------------------------------------------------------------ sub execute { my ($self) = @_; my $where = $self->_where; my $attrs = $self->_attrs; my $method = 'search_' . ($self->all ? 'package' : 'registration'); my $rs = $self->repo->db->schema->$method( $where, $attrs ); my $did_match = 0; while ( my $it = $rs->next ) { # $it could be a registration or a package object, depending # on whether we are listing a stack or the whole repository my $string = $it->to_string( $self->format ); my $color = undef; $color = $PINTO_PALETTE_COLOR_0 if $it->distribution->is_local; $color = $PINTO_PALETTE_COLOR_1 if $it->isa('Pinto::Schema::Result::Registration') && $it->is_pinned; $self->show( $string, { color => $color } ); $did_match++; } # If there are any search criteria and nothing matched, # then the exit status should not be successful. $self->result->failed if keys %$where > 1 && !$did_match; return $self->result; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Action::List - List the contents of a stack =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Action/Lock.pm000644 000766 000024 00000003417 13141540305 017110 0ustar00jeffstaff000000 000000 # ABSTRACT: Lock a stack to prevent future changes package Pinto::Action::Lock; use Moose; use MooseX::StrictConstructor; use MooseX::MarkAsMethods ( autoclean => 1 ); use Pinto::Types qw(StackName StackDefault StackObject); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ with qw( Pinto::Role::Transactional ); #------------------------------------------------------------------------------ has stack => ( is => 'ro', isa => StackName | StackDefault | StackObject, default => undef, ); #------------------------------------------------------------------------------ sub execute { my ($self) = @_; my $stack = $self->repo->get_stack( $self->stack ); if ( $stack->is_locked ) { $self->warning("Stack $stack is already locked"); return $self->result; } $stack->lock; return $self->result->changed; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Action::Lock - Lock a stack to prevent future changes =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Action/Log.pm000644 000766 000024 00000004644 13141540305 016744 0ustar00jeffstaff000000 000000 # ABSTRACT: Show revision log for a stack package Pinto::Action::Log; use Moose; use MooseX::StrictConstructor; use MooseX::Types::Moose qw(Str Bool); use MooseX::MarkAsMethods ( autoclean => 1 ); use Pinto::Difference; use Pinto::RevisionWalker; use Pinto::Constants qw(:color); use Pinto::Types qw(StackName StackDefault DiffStyle); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ has stack => ( is => 'ro', isa => StackName | StackDefault, default => undef, ); has with_diffs => ( is => 'ro', isa => Bool, default => 0, ); has diff_style => ( is => 'ro', isa => DiffStyle, predicate => 'has_diff_style', ); #------------------------------------------------------------------------------ sub execute { my ($self) = @_; my $stack = $self->repo->get_stack( $self->stack ); my $walker = Pinto::RevisionWalker->new( start => $stack->head ); while ( my $revision = $walker->next ) { my $revid = $revision->to_string("revision %I"); $self->show( $revid, { color => $PINTO_PALETTE_COLOR_1 } ); my $rest = $revision->to_string("Date: %u\nUser: %j\n\n%{4}G\n"); $self->show($rest); if ($self->with_diffs) { my $parent = ($revision->parents)[0]; local $ENV{PINTO_DIFF_STYLE} = $self->diff_style if $self->has_diff_style; my $diff = Pinto::Difference->new(left => $parent, right => $revision); $self->show($diff); } } return $self->result; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Action::Log - Show revision log for a stack =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Action/Look.pm000644 000766 000024 00000004445 13141540305 017126 0ustar00jeffstaff000000 000000 # ABSTRACT: Unpack and open a distribution with your shell package Pinto::Action::Look; use Moose; use MooseX::StrictConstructor; use MooseX::MarkAsMethods ( autoclean => 1 ); use Pinto::Shell; use Pinto::Util qw(throw); use Pinto::Types qw(StackName StackDefault TargetList); use Path::Class qw(file); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ has stack => ( is => 'ro', isa => StackName | StackDefault, default => undef, ); has targets => ( isa => TargetList, traits => [qw(Array)], handles => { targets => 'elements' }, required => 1, coerce => 1, ); #------------------------------------------------------------------------------ sub execute { my ($self) = @_; my $stack = $self->repo->get_stack($self->stack); for my $target ( $self->targets ) { my $dist; if ($target->isa('Pinto::Target::Package')) { $dist = $stack->get_distribution( target => $target ) or throw "Target $target is not in stack $stack"; } else { $dist = $self->repo->get_distribution( target => $target ) or throw "Target $target is not in the repository"; } my $shell = Pinto::Shell->new( archive => $dist->native_path ); $self->diag("Entering $dist with $shell\n"); $shell->spawn; } return $self->result; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Action::Look - Unpack and open a distribution with your shell =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Action/Merge.pm000644 000766 000024 00000004647 13141540305 017265 0ustar00jeffstaff000000 000000 # ABSTRACT: Join two stack histories together package Pinto::Action::Merge; use Moose; use MooseX::StrictConstructor; use MooseX::Types::Moose qw(Bool); use MooseX::MarkAsMethods ( autoclean => 1 ); use Pinto::Util qw(throw); use Pinto::Types qw(StackName StackObject StackDefault); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ with qw( Pinto::Role::Transactional ); #------------------------------------------------------------------------------ has stack => ( is => 'ro', isa => StackName | StackObject, required => 1, ); has into_stack => ( is => 'ro', isa => StackName | StackObject | StackDefault, default => undef, ); #------------------------------------------------------------------------------ sub execute { my ($self) = @_; my $stack = $self->repo->get_stack($self->stack); my $from_head = $stack->head; my $into_stack = $self->repo->get_stack($self->into_stack); my $into_head = $into_stack->head; return 1 && $self->warning("Both stacks are the same ($into_head)") if $into_head->id == $from_head->id; throw "Recursive merge is not supported yet" unless $from_head->is_descendant_of($into_head); $into_stack->update({head => $from_head->id}); $into_stack->write_index; my $format = '%i: %{40}T'; $self->diag("Fast-forward..."); $self->diag("Stack $into_stack was " . $into_head->to_string($format)); $self->diag("Stack $into_stack now " . $from_head->to_string($format)); return 1; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Action::Merge - Join two stack histories together =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Action/New.pm000644 000766 000024 00000004442 13141540305 016750 0ustar00jeffstaff000000 000000 # ABSTRACT: Create a new empty stack package Pinto::Action::New; use Moose; use MooseX::StrictConstructor; use MooseX::Types::Moose qw(Bool Str); use MooseX::MarkAsMethods ( autoclean => 1 ); use Pinto::Types qw(StackName PerlVersion); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ with qw( Pinto::Role::Transactional ); #------------------------------------------------------------------------------ has stack => ( is => 'ro', isa => StackName, required => 1, ); has default => ( is => 'ro', isa => Bool, default => 0, ); has description => ( is => 'ro', isa => Str, predicate => 'has_description', ); has target_perl_version => ( is => 'ro', isa => PerlVersion, predicate => 'has_target_perl_version', coerce => 1, ); #------------------------------------------------------------------------------ sub execute { my ($self) = @_; my %attrs = ( name => $self->stack ); my $stack = $self->repo->create_stack(%attrs); $stack->set_properties( $stack->default_properties ); $stack->set_property( description => $self->description ) if $self->has_description; $stack->set_property( target_perl_version => $self->target_perl_version ) if $self->has_target_perl_version; $stack->mark_as_default if $self->default; return $self->result->changed; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Action::New - Create a new empty stack =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Action/Nop.pm000644 000766 000024 00000003211 13141540305 016744 0ustar00jeffstaff000000 000000 # ABSTRACT: A no-op action package Pinto::Action::Nop; use Moose; use MooseX::StrictConstructor; use MooseX::Types::Moose qw(Int); use MooseX::MarkAsMethods ( autoclean => 1 ); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ has sleep => ( is => 'ro', isa => Int, default => 0, ); #------------------------------------------------------------------------------ sub execute { my ($self) = @_; if ( my $sleep = $self->sleep ) { $self->notice("Process $$ sleeping for $sleep seconds"); sleep $self->sleep; } return $self->result; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable(); #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Action::Nop - A no-op action =head1 VERSION version 0.14 =head1 DESCRIPTION This action does nothing. It can be used to get Pinto to initialize the store and load the indexes without performing any real operations on them. =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Action/Pin.pm000644 000766 000024 00000004111 13141540305 016736 0ustar00jeffstaff000000 000000 # ABSTRACT: Force a package to stay in a stack package Pinto::Action::Pin; use Moose; use MooseX::StrictConstructor; use MooseX::MarkAsMethods ( autoclean => 1 ); use Pinto::Util qw(throw); use Pinto::Types qw(TargetList); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ has targets => ( isa => TargetList, traits => [qw(Array)], handles => { targets => 'elements' }, required => 1, coerce => 1, ); #------------------------------------------------------------------------------ with qw( Pinto::Role::Committable ); #------------------------------------------------------------------------------ sub execute { my ($self) = @_; my $stack = $self->stack; for my $target ( $self->targets ) { throw "$target is not registered on stack $stack" unless my $dist = $stack->get_distribution( target => $target ); $self->notice("Pinning distribution $dist to stack $stack"); my $did_pin = $dist->pin( stack => $stack ); push @{$self->affected}, $dist if $did_pin; $self->warning("Distribution $dist is already pinned to stack $stack") unless $did_pin; } return $self; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Action::Pin - Force a package to stay in a stack =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Action/Props.pm000644 000766 000024 00000005302 13141540305 017316 0ustar00jeffstaff000000 000000 # ABSTRACT: Show or change stack properties package Pinto::Action::Props; use Moose; use MooseX::StrictConstructor; use MooseX::MarkAsMethods ( autoclean => 1 ); use MooseX::Types::Moose qw(Str HashRef); use String::Format qw(stringf); use Pinto::Constants qw(:color); use Pinto::Util qw(is_system_prop); use Pinto::Types qw(StackName StackDefault StackObject); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ with qw( Pinto::Role::Transactional ); #------------------------------------------------------------------------------ has stack => ( is => 'ro', isa => StackName | StackDefault | StackObject, ); has properties => ( is => 'ro', isa => HashRef, predicate => 'has_properties', ); has format => ( is => 'ro', isa => Str, default => "%p = %v", ); #------------------------------------------------------------------------------ sub execute { my ($self) = @_; my $stack = $self->repo->get_stack( $self->stack ); $self->has_properties ? $self->_set_properties($stack) : $self->_show_properties($stack); return $self->result; } #------------------------------------------------------------------------------ sub _set_properties { my ( $self, $target ) = @_; $target->set_properties( $self->properties ); $self->result->changed; return; } #------------------------------------------------------------------------------ sub _show_properties { my ( $self, $target ) = @_; my $props = $target->get_properties; while ( my ( $prop, $value ) = each %{$props} ) { my $string = stringf( $self->format, { p => $prop, v => $value } ); my $color = is_system_prop($prop) ? $PINTO_PALETTE_COLOR_2 : undef; $self->show( $string, { color => $color } ); } return; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Action::Props - Show or change stack properties =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Action/Pull.pm000644 000766 000024 00000005165 13141540305 017136 0ustar00jeffstaff000000 000000 # ABSTRACT: Pull upstream distributions into the repository package Pinto::Action::Pull; use Moose; use MooseX::StrictConstructor; use MooseX::Types::Moose qw(Bool); use MooseX::MarkAsMethods ( autoclean => 1 ); use Try::Tiny; use Pinto::Util qw(throw); use Pinto::Types qw(TargetList); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ has targets => ( isa => TargetList, traits => [qw(Array)], handles => { targets => 'elements' }, required => 1, coerce => 1, ); has no_fail => ( is => 'ro', isa => Bool, default => 0, ); #------------------------------------------------------------------------------ with qw( Pinto::Role::Committable Pinto::Role::Puller ); #------------------------------------------------------------------------------ sub execute { my ($self) = @_; my $stack = $self->stack; for my $target ( $self->targets ) { try { $self->repo->svp_begin; $self->notice( "Pulling target $target to stack $stack"); my ($dist, $did_pull, $did_pull_prereqs) = $self->pull( target => $target ); $self->notice("Target $target is already on stack $stack") unless $did_pull; push @{$self->affected}, $dist if $did_pull || $did_pull_prereqs; } catch { throw $_ unless $self->no_fail; $self->result->failed( because => $_ ); $self->repo->svp_rollback; $self->error($_); $self->error("Target $target failed...continuing anyway"); } finally { my ($error) = @_; $self->repo->svp_release unless $error; }; } $self->chrome->progress_done; return $self; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Action::Pull - Pull upstream distributions into the repository =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Action/Register.pm000644 000766 000024 00000004465 13141540305 020010 0ustar00jeffstaff000000 000000 # ABSTRACT: Register packages from existing archives on a stack package Pinto::Action::Register; use Moose; use MooseX::StrictConstructor; use MooseX::Types::Moose qw(Bool); use MooseX::MarkAsMethods ( autoclean => 1 ); use Pinto::Util qw(throw); use Pinto::Types qw(DistributionTargetList); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ has targets => ( isa => DistributionTargetList, traits => [qw(Array)], handles => { targets => 'elements' }, required => 1, coerce => 1, ); has pin => ( is => 'ro', isa => Bool, default => 0, ); #------------------------------------------------------------------------------ with qw( Pinto::Role::Committable ); #------------------------------------------------------------------------------ sub execute { my ($self) = @_; my $stack = $self->stack; for my $target ( $self->targets ) { throw "Distribution $target is not in the repository" unless my $dist = $self->repo->get_distribution( target => $target ); $self->notice("Registering distribution $dist on stack $stack"); my $did_register = $dist->register( stack => $stack, pin => $self->pin ); push @{$self->affected}, $dist if $did_register; $self->warning("Distribution $dist is already registered on stack $stack") unless $did_register; } return $self; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Action::Register - Register packages from existing archives on a stack =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Action/Rename.pm000644 000766 000024 00000003362 13141540305 017426 0ustar00jeffstaff000000 000000 # ABSTRACT: Change the name of a stack package Pinto::Action::Rename; use Moose; use MooseX::StrictConstructor; use MooseX::MarkAsMethods ( autoclean => 1 ); use Pinto::Types qw(StackName StackObject); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ with qw( Pinto::Role::Transactional ); #------------------------------------------------------------------------------ has stack => ( is => 'ro', isa => StackName | StackObject, required => 1, ); has to_stack => ( is => 'ro', isa => StackName, required => 1, ); #------------------------------------------------------------------------------ sub execute { my ($self) = @_; my $stack = $self->repo->get_stack( $self->stack ); $self->repo->rename_stack( stack => $stack, to => $self->to_stack ); return $self->result->changed; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Action::Rename - Change the name of a stack =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Action/Reset.pm000644 000766 000024 00000004522 13141540305 017300 0ustar00jeffstaff000000 000000 # ABSTRACT: Reset stack to a prior revision package Pinto::Action::Reset; use Moose; use MooseX::StrictConstructor; use MooseX::Types::Moose qw(Bool); use MooseX::MarkAsMethods ( autoclean => 1 ); use Pinto::Util qw(throw); use Pinto::Types qw(StackName StackDefault RevisionID); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ with qw( Pinto::Role::Transactional ); #------------------------------------------------------------------------------ has stack => ( is => 'ro', isa => StackName | StackDefault, default => undef, ); has revision => ( is => 'ro', isa => RevisionID, required => 1, coerce => 1, ); has force => ( is => 'ro', isa => Bool, default => 0, ); #------------------------------------------------------------------------------ sub execute { my ($self) = @_; my $rev = $self->repo->get_revision($self->revision); my $stack = $self->repo->get_stack($self->stack); my $head = $stack->head; throw "Revision $rev is the head of stack $stack" if $rev->id == $head->id; throw "Revision $rev is not an ancestor of stack $stack" if !$rev->is_ancestor_of($head) && !$self->force; $stack->set_head($rev); $stack->write_index; my $format = '%i: %{40}T'; $self->diag("Stack $stack was " . $head->to_string($format)); $self->diag("Stack $stack now " . $rev->to_string($format)); return 1; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Action::Reset - Reset stack to a prior revision =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Action/Revert.pm000644 000766 000024 00000006366 13141540305 017475 0ustar00jeffstaff000000 000000 # ABSTRACT: Revert stack to a prior revision package Pinto::Action::Revert; use Moose; use MooseX::StrictConstructor; use MooseX::Types::Moose qw(Bool); use MooseX::MarkAsMethods ( autoclean => 1 ); use Pinto::Util qw(throw); use Pinto::Types qw(RevisionID RevisionHead); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ with qw( Pinto::Role::Committable ); #------------------------------------------------------------------------------ has revision => ( is => 'ro', isa => RevisionID | RevisionHead, default => undef, coerce => 1, ); has force => ( is => 'ro', isa => Bool, default => 0, ); #------------------------------------------------------------------------------ sub execute { my ($self) = @_; # Remember that the Committable role has already moved the head # forward to a new revision which is a duplicate of the last head. my $stack = $self->stack; my $new_head = $stack->head; my $old_head = ($new_head->parents)[0]; my $rev = $self->revision ? $self->repo->get_revision($self->revision) : ($old_head->parents)[0]; throw "Cannot revert past the root commit" if not $rev; throw "Revision $rev is the head of stack $stack" if $rev eq $old_head; throw "Revision $rev is not an ancestor of stack $stack" if !$rev->is_ancestor_of($old_head) && !$self->force; $new_head->registrations_rs->delete; $stack->duplicate_registrations(to => $new_head, from => $rev); # We must explicitly mark the stack as changed, snce we injected the # registrations directly. But it is possible that the new state is # exactly the same as the old state. So we use the diff to be sure. $stack->diff->is_different ? $stack->mark_as_changed : throw "Revision $rev is identical to the head of stack $stack"; return 1; } #------------------------------------------------------------------------------ sub generate_message_title { my ($self) = @_; # TODO: fix duplication... my $stack = $self->stack; my $new_head = $stack->head; my $old_head = ($new_head->parents)[0]; my $rev = $self->revision ? $self->repo->get_revision($self->revision) : ($old_head->parents)[0]; return sprintf "Revert to %s: %s", $rev->uuid_prefix, $rev->message_title; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Action::Revert - Revert stack to a prior revision =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Action/Roots.pm000644 000766 000024 00000003360 13141540305 017323 0ustar00jeffstaff000000 000000 # ABSTRACT: Show the roots of a stack package Pinto::Action::Roots; use Moose; use MooseX::StrictConstructor; use MooseX::Types::Moose qw(Str); use MooseX::MarkAsMethods ( autoclean => 1 ); use Pinto::Util qw(whine); use Pinto::Types qw(StackName StackDefault StackObject); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ has stack => ( is => 'ro', isa => StackName | StackDefault | StackObject, default => undef, ); has format => ( is => 'ro', isa => Str, default => '%a/%f', lazy => 1, ); #------------------------------------------------------------------------------ sub execute { my ($self) = @_; my $stack = $self->repo->get_stack($self->stack); my @roots = sort map { $_->to_string($self->format) } $stack->roots; $self->show($_) for @roots; return $self->result; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Action::Roots - Show the roots of a stack =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Action/Stacks.pm000644 000766 000024 00000004027 13141540305 017446 0ustar00jeffstaff000000 000000 # ABSTRACT: List known stacks in the repository package Pinto::Action::Stacks; use Moose; use MooseX::StrictConstructor; use MooseX::Types::Moose qw(Str); use MooseX::MarkAsMethods ( autoclean => 1 ); use List::Util qw(max); use Pinto::Constants qw(:color); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ extends 'Pinto::Action'; #------------------------------------------------------------------------------ has format => ( is => 'ro', isa => Str, ); #------------------------------------------------------------------------------ sub execute { my ($self) = @_; my @stacks = sort { $a cmp $b } $self->repo->get_all_stacks; my $max_name = max( map { length( $_->name ) } @stacks ) || 0; my $max_user = max( map { length( $_->head->username ) } @stacks ) || 0; my $format = $self->format || "%M%L %-${max_name}k %u %-{$max_user}j %i: %{40}T"; for my $stack (@stacks) { my $string = $stack->to_string($format); my $color = $stack->is_default ? $PINTO_PALETTE_COLOR_0 : $stack->is_locked ? $PINTO_PALETTE_COLOR_2 : undef; $self->show( $string, { color => $color } ); } return $self->result; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Action::Stacks - List known stacks in the repository =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Action/Statistics.pm000644 000766 000024 00000003205 13141540305 020345 0ustar00jeffstaff000000 000000 # ABSTRACT: Report statistics about the repository package Pinto::Action::Statistics; use Moose; use MooseX::StrictConstructor; use MooseX::MarkAsMethods ( autoclean => 1 ); use Pinto::Types qw(StackName StackDefault StackObject); use Pinto::Statistics; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ has stack => ( is => 'ro', isa => StackName | StackDefault | StackObject, default => undef, ); #------------------------------------------------------------------------------ sub execute { my ($self) = @_; my $stack = $self->repo->get_stack( $self->stack ); my $stats = Pinto::Statistics->new( stack => $stack ); $self->show( $stats->to_string ); return $self->result; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable(); #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Action::Statistics - Report statistics about the repository =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Action/Unlock.pm000644 000766 000024 00000003422 13141540305 017447 0ustar00jeffstaff000000 000000 # ABSTRACT: Unlock a stack to allow future changes package Pinto::Action::Unlock; use Moose; use MooseX::StrictConstructor; use MooseX::MarkAsMethods ( autoclean => 1 ); use Pinto::Types qw(StackName StackDefault StackObject); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ with qw( Pinto::Role::Transactional ); #------------------------------------------------------------------------------ has stack => ( is => 'ro', isa => StackName | StackDefault | StackObject, default => undef, ); #------------------------------------------------------------------------------ sub execute { my ($self) = @_; my $stack = $self->repo->get_stack( $self->stack ); if ( !$stack->is_locked ) { $self->warning("Stack $stack is not locked"); return $self->result; } $stack->unlock; return $self->result->changed; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Action::Unlock - Unlock a stack to allow future changes =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Action/Unpin.pm000644 000766 000024 00000004133 13141540305 017305 0ustar00jeffstaff000000 000000 # ABSTRACT: Loosen a package that has been pinned package Pinto::Action::Unpin; use Moose; use MooseX::StrictConstructor; use MooseX::MarkAsMethods ( autoclean => 1 ); use Pinto::Util qw(throw); use Pinto::Types qw(TargetList); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ has targets => ( isa => TargetList, traits => [qw(Array)], handles => { targets => 'elements' }, required => 1, coerce => 1, ); #------------------------------------------------------------------------------ with qw( Pinto::Role::Committable ); #------------------------------------------------------------------------------ sub execute { my ($self) = @_; my $stack = $self->stack; for my $target ( $self->targets ) { throw "$target is not registered on stack $stack" unless my $dist = $stack->get_distribution( target => $target ); $self->notice("Unpinning distribution $dist from stack $stack"); my $did_unpin = $dist->unpin( stack => $stack ); push @{$self->affected}, $dist if $did_unpin; $self->warning("Distribution $dist is not pinned to stack $stack") unless $did_unpin; } return $self; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Action::Unpin - Loosen a package that has been pinned =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Action/Unregister.pm000644 000766 000024 00000004153 13141540305 020345 0ustar00jeffstaff000000 000000 # ABSTRACT: Unregister packages from a stack package Pinto::Action::Unregister; use Moose; use MooseX::StrictConstructor; use MooseX::Types::Moose qw(Bool); use MooseX::MarkAsMethods ( autoclean => 1 ); use Pinto::Util qw(throw); use Pinto::Types qw(TargetList); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ has targets => ( isa => TargetList, traits => [qw(Array)], handles => { targets => 'elements' }, required => 1, coerce => 1, ); has force => ( is => 'ro', isa => Bool, default => 0, ); #------------------------------------------------------------------------------ with qw( Pinto::Role::Committable ); #------------------------------------------------------------------------------ sub execute { my ($self) = @_; my $stack = $self->stack; for my $target ( $self->targets ) { throw "Target $target is not registered on stack $stack" unless my $dist = $stack->get_distribution( target => $target ); $self->notice("Unregistering distribution $dist from stack $stack"); $dist->unregister( stack => $stack, force => $self->force ); push @{$self->affected}, $dist; } return $self; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Action::Unregister - Unregister packages from a stack =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Action/Update.pm000644 000766 000024 00000011731 13141540305 017440 0ustar00jeffstaff000000 000000 # ABSTRACT: Update packages to latest versions package Pinto::Action::Update; use Moose; use MooseX::StrictConstructor; use MooseX::Types::Moose qw(Bool); use MooseX::MarkAsMethods ( autoclean => 1 ); use Try::Tiny; use Pinto::Util qw(throw); use Pinto::Types qw(PackageTargetList); use Pinto::Target::Package; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ has targets => ( isa => PackageTargetList, traits => [qw(Array)], handles => { targets => 'elements' }, default => sub { [] }, coerce => 1, ); has all => ( is => 'ro', isa => Bool, default => 0, ); has roots => ( is => 'ro', isa => Bool, default => 0, ); has no_fail => ( is => 'ro', isa => Bool, default => 0, ); #------------------------------------------------------------------------------ with qw( Pinto::Role::Committable Pinto::Role::Puller ); #------------------------------------------------------------------------------ sub execute { my ($self) = @_; my $stack = $self->stack; my @targets = $self->compute_targets; for my $target ( @targets ) { if ($target->version) { $self->warning("Ignoring version specification on target $target"); $target = $target->unversioned; } try { $self->repo->svp_begin; my ($dist, $did_update, $did_update_prereqs) = $self->update($target); push @{$self->affected}, $dist if $did_update; } catch { throw $_ unless $self->no_fail; $self->result->failed( because => $_ ); $self->repo->svp_rollback; $self->error($_); $self->error("Target $target failed...continuing anyway"); } finally { my ($error) = @_; $self->repo->svp_release unless $error; }; } $self->chrome->progress_done; return $self; } #------------------------------------------------------------------------------ sub compute_targets { my ($self) = @_; my $stack = $self->stack; return map {$_->main_module->as_target->unversioned} $stack->distributions if $self->all; return map {$_->main_module->as_target->unversioned} $stack->roots if $self->roots; return $self->targets if $self->targets; throw "No targets specified"; } #------------------------------------------------------------------------------ # TODO: Should we only update packages from foreign dists? # TODO: Skip pinned targets unless --force # TODO: Should pins be preserved? sub update { my ($self, $target) = @_; my $pkg_name = $target->name; my $stack = $self->stack; throw ("Package $pkg_name is not on stack $stack") unless my $reg = $stack->head->registrations->find({package_name => $pkg_name}); my $current_dist = $reg->distribution; my $current_pkg = $reg->package; if ($reg->is_pinned && not $self->force) { $self->notice("Skipping package $pkg_name because it is pinned to $current_dist"); return ($current_dist, 0, 0); } if ($current_dist->is_local && !$self->all) { $self->notice("Skipping local package $pkg_name"); return ($current_dist, 0, 0); } # Now go look for a newer version... my $latest_pkg = $self->repo->locate(target => $target); if (!$latest_pkg and !$current_dist->is_local) { $self->warning("No upstream version of $pkg_name was found"); return ($current_dist, 0, 0); } my $latest_pkg_version = $latest_pkg->{version}; my $current_pkg_version = $current_pkg->version; if ($latest_pkg_version <= $current_pkg_version) { $self->notice( "Package $pkg_name~$current_pkg_version is up to date"); return ($current_dist, 0, 0); } # Finally, we update... $self->notice("Updating $pkg_name to $latest_pkg_version on stack $stack"); my %target_args = (name => $pkg_name, version => $latest_pkg_version); my $new_target = Pinto::Target::Package->new(%target_args); return $self->pull(target => $new_target); } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Action::Update - Update packages to latest versions =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/Pinto/Action/Verify.pm000644 000766 000024 00000003044 13141540305 017460 0ustar00jeffstaff000000 000000 # ABSTRACT: Report distributions that are missing package Pinto::Action::Verify; use Moose; use MooseX::StrictConstructor; use MooseX::MarkAsMethods ( autoclean => 1 ); use Pinto::Util qw(throw); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ sub execute { my ($self) = @_; my $dist_rs = $self->repo->db->schema->distribution_rs; my $missing = 0; while ( my $dist = $dist_rs->next ) { if ( not -e $dist->native_path ) { $self->error("Missing distribution $dist"); $missing++; } } throw("$missing archives are missing") if $missing; return $self->result; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Action::Verify - Report distributions that are missing =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/App/Pinto/000755 000766 000024 00000000000 13141540305 015160 5ustar00jeffstaff000000 000000 Pinto-0.14/lib/App/Pinto.pm000644 000766 000024 00000006651 13141540305 015526 0ustar00jeffstaff000000 000000 # ABSTRACT: Command-line driver for Pinto package App::Pinto; use strict; use warnings; use Class::Load; use App::Cmd::Setup -app; use Pinto::Util qw(is_remote_repo); #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ sub global_opt_spec { return ( [ 'root|r=s' => 'Path to your repository root directory' ], [ 'color|colour!' => 'Colorize any output (negatable)' ], [ 'password|p=s' => 'Password for server authentication' ], [ 'quiet|q' => 'Only report fatal errors' ], [ 'username|u=s' => 'Username for server authentication' ], [ 'verbose|v+' => 'More diagnostic output (repeatable)' ], ); } #------------------------------------------------------------------------------ sub pinto { my ($self) = @_; return $self->{pinto} ||= do { my $global_options = $self->global_options; $global_options->{root} ||= $ENV{PINTO_REPOSITORY_ROOT} || $self->usage_error('Must specify a repository root'); # Discard password and username arguments if this is not a # remote repository. StrictConstrutor will not allow them. delete @{$global_options}{qw(username password)} if not is_remote_repo($global_options->{root}); # Disable color if STDOUT is not a tty, unless it has already been # explicitly enabled. For example: pinto --color ls | less -R $global_options->{color} = 0 if ($ENV{PINTO_NO_COLOR} or not -t STDOUT) and not defined $global_options->{color}; $global_options->{password} = $self->_prompt_for_password if defined $global_options->{password} and $global_options->{password} eq '-'; my $pinto_class = $self->pinto_class_for( $global_options->{root} ); Class::Load::load_class($pinto_class); $pinto_class->new( %{$global_options} ); }; } #------------------------------------------------------------------------------ sub pinto_class_for { my ( $self, $root ) = @_; return is_remote_repo($root) ? 'Pinto::Remote' : 'Pinto'; } #------------------------------------------------------------------------------ sub _prompt_for_password { my ($self) = @_; require Encode; require IO::Prompt; my $repo = $self->global_options->{root}; my $prompt = "Password for repository at $repo: "; my $input = IO::Prompt::prompt( $prompt, -echo => '*', -tty ); my $password = Encode::decode_utf8($input); return $password; } #------------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME App::Pinto - Command-line driver for Pinto =head1 VERSION version 0.14 =head1 SYNOPSIS L to create and manage a Pinto repository. L to allow remote access to your Pinto repository. L for general information on using Pinto. L for hosting your Pinto repository in the cloud. =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/App/Pinto/Command/000755 000766 000024 00000000000 13141540305 016536 5ustar00jeffstaff000000 000000 Pinto-0.14/lib/App/Pinto/Command.pm000644 000766 000024 00000007046 13141540305 017103 0ustar00jeffstaff000000 000000 # ABSTRACT: Base class for pinto commands package App::Pinto::Command; use strict; use warnings; use IO::String; use Pod::Usage qw(pod2usage); #----------------------------------------------------------------------------- use App::Cmd::Setup -command; #----------------------------------------------------------------------------- our $VERSION = '0.14'; # VERSION #----------------------------------------------------------------------------- sub usage_desc { my ( $class_or_self, @args ) = @_; my $class = ref $class_or_self || $class_or_self; my $file = $class . '.pm'; $file =~ s{::}{/}xg; my $path = $INC{$file} or return; my $handle = IO::String->new; pod2usage( -output => $handle, -input => $path, -exitval => 'NOEXIT' ); return ${ $handle->string_ref }; } #----------------------------------------------------------------------------- sub pinto { my ($self) = @_; return $self->app->pinto; } #----------------------------------------------------------------------------- sub validate_args { my ( $self, $opts, $args ) = @_; $self->usage_error("Arguments are not allowed") if @{$args} and not $self->args_attribute; return 1; } #------------------------------------------------------------------------------ sub execute { my ( $self, $opts, $args ) = @_; my %args = $self->process_args($opts, $args); my $result = $self->pinto->run( $self->action_name, %{$opts}, %args ); return $result->exit_status; } #----------------------------------------------------------------------------- sub process_args { my ( $self, $opts, $args ) = @_; my $attr_name = $self->args_attribute or return; if ( !@{$args} && $self->args_from_stdin($opts) ) { return ( $attr_name => [ _args_from_fh( \*STDIN ) ] ); } return ( $attr_name => $args ); } #----------------------------------------------------------------------------- sub action_name { my ($self) = @_; my $class = ref $self; my $prefix = $self->command_namespace_prefix(); $class =~ m/ ^ ${prefix}:: (.+) /mx or die "Unable to parse Action name from $class\n"; # Convert foo::bar::baz -> Foo::Bar:Baz # TODO: consider using a regex to do the conversion my $action_name = join '::', map {ucfirst} split '::', $1; return $action_name; } #----------------------------------------------------------------------------- sub _args_from_fh { my ($fh) = @_; my @args; while ( my $line = <$fh> ) { chomp $line; next if not length $line; next if $line =~ m/^ \s* [;#]/x; next if $line !~ m/\S/x; push @args, $line; } return @args; } #------------------------------------------------------------------------------- sub args_attribute { return '' } #----------------------------------------------------------------------------- sub args_from_stdin { return 0 } #----------------------------------------------------------------------------- sub command_namespace_prefix { return __PACKAGE__ } #----------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME App::Pinto::Command - Base class for pinto commands =head1 VERSION version 0.14 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/App/Pinto/Command/add.pm000644 000766 000024 00000022020 13141540305 017620 0ustar00jeffstaff000000 000000 package App::Pinto::Command::add; # ABSTRACT: add local archives to the repository use strict; use warnings; #------------------------------------------------------------------------------ use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #----------------------------------------------------------------------------- sub opt_spec { my ( $self, $app ) = @_; return ( [ 'author=s' => 'The ID of the archive author' ], [ 'cascade' => 'Always pick latest upstream package' ], [ 'diff-style=s' => 'Set style of diff reports' ], [ 'dry-run' => 'Do not commit any changes' ], [ 'message|m=s' => 'Message to describe the change' ], [ 'no-fail' => 'Do not fail when there is an error' ], [ 'no-index|x=s@' => 'Do not index matching packages' ], [ 'recurse!' => 'Recursively pull prereqs (negatable)' ], [ 'pin' => 'Pin packages to the stack' ], [ 'skip-missing-prerequisite|k=s@' => 'Skip missing prereq (repeatable)' ], [ 'skip-all-missing-prerequisites|K' => 'Skip all missing prereqs' ], [ 'stack|s=s' => 'Put packages into this stack' ], [ 'use-default-message|M' => 'Use the generated message' ], [ 'with-development-prerequisites|wd' => 'Also pull prereqs for development' ], ); } #------------------------------------------------------------------------------ sub args_attribute { return 'archives' } #------------------------------------------------------------------------------ sub args_from_stdin { return 1 } #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME App::Pinto::Command::add - add local archives to the repository =head1 VERSION version 0.14 =head1 SYNOPSIS pinto --root=REPOSITORY_ROOT add [OPTIONS] ARCHIVE_FILE ... =head1 DESCRIPTION This command adds local distribution archives to the repository and registers their packages on a stack. Then it recursively pulls all the distributions that are necessary to satisfy their prerequisites. When locating prerequisite packages, Pinto first looks at the packages that already exist in the local repository, then Pinto looks at the packages that are available on the upstream repositories. =head1 COMMAND ARGUMENTS Arguments to this command are paths to the distribution archives that you wish to add. Each of these files must exist and must be readable. You can also pipe arguments to this command over STDIN. In that case, blank lines and lines that look like comments (i.e. starting with "#" or ';') will be ignored. =head1 COMMAND OPTIONS =over 4 =item --author NAME Set the identity of the distribution author. The C is automatically forced to uppercase and must match C (that means two ASCII letters followed by zero or more ASCII letters, digits, or hyphens). Defaults to the C attribute specified in your F<~/.pause> configuration file if such file exists. Otherwise, defaults to your current login username. =item --cascade !! THIS OPTION IS EXPERIMENTAL !! When searching for a prerequisite package, always take the latest satisfactory version of the package found amongst B the upstream repositories, rather than just taking the B satisfactory version that is found. Remember that Pinto only searches the upstream repositories when the local repository does not already contain a satisfactory version of the package. =item --diff-style=STYLE Controls the style of the diff reports. STYLE must be either C or C. Concise reports show only one record for each distribution added or deleted. Detailed reports show one record for every package added or deleted. The default style is C. However, the default style can changed by setting the C environment variable to your preferred STYLE. This variable affects the default style for diff reports generated by all other commands too. =item --dry-run Go through all the motions, but do not actually commit any changes to the repository. At the conclusion, a diff showing the changes that would have been made will be displayed. Use this option to see how upgrades would potentially impact the stack. =item --message=TEXT =item -m TEXT Use TEXT as the revision history log message. If you do not use the C<--message> option or the C<--use-default-message> option, then you will be prompted to enter the message via your text editor. Use the C or C or C environment variables to control which editor is used. A log message is not required whenever the C<--dry-run> option is set, or if the action did not yield any changes to the repository. =item --no-fail !! THIS OPTION IS EXPERIMENTAL !! Normally, failure to add an archive (or its prerequisites) causes the command to immediately abort and rollback the changes to the repository. But if C<--no-fail> is set, then only the changes caused by the failed archive (and its prerequisites) will be rolled back and the command will continue processing the remaining archives. This option is useful if you want to throw a list of archives into a repository and see which ones are problematic. Once you've fixed the broken ones, you can throw the whole list at the repository again. =item --no-index=PACKAGE =item -x PACKAGE =item --no-index=/PATTERN =item -x /PATTERN !! THIS OPTION IS EXPERIMENTAL !! Exclude the PACKAGE from the index. If the argument starts with a slash, then it is interpreted as a regular expression, and all packages matching the pattern will be excluded. Exclusions only apply to the added distributions (i.e. the arguments to this command) so they do not affect any prerequisited distributions that may also get pulled. You can repeat this option to specify multiple PACKAGES or PATTERNS. This option is useful when Pinto's indexing is to aggressive and finds packages that it probably should not. Remember that Pinto does not promise to index exactly as PAUSE would. When using a PATTERN, take care to use a conservative one so you don't exclude the wrong packages. Pinto will throw an exception if you exclude every package in the distribution. =item --pin Pins all the packages in the added distributions to the stack, so they cannot be changed until you unpin them. The pin does not apply to any prerequisites that are pulled in for this distribution. However, you may pin them separately with the L command, if you so desire. =item --recurse =item --no-recurse Recursively pull any distributions required to satisfy prerequisites for the targets. The default value for this option can be configured in the F configuration file for the repository (it is usually set to 1). To disable recursion, use C<--no-recurse>. =item --skip-missing-prerequisite=PACKAGE =item -k PACKAGE !! THIS OPTION IS EXPERIMENTAL !! Skip any prerequisite with name PACKAGE if a satisfactory version cannot be found. However, a warning will be given whenever this occurrs. This option only has effect when recursively fetching prerequisites for the targets (See also the C<--recurse> option). This option can be repeated. =item --skip-all-missing-prerequisites =item -K !! THIS OPTION IS EXPERIMENTAL !! Skips all missing prerequisites if a satisfactory version cannot be found. However, a warning will be given whenever this occurrs. This option will silently override the C<--skip-missing-prerequisite> option and only has effect when recursively fetching prerequisites for the targets (See also the C<--recurse> option). =item --stack=NAME =item -s NAME Puts all the packages onto the stack with the given NAME. Defaults to the name of whichever stack is currently marked as the default stack. Use the L command to see the stacks in the repository. =item --use-default-message =item -M Use the default value for the revision history log message. Pinto will generate a semi-informative log message just based on the command and its arguments. If you set an explicit message with C<--message>, the C<--use-default-message> option will be silently ignored. =item --with-development-prerequisites =item --wd Also pull development prerequisites so you'll have everything you need to work on those distributions, in the event that you need to patch them in the future. Be aware that most distributions do not actually declare their development prerequisites. =back =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/App/Pinto/Command/clean.pm000644 000766 000024 00000003136 13141540305 020161 0ustar00jeffstaff000000 000000 # ABSTRACT: remove orphaned distribution archives package App::Pinto::Command::clean; use strict; use warnings; #------------------------------------------------------------------------------ use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #----------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME App::Pinto::Command::clean - remove orphaned distribution archives =head1 VERSION version 0.14 =head1 SYNOPSIS pinto --root=REPOSITORY_ROOT clean =head1 DESCRIPTION The database for L is transactional, so failures and aborted commands do not change the indexes. However, the filesystem where distribution archives are physically stored is not transactional and may become cluttered with archives that are not in the database. Normally, L tries to clean up those orphaned archives. But in some cases it might not. Running this command will force their removal. This command also runs some optimizations on the database. So if your repository seems to be running slowly, try running this command to see if performance improves. =head1 COMMAND ARGUMENTS None. =head1 COMMAND OPTIONS None. =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/App/Pinto/Command/copy.pm000644 000766 000024 00000006055 13141540305 020054 0ustar00jeffstaff000000 000000 # ABSTRACT: create a new stack by copying another package App::Pinto::Command::copy; use strict; use warnings; #----------------------------------------------------------------------------- use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ sub command_names { return qw(copy cp) } #------------------------------------------------------------------------------ sub opt_spec { my ( $self, $app ) = @_; return ( [ 'default' => 'Make the new stack the default stack' ], [ 'description|d=s' => 'Brief description of the stack' ], [ 'lock' => 'Lock the new stack to prevent changes' ], ); } #------------------------------------------------------------------------------ sub validate_args { my ( $self, $opts, $args ) = @_; $self->usage_error('Must specify STACK and TO_STACK') if @{$args} != 2; return 1; } #------------------------------------------------------------------------------ sub execute { my ( $self, $opts, $args ) = @_; my %stacks = ( stack => $args->[0], to_stack => $args->[1] ); my $result = $self->pinto->run( $self->action_name, %{$opts}, %stacks ); return $result->exit_status; } #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME App::Pinto::Command::copy - create a new stack by copying another =head1 VERSION version 0.14 =head1 SYNOPSIS pinto --root=REPOSITORY_ROOT copy [OPTIONS] STACK TO_STACK =head1 DESCRIPTION This command creates a new stack by copying an existing one. All the pins and properties from the existing stack will also be copied to the new one. The new stack must not already exist. Use the L command to create a new empty stack, or the L command to change a stack's properties after it has been created. =head1 COMMAND ARGUMENTS The two required arguments are the name of the source and target stacks. Stack names must be alphanumeric plus hyphens, underscores, and periods, and are not case-sensitive. =head1 COMMAND OPTIONS =over 4 =item --default Also mark the new stack as the default stack. =item --description=TEXT =item -d TEXT Use TEXT for the description of the stack. If not specified, defaults to 'Copy of stack STACK'. =item --lock Also lock the new stack to prevent future changes. This is useful for creating a read-only "tag" of a stack. You can always use the L or L commands at a later time. =back =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/App/Pinto/Command/default.pm000644 000766 000024 00000005712 13141540305 020525 0ustar00jeffstaff000000 000000 # ABSTRACT: mark the default stack package App::Pinto::Command::default; use strict; use warnings; #----------------------------------------------------------------------------- use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ sub opt_spec { my ( $self, $app ) = @_; return ( [ 'none' => 'Unmark the default stack' ] ); } #----------------------------------------------------------------------------- sub validate_args { my ( $self, $opts, $args ) = @_; $self->usage_error('Cannot specify multiple stacks') if @{$args} > 1; $self->usage_error('Must specify a STACK or --none') if !( @{$args} xor $opts->{none} ); return 1; } #------------------------------------------------------------------------------ sub execute { my ( $self, $opts, $args ) = @_; $opts->{stack} = $args->[0] if $args->[0]; my $result = $self->pinto->run( $self->action_name, %{$opts} ); return $result->exit_status; } #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer unmark unmarks =head1 NAME App::Pinto::Command::default - mark the default stack =head1 VERSION version 0.14 =head1 SYNOPSIS pinto --root=REPOSITORY_ROOT default [OPTIONS] [STACK] =head1 DESCRIPTION This command marks the given C as the default stack for the repository. The existing default stack (if one exists) is thereby unmarked. The default stack is used by most L commands where a stack is not explicitly specified either by option or argument. If the C<--none> option is given instead of a C argument, then the default stack is unmarked (if one exists). When a repository has no default stack, you will have to explicitly specify the stack as option or argument for most L commands. Use the L command to list the stacks that currently exist in the repository and show which one is the default. =head1 BEWARE Think carefully before changing the default stack. This will dramatically affect all users of the repository, so it is wise to notify them well in advance. =head1 COMMAND ARGUMENTS The argument is the name of the stack you wish to mark as the default. The stack must already exist. A stack argument cannot be used when the C<--none> option is specified. =head1 COMMAND OPTIONS =over 4 =item --none Unmarks the default stack (if one exists). This option cannot be used when the C argument is specified. =back =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/App/Pinto/Command/delete.pm000644 000766 000024 00000005501 13141540305 020337 0ustar00jeffstaff000000 000000 # ABSTRACT: permanently remove an archive package App::Pinto::Command::delete; use strict; use warnings; #------------------------------------------------------------------------------ use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #----------------------------------------------------------------------------- sub command_names { return qw(delete remove del rm) } #----------------------------------------------------------------------------- sub opt_spec { my ( $self, $app ) = @_; return ( [ 'force' => 'Delete even if packages are pinned' ], ); } #------------------------------------------------------------------------------ sub args_attribute { return 'targets'; } #------------------------------------------------------------------------------ sub args_from_stdin { return 1; } #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME App::Pinto::Command::delete - permanently remove an archive =head1 VERSION version 0.14 =head1 SYNOPSIS pinto --root=REPOSITORY_ROOT delete [OPTIONS] TARGET ... =head1 DESCRIPTION !! THIS COMMAND IS EXPERIMENTAL !! B This command is dangerous. If you just want to remove packages or distributions from a stack, then you should probably be looking at the L command instead. This command permanently removes an archive from the repository, thereby unregistering it from all stacks and wiping it from all history (as if it had never been put in the repository). Beware that once an archive is deleted it cannot be recovered. There will be no record that the archive was ever added or deleted, and this change cannot be undone. To merely remove packages from a stack (while preserving the archive), use the L command. =head1 COMMAND ARGUMENTS Arguments are the targets that you want to delete. Targets are specified as C. For example: SHAKESPEARE/King-Lear-1.2.tar.gz You can also pipe arguments to this command over STDIN. In that case, blank lines and lines that look like comments (i.e. starting with "#" or ';') will be ignored. =head1 COMMAND OPTIONS =over 4 =item --force Deletes the archive even if its packages are pinned to a stack. Take care when deleting pinned packages, as it usually means that particular package is important to someone. =back =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/App/Pinto/Command/diff.pm000644 000766 000024 00000007741 13141540305 020015 0ustar00jeffstaff000000 000000 #ABSTRACT: show difference between two stacks package App::Pinto::Command::diff; use strict; use warnings; #----------------------------------------------------------------------------- use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ sub command_names { return qw(diff) } #------------------------------------------------------------------------------ sub opt_spec { my ( $self, $app ) = @_; return ( [ 'diff-style=s' => 'Diff style (concise|detailed)' ], [ 'format=s' => 'Format specification (see POD for details)' ], ); } #------------------------------------------------------------------------------ sub validate_args { my ( $self, $opts, $args ) = @_; $self->usage_error('Must specify at least one stack or revision') if @{$args} < 1; $self->usage_error('Cannot specify more than two stacks or revisions') if @{$args} > 2; return 1; } #------------------------------------------------------------------------------ sub execute { my ( $self, $opts, $args ) = @_; # If there's only one argument, then the left argument # is assumed to be the default stack (i.e. undef) unshift @{$args}, undef if @{$args} == 1; my %stacks = ( left => $args->[0], right => $args->[1] ); my $result = $self->pinto->run( $self->action_name, %{$opts}, %stacks ); return $result->exit_status; } #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME App::Pinto::Command::diff - show difference between two stacks =head1 VERSION version 0.14 =head1 SYNOPSIS pinto --root=REPOSITORY_ROOT diff [OPTIONS] LEFT [RIGHT] =head1 DESCRIPTION !! THIS COMMAND IS EXPERIMENTAL !! This command shows the difference between two stacks or revisions, presented in a format similar to diff[1]. =head1 COMMAND ARGUMENTS Command arguments are the names of the stacks or revision IDs to compare. If you specify a stack name, the head revision of that stack will be used. If you only specify one argument, then it is assumed to be the RIGHT and the head revision of the default stack will be used as the LEFT. Revision IDs can be truncated to uniqueness. =head1 COMMAND OPTIONS =over 4 =item --diff-style=STYLE Controls the style of the diff reports. STYLE must be either C or C. Concise reports show only one record for each distribution added or deleted. Detailed reports show one record for every package added or deleted. The default style is C. However, the default style can be changed by setting the C environment variable to your preferred STYLE. This variable affects the default style for diff reports generated by all other commands too. =item --format=FORMAT A C-style format string describing how individual lines of the diff are to be printed. For the description of the C, please refer to L. The default format for C diffs is C<%o[%F] %a/%f>. The default format for C diffs is C<%o[%F] %-40p %12v %a/%f>. =back =head2 EXAMPLES pinto diff foo # Compare of head of default stack with head of foo stack pinto diff foo bar # Compare heads of both foo and bar stack. pinto diff 1ae834f # Compare head of default stack with revision 1ae834f pinto diff foo 1ae834f # Compare head of foo stack with revision 1ae834f pinto diff 663fd2a 1ae834f # Compare revision 663fd2a with revision 1ae834f =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/App/Pinto/Command/help.pm000644 000766 000024 00000003372 13141540305 020031 0ustar00jeffstaff000000 000000 # ABSTRACT: display a command's help screen package App::Pinto::Command::help; use strict; use warnings; use base qw(App::Cmd::Command::help); #------------------------------------------------------------------------------- our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------- # This is just a thin subclass of App::Cmd::Command::help. All we have done is # extend the exeucte() method to mention the "pinto manual" command at the end sub execute { my ( $self, $opts, $args ) = @_; my ( $cmd, undef, undef ) = $self->app->prepare_command(@$args); my ($cmd_name) = $cmd->command_names; my $rv = $self->SUPER::execute( $opts, $args ); # Only display this if showing help for a specific command. print qq{For more information, run "pinto manual $cmd_name"\n} if @{$args}; return $rv; } #------------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME App::Pinto::Command::help - display a command's help screen =head1 VERSION version 0.14 =head1 SYNOPSIS pinto help COMMAND =head1 DESCRIPTION This command shows a brief help screen for a pinto COMMAND. =head1 COMMAND ARGUMENTS The argument to this command is the name of the command you would like help on. You can also use the L command to get extended documentation for any command. =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/App/Pinto/Command/init.pm000644 000766 000024 00000012320 13141540305 020035 0ustar00jeffstaff000000 000000 # ABSTRACT: create a new repository package App::Pinto::Command::init; use strict; use warnings; use Class::Load; use Pinto::Util qw(is_remote_repo); #----------------------------------------------------------------------------- use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ sub opt_spec { my ( $self, $app ) = @_; return ( [ 'description=s' => 'Description of the initial stack' ], [ 'no-default' => 'Do not mark the initial stack as the default' ], [ 'recurse!' => 'Default recursive behavior (negatable)' ], [ 'source=s@' => 'URI of upstream repository (repeatable)' ], [ 'stack=s' => 'Name of the initial stack' ], [ 'target-perl-version|tpv=s' => 'Default perl version for new stacks' ], ); } #------------------------------------------------------------------------------ sub validate_args { my ( $self, $opts, $args ) = @_; $self->usage_error('Only one argument is allowed') if @{$args} > 1; return 1; } #------------------------------------------------------------------------------ sub execute { my ( $self, $opts, $args ) = @_; my $global_opts = $self->app->global_options; die "Must specify a repository root directory\n" unless $global_opts->{root} ||= ($args->[0] || $ENV{PINTO_REPOSITORY_ROOT}); die "Cannot create remote repositories\n" if is_remote_repo( $global_opts->{root} ); # Combine repeatable "source" options into one space-delimited "sources" option. # TODO: Use a config file format that allows multiple values per key (MVP perhaps?). $opts->{sources} = join ' ', @{ delete $opts->{source} } if defined $opts->{source}; my $initializer = $self->load_initializer->new; $initializer->init( %{$global_opts}, %{$opts} ); return 0; } #------------------------------------------------------------------------------ sub load_initializer { my $class = 'Pinto::Initializer'; my ( $ok, $error ) = Class::Load::try_load_class($class); return $class if $ok; my $msg = $error =~ m/Can't locate .* in \@INC/ ## no critic (ExtendedFormatting) ? "Must install Pinto to create new repositories\n" : $error; die $msg; } #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME App::Pinto::Command::init - create a new repository =head1 VERSION version 0.14 =head1 SYNOPSIS pinto --root=REPOSITORY_ROOT init [OPTIONS] =head1 DESCRIPTION This command creates a new repository. If the target directory does not exist, it will be created for you. If it does already exist, then it must be empty. You can set the configuration properties of the new repository using the command line options listed below. =head1 COMMAND ARGUMENTS The path to the repository root directory can also be be given as an argument, which will silently override the C<--root> option. So the following are equivalent: pinto --root=/some/directory init pinto init /some/directory =head1 COMMAND OPTIONS =over 4 =item --description=TEXT A brief description of the initial stack. Defaults to "the initial stack". This option is only allowed if the C argument is given. =item --no-default Do not mark the initial stack as the default stack. If you choose not to mark the default stack, then you'll be required to specify the C<--stack> option for most commands. You can always mark (or unmark) the default stack at any time by using the L command. =item --recurse =item --no-recurse Sets the default recursion behavior for the L add L commands. C<--recurse> means that commands will be recursive by default. C<--no-recurse> means commands will not be recursive. If you do not specify either of these, it defaults to being recursive. However, each command can always override this default. =item --source=URI The URI of the upstream repository where distributions will be pulled from. This is usually the URI of a CPAN mirror, and it defaults to L and L. But it could also be a L mirror, or another L repository. You can specify multiple repository URIs by repeating the C<--source> option. Repositories that appear earlier in the list have priority over those that appear later. See L for more information about using multiple upstream repositories. =item --stack=NAME Sets the name of the initial stack. Stack names must be alphanumeric plus hyphens, underscores, and periods, and are not case-sensitive. Defaults to C. =back =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/App/Pinto/Command/install.pm000644 000766 000024 00000020751 13141540305 020547 0ustar00jeffstaff000000 000000 # ABSTRACT: install stuff from the repository package App::Pinto::Command::install; use strict; use warnings; #----------------------------------------------------------------------------- use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ sub opt_spec { my ( $self, $app ) = @_; return ( [ 'cascade' => 'Always pick latest upstream package' ], [ 'cpanm-exe|cpanm=s' => 'Path to the cpanm executable' ], [ 'cpanm-options|o:s%' => 'name=value pairs of cpanm options' ], [ 'diff-style=s' => 'Set style of diff reports' ], [ 'local-lib|l=s' => 'install into a local lib directory' ], [ 'local-lib-contained|L=s' => 'install into a contained local lib directory' ], [ 'message|m=s' => 'Message to describe the change' ], [ 'do-pull' => 'pull missing prereqs onto the stack first' ], [ 'stack|s=s' => 'Install modules from this stack' ], [ 'use-default-message|M' => 'Use the generated message' ], ); } #------------------------------------------------------------------------------ sub validate_args { my ( $self, $opts, $args ) = @_; my $local_lib = delete $opts->{local_lib}; $opts->{cpanm_options}->{'local-lib'} = $local_lib if $local_lib; my $local_lib_contained = delete $opts->{local_lib_contained}; $opts->{cpanm_options}->{'local-lib-contained'} = $local_lib_contained if $local_lib_contained; return 1; } #------------------------------------------------------------------------------ sub args_attribute { return 'targets' } #------------------------------------------------------------------------------ sub args_from_stdin { return 1 } #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer exe cpanm =head1 NAME App::Pinto::Command::install - install stuff from the repository =head1 VERSION version 0.14 =head1 SYNOPSIS pinto --root=REPOSITORY_ROOT install [OPTIONS] TARGET... =head1 DESCRIPTION !! THIS COMMAND IS EXPERIMENTAL !! Installs targets from the repository into your environment. This is just a thin wrapper around L that is wired to fetch everything from the Pinto repository, rather than a public CPAN mirror. If the C<--do-pull> option is given, then all targets and their prerequisites will be pulled onto the stack before attempting to install them. If any thing cannot be pulled because it cannot be found or is blocked by a pin, then the installation will not proceed. =head1 COMMAND ARGUMENTS Arguments are the things you want to install. These can be package names, distribution paths, URIs, local files, or directories. Look at the L documentation to see all the different ways of specifying what to install. You can also pipe arguments to this command over STDIN. In that case, blank lines and lines that look like comments (i.e. starting with "#" or ';') will be ignored. =head1 COMMAND OPTIONS =over 4 =item --cascade !! THIS OPTION IS EXPERIMENTAL !! When searching for a prerequisite package, always take the latest satisfactory version of the package found amongst B the upstream repositories, rather than just taking the B satisfactory version that is found. Remember that Pinto only searches the upstream repositories when the local repository does not already contain a satisfactory version of the package. This option only matters when the C<--do-pull> option is also used. =item --cpanm-exe PATH =item --cpanm PATH Sets the path to the L executable. If not specified, the C will be searched for the executable. At present, cpanm version 1.500 or newer is required. =item --cpanm-options NAME=VALUE =item -o NAME=VALUE These are options that you wish to pass to L. Do not prefix the option NAME with a '-'. You can pass any option you like, but the C<--mirror> and C<--mirror-only> options will always be set to point to the Pinto repository. =item --diff-style=STYLE Controls the style of the diff reports. STYLE must be either C or C. Concise reports show only one record for each distribution added or deleted. Detailed reports show one record for every package added or deleted. This option ony matters when the C<--do-pull> option is also used. The default style is C. However, the default style can changed by setting the C environment variable to your preferred STYLE. This variable affects the default style for diff reports generated by all other commands too. =item --do-pull Pull the targets and recursively pull all their prerequisites onto the stack before installing. Without the C<--do-pull> option, all targets and their prerequisites must already be on the stack or the installation will probably fail. When the C<--do-pull> option is used, the stack must not be locked. =item --local-lib=DIRECTORY =item -l DIRECTORY Shortcut for setting the C<--local-lib> option on L. Same as C<--cpanm-options local-lib=DIRECTORY> or C<-o l=DIRECTORY>. =item --local-lib-contained=DIRECTORY =item -L DIRECTORY Shortcut for setting the C<--local-lib-contained> option on L. Same as C<--cpanm-options local-lib-containted=DIRECTORY> or C<-o L=DIRECTORY>. =item --message=TEXT =item -m TEXT Use TEXT as the revision history log message. This is only relevant if you also set the C<--do-pull> option. If you do not use C<--message> option, then you will be prompted to enter the message via your text editor. Use the C or C or C environment variables to control which editor is used. A log message is not required whenever the C<--dry-run> option is set, or if the action did not yield any changes to the repository. =item --stack=NAME =item -s NAME Use the stack with the given NAME as the repository index. When used with the C<--pull> option, this also determines which stack prerequisites will be pulled onto. Defaults to the name of whichever stack is currently marked as the default stack. Use the L command to see the stacks in the repository. =item --use-default-message =item -M Use the default value for the revision history log message. This is only relevant if you also set the C<--do-pull> option. Pinto will generate a semi- informative log message just based on the command and its arguments. If you set an explicit message with C<--message>, the C<--use- default-message> option will be silently ignored. =back =head1 USING cpan OR cpanm DIRECTLY On the surface, A Pinto repository looks like an ordinary CPAN repository, so you can use any client to install modules. All you have to do is "point" it at the URI of your Pinto repository. Each client has a slightly different interface for setting the URI. For L, use the C<--mirror> and C<--mirror-only> options like this: $> cpanm --mirror file:///path/to/repo --mirror-only Some::Package ... For L, set the C config option via the shell like this: $> cpan cpan[1]> o conf urllist file:///path/to/repo cpan[2]> reload index cpan[3]> install Some::Package cpan[4]> o conf commit # If you want to make the change permanent Pointing your client at the top of your repository will install modules from the default stack. To install from a particular stack, just append the stack name to the URI. For example: file:///path/to/repo # Install from default stack file:///path/to/repo/stacks/dev # Install from "dev" stack file:///path/to/repo/stacks/prod # Install from "prod" stack If your repository does not have a default stack then you must specify the full URI to one of the stacks as shown above. =head1 COMPATIBILITY The C command does not support some of the newer features found in version 1.6 (or later) of L, such as installing from a Git repository, installing development releases, or using complex version expressions. If you pass any of those as arguments to this command, the behavior is unspecified. =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/App/Pinto/Command/kill.pm000644 000766 000024 00000004562 13141540305 020036 0ustar00jeffstaff000000 000000 # ABSTRACT: permanently delete a stack package App::Pinto::Command::kill; use strict; use warnings; #----------------------------------------------------------------------------- use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ sub command_names { return qw(kill) } #------------------------------------------------------------------------------ sub opt_spec { my ( $self, $app ) = @_; return ( [ 'force' => 'Kill even if stack is locked' ], ); } #------------------------------------------------------------------------------ sub validate_args { my ( $self, $opts, $args ) = @_; $self->usage_error('Must specify exactly one stack') if @{$args} != 1; return 1; } #------------------------------------------------------------------------------ sub execute { my ( $self, $opts, $args ) = @_; my $result = $self->pinto->run( $self->action_name, %{$opts}, stack => $args->[0] ); return $result->exit_status; } #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME App::Pinto::Command::kill - permanently delete a stack =head1 VERSION version 0.14 =head1 SYNOPSIS pinto --root=REPOSITORY_ROOT kill [OPTIONS] STACK =head1 DESCRIPTION This command permanently deletes a stack. Once a stack is killed, there is no direct way to get it back. However, any distributions that were registered on the stack will still remain in the repository. =head1 COMMAND ARGUMENTS The required argument is the name of the stack you wish to kill. Stack names must be alphanumeric plus hyphens and underscores, and are not case-sensitive. =head1 COMMAND OPTIONS =over 4 =item --force Kill the stack even if it is currently locked. Normally, locked stacks cannot be deleted. Take care when deleting a locked stack as it usually means the stack is important to someone. =back =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/App/Pinto/Command/list.pm000644 000766 000024 00000015155 13141540305 020056 0ustar00jeffstaff000000 000000 package App::Pinto::Command::list; # ABSTRACT: show the packages in a stack use strict; use warnings; use Pinto::Util qw(interpolate); #----------------------------------------------------------------------------- use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ sub command_names { return qw( list ls ) } #------------------------------------------------------------------------------ sub opt_spec { my ( $self, $app ) = @_; return ( [ 'all|a' => 'List everything in the repository'], [ 'authors|A=s' => 'Limit to matching author identities' ], [ 'distributions|D=s' => 'Limit to matching distribution names' ], [ 'packages|P=s' => 'Limit to matching package names' ], [ 'pinned!' => 'Limit to pinned packages (negatable)' ], [ 'format=s' => 'Format specification (See POD for details)' ], [ 'stack|s=s' => 'List contents of this stack' ], ); } #------------------------------------------------------------------------------ sub validate_args { my ( $self, $opts, $args ) = @_; $self->usage_error('Multiple arguments are not allowed') if @{$args} > 1; $opts->{format} = interpolate( $opts->{format} ) if exists $opts->{format}; $opts->{stack} = $args->[0] if $args->[0]; $self->usage_error('Cannot specify a stack when using --all') if $opts->{stack} && $opts->{all}; return 1; } #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME App::Pinto::Command::list - show the packages in a stack =head1 VERSION version 0.14 =head1 SYNOPSIS pinto --root=REPOSITORY_ROOT list [OPTIONS] =head1 DESCRIPTION This command lists the packages that are currently registered on a particular stack, or all the packages in the entire repository. You can format the output to see the specific bits of information that you want. For a large repository, it can take a long time to list everything. So consider using the C<--packages> or C<--distributions> options to narrow the scope. =head1 COMMAND ARGUMENTS As an alternative to the C<--stack> option, you can also specify the stack as an argument. So the following examples are equivalent: pinto --root REPOSITORY_ROOT list --stack dev pinto --root REPOSITORY_ROOT list dev A stack specified as an argument in this fashion will override any stack specified with the C<--stack> option. If a stack is not specified by neither argument nor option, then it defaults to the stack that is currently marked as the default stack. =head1 COMMAND OPTIONS =over 4 =item --all =item -a List every package in every distribution that exists in the entire repository, including distributions that are not currently registered on any stack. When the C<--all> option is used, then the stack argument and C<--stack> option are not allowed. Also note the pin status is indeterminable when using the C<--all> option so it always appears as C (see the C<--format> option below for more details about that). =item --authors=PATTERN =item -A PATTERN Limit the listing to records where the distribution's author identity matches C. The C will be interpreted as a case-insensitive regular expression. Take care to use quotes if your C contains any special shell metacharacters. =item --distributions=PATTERN =item -D PATTERN Limit the listing to records where the distribution archive name matches C. The C will be interpreted as a case-sensitive regular expression. Take care to use quotes if your C contains any special shell metacharacters. =item --format FORMAT_SPECIFICATION Format of the output using C-style placeholders. Valid placeholders are: Placeholder Meaning ----------------------------------------------------------------------------- %p Package name %P Package name-version %v Package version %x Package can be indexed: (x) = true, (-) = false %M Package is the main module: (m) = true, (-) = false %y Package is pinned: (!) = true, (-) = false %a Distribution author %f Distribution archive filename %m Distribution maturity: (d) = developer, (r) = release %h Distribution index path [1] %H Distribution physical path [2] %s Distribution origin: (l) = local, (f) = foreign %S Distribution source URL %d Distribution name %D Distribution name-version %V Distribution version %u Distribution URI %% A literal '%' [1]: The index path is always a Unix-style path fragment, as it appears in the 02packages.details.txt index file. [2]: The physical path is always in the native style for this OS, and is relative to the root directory of the repository. You can also specify the minimum field widths and left or right justification, using the usual notation. For example, the default format looks something like this: [%m%s%y] %-40p %12v %a/%f When using the C<--all> option, the pin status is indeterminable so it always appears as C. Also, the indexable status is shown. So the default format looks something like this instead: [%m%s?%x] %-40p %12v %a/%f =item --packages=PATTERN =item -P PATTERN Limit the listing to records where the package name matches C. The C will be interpreted as a case-sensitive regular expression. Take care to use quotes if your C contains any special shell metacharacters. =item --pinned Limit the listing to records for packages that are pinned. This option has no effect when using the C<--all> option. =item --stack=NAME =item -s NAME List the contents of the stack with the given NAME. Defaults to the name of whichever stack is currently marked as the default stack. Use the L command to see the stacks in the repository. This option cannot be used with the C<--all> option. =back =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/App/Pinto/Command/lock.pm000644 000766 000024 00000004707 13141540305 020034 0ustar00jeffstaff000000 000000 # ABSTRACT: mark a stack as read-only package App::Pinto::Command::lock; use strict; use warnings; #----------------------------------------------------------------------------- use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ sub opt_spec { my ( $self, $app ) = @_; return ( [ 'stack|s=s' => 'Lock this stack' ], ); } #------------------------------------------------------------------------------ sub validate_args { my ( $self, $opts, $args ) = @_; $self->usage_error('Multiple arguments are not allowed') if @{$args} > 1; $opts->{stack} = $args->[0] if $args->[0]; return 1; } #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME App::Pinto::Command::lock - mark a stack as read-only =head1 VERSION version 0.14 =head1 SYNOPSIS pinto --root=REPOSITORY_ROOT lock [OPTIONS] =head1 DESCRIPTION This command locks a stack so that its packages cannot be changed. It is typically used with the L command to effectively create a read-only "tag" of a stack. To unlock a stack, use the L command. =head1 COMMAND ARGUMENTS As an alternative to the C<--stack> option, you can also specify the stack as an argument. So the following examples are equivalent: pinto --root REPOSITORY_ROOT lock --stack dev pinto --root REPOSITORY_ROOT lock dev A stack specified as an argument in this fashion will override any stack specified with the C<--stack> option. If a stack is not specified by neither argument nor option, then it defaults to the stack that is currently marked as the default stack. =head1 COMMAND OPTIONS =over 4 =item --stack NAME =item -s NAME Lock the stack with the given NAME. Defaults to the name of whichever stack is currently marked as the default stack. Use the L command to see the stacks in the repository. =back =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/App/Pinto/Command/log.pm000644 000766 000024 00000005303 13141540305 017656 0ustar00jeffstaff000000 000000 # ABSTRACT: show the revision logs of a stack package App::Pinto::Command::log; use strict; use warnings; #----------------------------------------------------------------------------- use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ sub command_names { return qw(log history) } #------------------------------------------------------------------------------ sub opt_spec { my ( $self, $app ) = @_; return ( [ 'stack|s=s' => 'Show history for this stack' ], [ 'with-diffs|d' => 'Show a diff for each revision'], [ 'diff-style=s' => 'Diff style (concise|detailed)' ], ); } #------------------------------------------------------------------------------ sub validate_args { my ( $self, $opts, $args ) = @_; $self->usage_error('Multiple arguments are not allowed') if @{$args} > 1; $opts->{stack} = $args->[0] if $args->[0]; return 1; } #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME App::Pinto::Command::log - show the revision logs of a stack =head1 VERSION version 0.14 =head1 SYNOPSIS pinto --root=REPOSITORY_ROOT log [STACK] [OPTIONS] =head1 DESCRIPTION !! THIS COMMAND IS EXPERIMENTAL !! This command shows the revision logs for the stack. =head1 COMMAND ARGUMENTS As an alternative to the C<--stack> option, you can specify it as an argument. So the following examples are equivalent: pinto --root REPOSITORY_ROOT log --stack=dev pinto --root REPOSITORY_ROOT log dev A C argument will override anything specified with the C<--stack> option. If the stack is not specified using neither argument nor option, then the logs of the default stack will be shown. =head1 COMMAND OPTIONS =over 4 =item --with-diffs =item -d For each revision, also show the diff from the previous revision. If the C environment varaible is set to a true value, a detailed diff will be shown. =item --stack NAME =item -s NAME Show the logs of the stack with the given NAME. Defaults to the name of whichever stack is currently marked as the default stack. Use the L command to see the stacks in the repository. =back =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/App/Pinto/Command/look.pm000644 000766 000024 00000006650 13141540305 020047 0ustar00jeffstaff000000 000000 # ABSTRACT: unpack and explore distributions with your shell package App::Pinto::Command::look; use strict; use warnings; use Pinto::Util qw(is_remote_repo); #------------------------------------------------------------------------------ use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ sub command_names { return qw(look) } #------------------------------------------------------------------------------ sub opt_spec { my ( $self, $app ) = @_; return ( [ 'stack|s=s' => 'Resolve targets against this stack' ], ); } #------------------------------------------------------------------------------ sub validate_args { my ( $self, $opts, $args ) = @_; $self->usage_error('Requires at least one target') unless @{$args}; return 1; } #------------------------------------------------------------------------------ sub args_attribute { return 'targets' } #------------------------------------------------------------------------------ sub args_from_stdin { return 1 } #------------------------------------------------------------------------------ sub execute { my ( $self, $opts, $args ) = @_; my $global_opts = $self->app->global_options; die "Cannot look into remote repositories (yet)\n" if is_remote_repo( $global_opts->{root} ); return $self->SUPER::execute($opts, $args); }; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME App::Pinto::Command::look - unpack and explore distributions with your shell =head1 VERSION version 0.14 =head1 SYNOPSIS pinto --root=REPOSITORY_ROOT look [OPTIONS] TARGET ... =head1 DESCRIPTION Unpack one or more distributions and explore its contents with your shell. This is handy if you want to manually inspect a distribution before use. At present, this command only works with local repositories and distributions that are already in the repository. At present, this command only works with local repositories. =head1 COMMAND ARGUMENTS Arguments are the targets you wish to look at. Targets can be specified as packages or distributions, such as: Some::Package Some::Other::Package AUTHOR/Some-Dist-1.2.tar.gz AUTHOR/Some-Other-Dist-1.3.zip You can also pipe arguments to this command over STDIN. In that case, blank lines and lines that look like comments (i.e. starting with "#" or ';') will be ignored. =head1 COMMAND OPTIONS =over 4 =item --stack=NAME =item -s NAME Resolve package targets against the stack with the given NAME. Defaults to the name of whichever stack is currently marked as the default stack. For distribution targets (i.e. those specified with a complete AUTHOR/filename) the C<--stack> option has no effect. =back =head1 ENVIRONMENT VARIABLES =over 4 =item C Sets the path to the command Pinto will use for the interactive shell. If this is not set, Pinto defaults to either C or C. =back =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/App/Pinto/Command/manual.pm000644 000766 000024 00000004627 13141540305 020362 0ustar00jeffstaff000000 000000 # ABSTRACT: show the full manual for a command package App::Pinto::Command::manual; use strict; use warnings; use Pod::Usage qw(pod2usage); use base qw(App::Pinto::Command); #------------------------------------------------------------------------------- our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------- sub command_names { return qw( manual man --man ) } #----------------------------------------------------------------------------- sub validate_args { my ( $self, $opts, $args ) = @_; $self->usage_error("Must specify a command") if @{$args} != 1; return 1; } #------------------------------------------------------------------------------- # This was stolen from App::Cmd::Command::help sub execute { my ( $self, $opts, $args ) = @_; my ( $cmd, undef, undef ) = $self->app->prepare_command(@$args); my $class = ref $cmd; # An invalid command name was specified, so the fallback command class # was returned. Rather than showing the (unhelpful) manual for # App::Cmd::Command::commands, we will just bail out and let App::Cmd # show the usual 'unrecognized command' message. return 1 if $class eq 'App::Cmd::Command::commands'; ( my $relative_path = $class ) =~ s< :: >xmsg; $relative_path .= '.pm'; my $absolute_path = $INC{$relative_path} or die "No manual available for $class\n"; pod2usage( -verbose => 2, -input => $absolute_path, -exitval => 0 ); return 1; } #------------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME App::Pinto::Command::manual - show the full manual for a command =head1 VERSION version 0.14 =head1 SYNOPSIS pinto manual COMMAND =head1 DESCRIPTION This command shows the complete user manual for a pinto COMMAND. =head1 COMMAND ARGUMENTS The argument to this command is the name of the command for which you would like to see the manual. You can also use the L command to get a brief summary of the command. =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/App/Pinto/Command/merge.pm000644 000766 000024 00000006626 13141540305 020205 0ustar00jeffstaff000000 000000 # ABSTRACT: join two stack histories together package App::Pinto::Command::merge; use strict; use warnings; #----------------------------------------------------------------------------- use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ sub command_names { return qw(merge) } #------------------------------------------------------------------------------ sub opt_spec { my ( $self, $app ) = @_; return (); } #------------------------------------------------------------------------------ sub validate_args { my ( $self, $opts, $args ) = @_; my $arg_count = @{$args}; $self->usage_error("Must specify a stack to merge from") if not $arg_count; $self->usage_error("Too many arguments") if $arg_count > 2; $opts->{stack} = $args->[0]; $opts->{into_stack} = $args->[1]; return 1; } #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME App::Pinto::Command::merge - join two stack histories together =head1 VERSION version 0.14 =head1 SYNOPSIS pinto --root=REPOSITORY_ROOT merge [OPTIONS] STACK [INTO_STACK] =head1 DESCRIPTION !! THIS COMMAND IS EXPERIMENTAL !! This command joins the history of one stack with another. At present, it is only capable of doing a "fast-forward" merge when the head of STACK is a direct descendant of the head of INTO_STACK. =head1 COMMAND ARGUMENTS The first mandatory argument is the name of the stack to merge from. The second optional argument is the name of the stack to merge to. If the second argument is not specified, it defaults to whichever stack is currently marked as the default. Here are some examples: pinto ... merge dev # Merge the "dev" stack into the default stack pinto ... merge dev prod # Merge the "dev" stack into the "prod" stack =head1 COMMAND OPTIONS =over 4 =item --dry-run Go through all the motions, but do not actually commit any changes to the repository. At the conclusion, a diff showing the changes that would have been made will be displayed. Use this option to see how upgrades would potentially impact the stack. =item --message=TEXT =item -m TEXT Use TEXT as the revision history log message. If you do not use the C<--message> option or the C<--use-default-message> option, then you will be prompted to enter the message via your text editor. Use the C or C or C environment variables to control which editor is used. A log message is not required whenever the C<--dry-run> option is set, or if the action did not yield any changes to the repository. =item --use-default-message =item -M Use the default value for the revision history log message. Pinto will generate a semi-informative log message just based on the command and its arguments. If you set an explicit message with C<--message>, the C<--use- default-message> option will be silently ignored. =back =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/App/Pinto/Command/migrate.pm000644 000766 000024 00000005163 13141540305 020531 0ustar00jeffstaff000000 000000 # ABSTRACT: migrate repository to a new version package App::Pinto::Command::migrate; use strict; use warnings; use Class::Load; use Pinto::Util qw(is_remote_repo); #----------------------------------------------------------------------------- use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ sub validate_args { my ( $self, $opts, $args ) = @_; $self->usage_error('Arguments are not allowed') if @{$args}; return 1; } #------------------------------------------------------------------------------ sub execute { my ( $self, $opts, $args ) = @_; my $global_opts = $self->app->global_options; die "Must specify a repository root directory\n" unless $global_opts->{root} ||= $ENV{PINTO_REPOSITORY_ROOT}; die "Cannot migrate remote repositories\n" if is_remote_repo( $global_opts->{root} ); my $class = $self->load_migrator; my $migrator = $class->new( %{$global_opts} ); $migrator->migrate; return 0; } #------------------------------------------------------------------------------ sub load_migrator { my $class = 'Pinto::Migrator'; my ( $ok, $error ) = Class::Load::try_load_class($class); return $class if $ok; my $msg = $error =~ m/Can't locate .* in \@INC/ ## no critic (ExtendedFormat) ? "Must install Pinto to migrate repositories\n" : $error; die $msg; } #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME App::Pinto::Command::migrate - migrate repository to a new version =head1 VERSION version 0.14 =head1 SYNOPSIS pinto --root=REPOSITORY_ROOT migrate =head1 DESCRIPTION This command migrates an existing repository to a format that is compatible with the current version of L that you have. At present, it only works for repositories created with version 0.070 or later. If you need to migrate a repository that was created with an earlier version, please contact C and I'll help you come up with a migration plan that fits your situation. =head1 COMMAND ARGUMENTS None. =head1 COMMAND OPTIONS None. =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/App/Pinto/Command/new.pm000644 000766 000024 00000005046 13141540305 017672 0ustar00jeffstaff000000 000000 # ABSTRACT: create a new empty stack package App::Pinto::Command::new; use strict; use warnings; #----------------------------------------------------------------------------- use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ sub opt_spec { my ( $self, $app ) = @_; return ( [ 'default' => 'Make the new stack the default stack' ], [ 'description|d=s' => 'Brief description of the stack' ], [ 'target-perl-version|tpv=s' => 'Target Perl version for this stack' ], ); } #------------------------------------------------------------------------------ sub validate_args { my ( $self, $opts, $args ) = @_; $self->usage_error('Must specify exactly one stack') if @{$args} != 1; $opts->{stack} = $args->[0]; return 1; } #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME App::Pinto::Command::new - create a new empty stack =head1 VERSION version 0.14 =head1 SYNOPSIS pinto --root=REPOSITORY_ROOT new [OPTIONS] STACK =head1 DESCRIPTION This command creates a new empty stack. See the L command to create a new stack from another one, or the L command to change a stack's properties after it has been created. =head1 COMMAND ARGUMENTS The required argument is the name of the stack you wish to create. Stack names must be alphanumeric plus hyphens and underscores, and are not case sensitive. =head1 COMMAND OPTIONS =over 4 =item --default Also mark the new stack as the default stack. =item --description=TEXT =item -d TEXT Use TEXT for the description of the stack. =item --target-perl-version=VERSION =item --tpv=VERSION Sets the target perl version for the stack. Pinto never pulls distributions for prerequisites that are satisfied by the core of the target perl version. VERSION must be a valid version number for an existing release of perl 5. Defaults to the global target Perl version of this repository. =back =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/App/Pinto/Command/nop.pm000644 000766 000024 00000003433 13141540305 017673 0ustar00jeffstaff000000 000000 # ABSTRACT: do nothing package App::Pinto::Command::nop; use strict; use warnings; #----------------------------------------------------------------------------- use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ sub opt_spec { my ( $self, $app ) = @_; return ( [ 'sleep=i' => 'seconds to sleep before exiting' ], ); } #------------------------------------------------------------------------------ sub validate_args { my ( $self, $opts, $args ) = @_; $self->SUPER::validate_args( $opts, $args ); $self->usage_error('Sleep time must be positive integer') if defined $opts->{sleep} && $opts->{sleep} < 1; return 1; } #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME App::Pinto::Command::nop - do nothing =head1 VERSION version 0.14 =head1 SYNOPSIS pinto --root=REPOSITORY_ROOT nop [OPTIONS] =head1 DESCRIPTION This command is a no-operation. It puts a shared lock on the repository, but does not perform any operations. This is really only used for diagnostic purposes. So don't worry about it too much. =head1 COMMAND ARGUMENTS None. =head1 COMMAND OPTIONS =over 4 =item --sleep N Sleep for N seconds before releasing the lock and exiting. Default is 0. =back =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/App/Pinto/Command/pin.pm000644 000766 000024 00000010737 13141540305 017672 0ustar00jeffstaff000000 000000 # ABSTRACT: force a package to stay in a stack package App::Pinto::Command::pin; use strict; use warnings; #------------------------------------------------------------------------------ use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #----------------------------------------------------------------------------- sub opt_spec { my ( $self, $app ) = @_; return ( [ 'diff-style=s' => 'Set style of diff reports' ], [ 'dry-run' => 'Do not commit any changes' ], [ 'message|m=s' => 'Message to describe the change' ], [ 'stack|s=s' => 'Pin targets to this stack' ], [ 'use-default-message|M' => 'Use the generated message' ], ); } #------------------------------------------------------------------------------ sub args_attribute { return 'targets' } #------------------------------------------------------------------------------ sub args_from_stdin { return 1 } #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME App::Pinto::Command::pin - force a package to stay in a stack =head1 VERSION version 0.14 =head1 SYNOPSIS pinto --root=REPOSITORY_ROOT pin [OPTIONS] TARGET ... =head1 DESCRIPTION This command pins a package so that it cannot be changed even if a different version is added or pulled to the stack The pin is local to the stack and does not affect any other stacks. A package must be registered on the stack before you can pin it. To bring a package onto the stack, use the L or L commands. To remove the pin from a package, see the L command. When pinning, all its sister packages in that distribution also become pinned. Pinned packages also cannot be unregistered from the stack or deleted from the repository without the C<--force> option. =head1 COMMAND ARGUMENTS Arguments are the targets you wish to unpin. Targets can be specified as packages or distributions, such as: Some::Package Some::Other::Package AUTHOR/Some-Dist-1.2.tar.gz AUTHOR/Some-Other-Dist-1.3.zip You can also pipe arguments to this command over STDIN. In that case, blank lines and lines that look like comments (i.e. starting with "#" or ';') will be ignored. =head1 COMMAND OPTIONS =over 4 =item --diff-style=STYLE Controls the style of the diff reports. STYLE must be either C or C. Concise reports show only one record for each distribution added or deleted. Detailed reports show one record for every package added or deleted. The default style is C. However, the default style can changed by setting the C environment variable to your preferred STYLE. This variable affects the default style for diff reports generated by all other commands too. =item --dry-run Go through all the motions, but do not actually commit any changes to the repository. Use this option to see how the command would potentially impact the stack. =item --message=TEXT =item -m TEXT Use TEXT as the revision history log message. If you do not use the C<--message> option or the C<--use-default-message> option, then you will be prompted to enter the message via your text editor. Use the C or C or C environment variables to control which editor is used. A log message is not required whenever the C<--dry-run> option is set, or if the action did not yield any changes to the repository. =item --stack=NAME Pins the package on the stack with the given NAME. Defaults to the name of whichever stack is currently marked as the default stack. Use the L command to see the stacks in the repository. =item --use-default-message =item -M Use the default value for the revision history log message. Pinto will generate a semi-informative log message just based on the command and its arguments. If you set an explicit message with C<--message>, the C<--use-default-message> option will be silently ignored. =back =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/App/Pinto/Command/props.pm000644 000766 000024 00000007657 13141540305 020256 0ustar00jeffstaff000000 000000 # ABSTRACT: show or set stack properties package App::Pinto::Command::props; use strict; use warnings; use Pinto::Util qw(interpolate); #----------------------------------------------------------------------------- use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ sub opt_spec { return ( [ 'format=s' => 'Format specification (See POD for details)' ], [ 'properties|prop|P=s%' => 'name=value pairs of properties' ], ); } #------------------------------------------------------------------------------ sub validate_args { my ( $self, $opts, $args ) = @_; $self->usage_error('Cannot specify multiple stacks') if @{$args} > 1; $opts->{format} = interpolate( $opts->{format} ) if exists $opts->{format}; $opts->{stack} = $args->[0] if $args->[0]; return 1; } #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME App::Pinto::Command::props - show or set stack properties =head1 VERSION version 0.14 =head1 SYNOPSIS pinto --root=REPOSITORY_ROOT props [OPTIONS] [STACK] =head1 DESCRIPTION This command shows or sets stack configuration properties. If the C<--properties> option is given, then the properties will be set. If the C<--properties> option is not given, then properties will just be shown. =head1 COMMAND ARGUMENTS If the C argument is given, then the properties for that stack will be set/shown. If the C argument is not given, then properties for the default stack will be set/shown. =head1 COMMAND OPTIONS =over 4 =item --format=FORMAT_SPECIFICATION Format the output using C-style placeholders. This only matters when showing properties. Valid placeholders are: Placeholder Meaning ----------------------------------------------------------------------------- %p Property name %v Package value =item --properties name=value =item --prop name=value =item -P name=value Specifies property names and values. You can repeat this option to set multiple properties. If the property with that name does not already exist, it will be created. Property names must be alphanumeric plus hyphens and underscores, and will be forced to lower case. Setting a property to an empty string will cause it to be deleted. Properties starting with the prefix C are reserved for internal use, SO DO NOT CREATE OR CHANGE THEM. =back =head1 SUPPORTED PROPERTIES The following properties are supported for each stack: =over 4 =item description A description of the stack, usually to inform users of the application and/or environment that the stack is intended for. For a new stack, defaults to "The STACK_NAME stack". For a copied stack, defaults to "Copy of stack STACK_NAME". =item target_perl_version The version of perl that this stack is targeted at. This is used to determine whether a particular package is satisfied by the perl core and therefore does not need to be added to the stack. It must be a version string or number for an existing perl release, and cannot be later than the latest version specified in your L. To target even newer perls, just install the latest version of L. Remember that Pinto is often installed as a stand-alone application, so you will need to update Pinto's copy of L - for example: cpanm -L /opt/local/pinto/ Module::CoreList =back =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/App/Pinto/Command/pull.pm000644 000766 000024 00000026112 13141540305 020052 0ustar00jeffstaff000000 000000 # ABSTRACT: pull archives from upstream repositories package App::Pinto::Command::pull; use strict; use warnings; #------------------------------------------------------------------------------ use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #----------------------------------------------------------------------------- sub opt_spec { my ( $self, $app ) = @_; return ( [ 'cascade' => 'Always pick latest upstream package' ], [ 'diff-style=s' => 'Set style of diff reports' ], [ 'dry-run' => 'Do not commit any changes' ], [ 'message|m=s' => 'Message to describe the change' ], [ 'no-fail' => 'Do not fail when there is an error' ], [ 'recurse!' => 'Recursively pull prereqs (negatable)' ], [ 'pin' => 'Pin the packages to the stack' ], [ 'skip-missing-prerequisite|k=s@' => 'Skip missing prereq (repeatable)' ], [ 'skip-all-missing-prerequisites|K' => 'Skip all missing prereqs' ], [ 'stack|s=s' => 'Put packages into this stack' ], [ 'use-default-message|M' => 'Use the generated message' ], [ 'with-development-prerequisites|wd' => 'Also pull prereqs for development' ], ); } #------------------------------------------------------------------------------ sub args_attribute { return 'targets' } #------------------------------------------------------------------------------ sub args_from_stdin { return 1 } #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer norecurse =head1 NAME App::Pinto::Command::pull - pull archives from upstream repositories =head1 VERSION version 0.14 =head1 SYNOPSIS pinto --root=REPOSITORY_ROOT pull [OPTIONS] TARGET ... =head1 DESCRIPTION This command locates packages in your upstream repositories and then pulls the distributions providing those packages into your repository and registers them on a stack. Then it recursively locates and pulls all the distributions that are necessary to satisfy their prerequisites. You can also request to directly pull particular distributions. When locating packages, Pinto first looks at the packages that already exist in the local repository, then Pinto looks at the packages that are available on the upstream repositories. =head1 COMMAND ARGUMENTS Arguments are the targets that you want to pull. Targets can be specified as packages (with or without a version specification) or as distributions. Targets can be expressed in a number of ways, so please see L below for more information. You can also pipe arguments to this command over STDIN. In that case, blank lines and lines that look like comments (i.e. starting with "#" or ';') will be ignored. =head1 COMMAND OPTIONS =over 4 =item --cascade !! THIS OPTION IS EXPERIMENTAL !! When searching for a package (or one of its prerequisites), always take the latest satisfactory version of the package found amongst B the upstream repositories, rather than just taking the B satisfactory version that is found. Remember that Pinto only searches the upstream repositories when the local repository does not already contain a satisfactory version of the package. =item --diff-style=STYLE Controls the style of the diff reports. STYLE must be either C or C. Concise reports show only one record for each distribution added or deleted. Detailed reports show one record for every package added or deleted. The default style is C. However, the default style can changed by setting the C environment variable to your preferred STYLE. This variable affects the default style for diff reports generated by all other commands too. =item --dry-run Go through all the motions, but do not actually commit any changes to the repository. At the conclusion, a diff showing the changes that would have been made will be displayed. Use this option to see how upgrades would potentially impact the stack. =item --no-fail !! THIS OPTION IS EXPERIMENTAL !! Normally, failure to pull a target (or its prerequisites) causes the command to immediately abort and rollback the changes to the repository. But if C<--no-fail> is set, then only the changes caused by the failed target (and its prerequisites) will be rolled back and the command will continue processing the remaining targets. This option is useful if you want to throw a list of targets into a repository and see which ones are problematic. Once you've fixed the broken ones, you can throw the whole list at the repository again. =item --message=TEXT =item -m TEXT Use TEXT as the revision history log message. If you do not use the C<--message> option or the C<--use-default-message> option, then you will be prompted to enter the message via your text editor. Use the C or C or C environment variables to control which editor is used. A log message is not required whenever the C<--dry-run> option is set, or if the action did not yield any changes to the repository. =item --pin Pins the packages to the stack, so they cannot be changed until you unpin them. Only the packages in the requested targets will be pinned -- packages in prerequisites will not be pinned. However, you may pin them separately with the L command if you so desire. =item --recurse =item --no-recurse Recursively pull any distributions required to satisfy prerequisites for the targets. The default value for this option can be configured in the F configuration file for the repository (it is usually set to 1). To disable recursion, use C<--no-recurse>. =item --skip-missing-prerequisite=PACKAGE =item -k PACKAGE !! THIS OPTION IS EXPERIMENTAL !! Skip any prerequisite with name PACKAGE if a satisfactory version cannot be found. However, a warning will be given whenever this occurrs. This option only has effect when recursively fetching prerequisites for the targets (See also the C<--recurse> option). This option can be repeated. =item --skip-all-missing-prerequisites =item -K !! THIS OPTION IS EXPERIMENTAL !! Skips all missing prerequisites if a satisfactory version cannot be found. However, a warning will be given whenever this occurrs. This option will silently override the C<--skip-missing-prerequisite> option and only has effect when recursively fetching prerequisites for the targets (See also the C<--recurse> option). =item --stack=NAME =item -s NAME Puts all the packages onto the stack with the given NAME. Defaults to the name of whichever stack is currently marked as the default stack. Use the L command to see the stacks in the repository. =item --use-default-message =item -M Use the default value for the revision history log message. Pinto will generate a semi-informative log message just based on the command and its arguments. If you set an explicit message with C<--message>, the C<--use- default-message> option will be silently ignored. =item --with-development-prerequisites =item --wd Also pull development prerequisites so you'll have everything you need to work on those distributions, in the event that you need to patch them in the future. Be aware that most distributions do not actually declare their development prerequisites. =back =head1 TARGETS Targets are a compact notation that identifies the things you want to pull into your repository. Targets come in two flavors: package targets and distribution targets. =head2 Package Targets A package target consists of a package name and (optionally) a version specification. Here are some examples: Foo::Bar # Any version of Foo::Bar Foo::Bar~1.2 # Foo::Bar version 1.2 or higher Foo::Bar==1.2 # Only version 1.2 of Foo::Bar Foo::Bar<1,2!=1.3,<=1.9 # Complex version range Package names are case-sensitive, and the version specification must follow the format used by L. All whitespace within the target will be discarded. If your version specification contains any special shell characters, take care to quote or escape them in your command. In all cases, pinto queries the local repository and then each upstream repository in order, and pulls the first distribution it can find that provides a package which satisfies the version specification. =head2 Distribution Targets A distribution target consists of an author ID, zero or more subdirectories, and the distribution name and version number. This corresponds to the actual path where the distribution archive lives in the repository or CPAN mirror. Here are some examples. SHAKESPEARE/King-Lear-1.2.tar.gz # A specific distribution SHAKESPEARE/tragedies/Hamlet-4.2.tar.gz # Same, but with a subdirectory The author ID will always be forced to uppercase, but the reset of the path is case-sensitive. =head2 Caveats L has no strict rules on how packages are versioned. It is quite common to see a package with the same verison number (or no version at all) in many releases of a distribution. So when you specify a package target with a precise version or version range, what you actually get is the latest distribution (chronologically) that has a package which satisfies the target. Most of the time this works out fine because you usally pull the "main module" of the distribution and authors always increment that version in each release. Since most CPAN mirrors only report the latest version of a package they have, they often cannot satisfy package targets that have a precise version specification. However, the mirror at L is special and can locate a precise version of any package. Package targets always resolve to production releases, unless you specify a precise developer release version (e.g. C). But since most CPAN mirrors do not index developer releases, this only works when using the mirror at L. However, you can usually pull a developer release from any mirror by using a distribution target. Remember that developer releases are those with an underscore in the version number. For repositories created with Pinto version 0.098 or later, the first upstream source is C (unless you configure it otherwise). For repositories created with older versions, you can manually add C to the C parameter in the configuration file located at F<.pinto/config/pinto.ini> within the repository. =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/App/Pinto/Command/register.pm000644 000766 000024 00000010306 13141540305 020720 0ustar00jeffstaff000000 000000 # ABSTRACT: put existing packages on a stack package App::Pinto::Command::register; use strict; use warnings; #------------------------------------------------------------------------------ use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #----------------------------------------------------------------------------- sub opt_spec { my ( $self, $app ) = @_; return ( [ 'diff-style=s' => 'Set style of diff reports' ], [ 'dry-run' => 'Do not commit any changes' ], [ 'message|m=s' => 'Message to describe the change' ], [ 'pin' => 'Pin packages to the stack' ], [ 'stack|s=s' => 'Remove packages from this stack' ], [ 'use-default-message|M' => 'Use the generated message' ], ); } #------------------------------------------------------------------------------ sub args_attribute { return 'targets' } #------------------------------------------------------------------------------ sub args_from_stdin { return 1 } #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME App::Pinto::Command::register - put existing packages on a stack =head1 VERSION version 0.14 =head1 SYNOPSIS pinto --root=REPOSITORY_ROOT register [OPTIONS] ARCHIVE ... =head1 DESCRIPTION !! THIS COMMAND IS EXPERIMENTAL !! This command adds packages to a stack. The archive which contains those packages must already exist in the repository. To add packages from an archive in an upstream repository, use the L command. To add packages from a local archive, use the L command. =head1 COMMAND ARGUMENTS Arguments are the archives you want to register. Archives are specified as C. For example: SHAKESPEARE/King-Lear-1.2.tar.gz You can also pipe arguments to this command over STDIN. In that case, blank lines and lines that look like comments (i.e. starting with "#" or ';') will be ignored. =head1 COMMAND OPTIONS =over 4 =item --diff-style=STYLE Controls the style of the diff reports. STYLE must be either C or C. Concise reports show only one record for each distribution added or deleted. Detailed reports show one record for every package added or deleted. The default style is C. However, the default style can changed by setting the C environment variable to your preferred STYLE. This variable affects the default style for diff reports generated by all other commands too. =item --dry-run Go through all the motions, but do not actually commit any changes to the repository. Use this option to see how the command would potentially impact the stack. =item --message=TEXT =item -m TEXT Use TEXT as the revision history log message. If you do not use the C<--message> option or the C<--use-default-message> option, then you will be prompted to enter the message via your text editor. Use the C or C or C environment variables to control which editor is used. A log message is not required whenever the C<--dry-run> option is set, or if the action did not yield any changes to the repository. =item --stack=NAME =item -s NAME Registers the targets on the stack with the given NAME. Defaults to the name of whichever stack is currently marked as the default stack. Use the L command to see the stacks in the repository. =item --use-default-message =item -M Use the default value for the revision history log message. Pinto will generate a semi-informative log message just based on the command and its arguments. If you set an explicit message with C<--message>, the C<--use-default-message> option will be silently ignored. =back =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/App/Pinto/Command/rename.pm000644 000766 000024 00000004044 13141540305 020345 0ustar00jeffstaff000000 000000 # ABSTRACT: change the name of a stack package App::Pinto::Command::rename; use strict; use warnings; #----------------------------------------------------------------------------- use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ sub command_names { return qw(rename mv) } #------------------------------------------------------------------------------ sub validate_args { my ( $self, $opts, $args ) = @_; $self->usage_error('Must specify STACK and TO_STACK') if @{$args} != 2; $opts->{stack} = $args->[0]; $opts->{to_stack} = $args->[1]; return 1; } #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME App::Pinto::Command::rename - change the name of a stack =head1 VERSION version 0.14 =head1 SYNOPSIS pinto --root=REPOSITORY_ROOT rename [OPTIONS] STACK TO_STACK =head1 DESCRIPTION This command changes the name of an existing stack. Once the name is changed, you will not be able to perform commands or access archives via the old stack name. See the L command to create a new empty stack, or the L command to duplicate an existing stack, or the L command to change a stack's properties after it has been created. =head1 COMMAND ARGUMENTS The two required arguments are the current name and new name of the stack. Stack names must be alphanumeric plus hyphens and underscores, and are not case-sensitive. =head1 COMMAND OPTIONS NONE. =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/App/Pinto/Command/reset.pm000644 000766 000024 00000006121 13141540305 020216 0ustar00jeffstaff000000 000000 # ABSTRACT: reset stack to a prior revision package App::Pinto::Command::reset; use strict; use warnings; #----------------------------------------------------------------------------- use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ sub command_names { return qw(reset) } #------------------------------------------------------------------------------ sub opt_spec { my ( $self, $app ) = @_; return ( [ 'force' => 'Reset even if revision is not ancestor' ], [ 'stack|s=s' => 'Reset this stack' ], ); } #------------------------------------------------------------------------------ sub validate_args { my ( $self, $opts, $args ) = @_; $self->usage_error("Must specify a revision") if not @{$args}; my $arg_count = @{$args}; # If there is one arg, then it is revision and stack is default # If there are 2 args, then the 1st is stack and 2nd is revision $opts->{revision} = $arg_count == 1 ? $args->[0] : $args->[1]; $opts->{stack} = $args->[0] if $arg_count == 2; return 1; } #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME App::Pinto::Command::reset - reset stack to a prior revision =head1 VERSION version 0.14 =head1 SYNOPSIS pinto --root=REPOSITORY_ROOT reset [OPTIONS] REVISION =head1 DESCRIPTION !! THIS COMMAND IS EXPERIMENTAL !! This command moves the head of the stack to a prior revision, thereby discarding subsequent revisions. See the L command to restore the stack to a prior revision by creating a new revision. =head1 COMMAND ARGUMENTS The arguments are the name of the stack and the id of the revision to reset to. If the stack is not specified, then it defaults to whichever stack is currently marked as the default. The stack can also be specified using the C<--stack> option. Some examples: pinto ... reset af01256e # Reset default stack to revision af01256e pinto ... reset mystack af01256e # Reset mystack to revision af0125e =head1 COMMAND OPTIONS =over 4 =item --force Force reset even if the revision is not actually an ancestor. Normally, you can only reset to a revision that the stack has actually been at. =item --stack=NAME =item -s NAME Peform reset on the stack with the given NAME. Defaults to the name of whichever stack is currently marked as the default stack. Use the L command to see the stacks in the repository. This option is silently ignored if the stack is specified as a command argument instead. =back =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/App/Pinto/Command/revert.pm000644 000766 000024 00000011130 13141540305 020377 0ustar00jeffstaff000000 000000 # ABSTRACT: revert stack to a prior revision package App::Pinto::Command::revert; use strict; use warnings; #----------------------------------------------------------------------------- use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ sub command_names { return qw(revert) } #------------------------------------------------------------------------------ sub opt_spec { my ( $self, $app ) = @_; return ( [ 'dry-run' => 'Do not commit any changes' ], [ 'force' => 'Revert even if revision is not ancestor' ], [ 'message|m=s' => 'Message to describe the change' ], [ 'stack|s=s' => 'Revert this stack' ], [ 'use-default-message|M' => 'Use the generated message' ], ); } #------------------------------------------------------------------------------ sub validate_args { my ( $self, $opts, $args ) = @_; my $arg_count = @{$args}; # If there is one arg, then it is revision and stack is default # If there are 2 args, then the 1st is stack and 2nd is revision $opts->{revision} = $arg_count == 1 ? $args->[0] : $args->[1]; $opts->{stack} = $args->[0] if $arg_count == 2; return 1; } #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME App::Pinto::Command::revert - revert stack to a prior revision =head1 VERSION version 0.14 =head1 SYNOPSIS pinto --root=REPOSITORY_ROOT revert [OPTIONS] [STACK] [REVISION] =head1 DESCRIPTION !! THIS COMMAND IS EXPERIMENTAL !! This command restores the head of the stack to a prior state by creating a new revision that matches the prior state. See the L command to move the head back to a prior state and discard subsequent revisions. =head1 COMMAND ARGUMENTS The arguments are the name of the stack and/or the id of the revision to revert to. If the revision id is not specified, it defaults to the immediate parent of head revision of the stack. If the stack is not specified, then it defaults to whichever stack is currently marked as the default. The stack can also be specified using the C<--stack> option. Some examples: pinto ... revert # Revert default stack to previous revision pinto ... revert af01256e # Revert default stack to revision af01256e pinto ... revert mystack af01256e # Revert mystack to revision af0125e =head1 COMMAND OPTIONS =over 4 =item --dry-run Go through all the motions, but do not actually commit any changes to the repository. At the conclusion, a diff showing the changes that would have been made will be displayed. Use this option to see how upgrades would potentially impact the stack. =item --force Force reversion even if the revision is not actually an ancestor. Normally, you can only revert to a revision that the stack has actually been at. This option only has effect if you specify a target revision argument. =item --message=TEXT =item -m TEXT Use TEXT as the revision history log message. If you do not use the C<--message> option or the C<--use-default-message> option, then you will be prompted to enter the message via your text editor. Use the C or C or C environment variables to control which editor is used. A log message is not required whenever the C<--dry-run> option is set, or if the action did not yield any changes to the repository. =item --stack=NAME =item -s NAME Peform reversion on the stack with the given NAME. Defaults to the name of whichever stack is currently marked as the default stack. Use the L command to see the stacks in the repository. This option is silently ignored if the stack is specified as a command argument instead. =item --use-default-message =item -M Use the default value for the revision history log message. Pinto will generate a semi-informative log message just based on the command and its arguments. If you set an explicit message with C<--message>, the C<--use- default-message> option will be silently ignored. =back =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/App/Pinto/Command/roots.pm000644 000766 000024 00000012173 13141540305 020246 0ustar00jeffstaff000000 000000 package App::Pinto::Command::roots; # ABSTRACT: show the roots of a stack use strict; use warnings; use Pinto::Util qw(interpolate); #----------------------------------------------------------------------------- use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ sub command_names { return qw( roots ) } #------------------------------------------------------------------------------ sub opt_spec { my ( $self, $app ) = @_; return ( [ 'format=s' => 'Format specification (See POD for details)' ], [ 'stack|s=s' => 'Show roots of this stack' ], ); } #------------------------------------------------------------------------------ sub validate_args { my ( $self, $opts, $args ) = @_; $self->usage_error('Multiple arguments are not allowed') if @{$args} > 1; $opts->{format} = interpolate( $opts->{format} ) if exists $opts->{format}; $opts->{stack} = $args->[0] if $args->[0]; return 1; } #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME App::Pinto::Command::roots - show the roots of a stack =head1 VERSION version 0.14 =head1 SYNOPSIS pinto --root=REPOSITORY_ROOT roots [OPTIONS] =head1 DESCRIPTION !! THIS COMMAND IS EXPERIMENTAL !! This command lists the distributions that are the roots of the dependency tree that includes all the distributions in the stack. In other words, it tells you which distributions or packages you would need to install from this stack to get all the other distribution in the stack. =head1 COMMAND ARGUMENTS As an alternative to the C<--stack> option, you can also specify the stack as an argument. So the following examples are equivalent: pinto --root REPOSITORY_ROOT list --stack dev pinto --root REPOSITORY_ROOT list dev A stack specified as an argument in this fashion will override any stack specified with the C<--stack> option. If a stack is not specified by neither argument nor option, then it defaults to the stack that is currently marked as the default stack. =head1 COMMAND OPTIONS =over 4 =item --format FORMAT_SPECIFICATION Format of the output of each record using C-style placeholders. Valid placeholders are: Placeholder Meaning ----------------------------------------------------------------------------- %p Package name %P Package name-version %v Package version %y Pin status: (!) = is pinned %a Distribution author %f Distribution archive filename %m Distribution maturity: (d) = developer, (r) = release %M Distribution main module %h Distribution index path [1] %H Distribution physical path [2] %s Distribution origin: (l) = local, (f) = foreign %S Distribution source %d Distribution name %D Distribution name-version %V Distribution version %u Distribution URI %% A literal '%' [1]: The index path is always a Unix-style path fragment, as it appears in the 02packages.details.txt index file. [2]: The physical path is always in the native style for this OS, and is relative to the root directory of the repository. You can also specify the minimum field widths and left or right justification, using the usual notation. The default format is C<%a/%f>. =item --stack NAME =item -s NAME List the roots of the stack with the given NAME. Defaults to the name of whichever stack is currently marked as the default stack. Use the L command to see the stacks in the repository. =back =head1 EXAMPLES Install all modules in the stack in one shot: pinto -r /myrepo roots | cpanm --mirror-only --mirror file:///myrepo Generate a basic F that would install all modules in the stack: pinto -r /myrepo roots --format 'requires q{%M};' > cpanfile =head1 CAVEATS This list of roots produced by this command is not always correct. Many Perl distributions use dynamic configuration so you can't truly know what distributions need to be installed until you actually try and install them. Pinto relies entirely on the static META files to determine prerequisites. But in most cases, this list is pretty accurate. When it is wrong, it typically includes too many distributions rather than too few. At best, this will have no impact because your installer will have already installed them as prerequisites. At worst, you may be installing a distribution that you don't really need. =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/App/Pinto/Command/stacks.pm000644 000766 000024 00000004755 13141540305 020377 0ustar00jeffstaff000000 000000 # ABSTRACT: show available stacks package App::Pinto::Command::stacks; use strict; use warnings; use Pinto::Util qw(interpolate); #----------------------------------------------------------------------------- use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ sub opt_spec { my ( $self, $app ) = @_; return ( [ 'format=s' => 'Format of the listing (See POD for details)' ], ); } #------------------------------------------------------------------------------ sub validate_args { my ( $self, $opts, $args ) = @_; $self->usage_error('No arguments are allowed') if @{$args}; $opts->{format} = interpolate( $opts->{format} ) if exists $opts->{format}; return 1; } #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME App::Pinto::Command::stacks - show available stacks =head1 VERSION version 0.14 =head1 SYNOPSIS pinto --root=REPOSITORY_ROOT stacks [OPTIONS] =head1 DESCRIPTION This command lists the names (and some other details) of all the stacks currently available in the repository. =head1 COMMAND ARGUMENTS None. =head1 COMMAND OPTIONS =over 4 =item --format=FORMAT_SPECIFICATION Format each record in the listing with C-style placeholders. Valid placeholders are: Placeholder Meaning ----------------------------------------------------------------------------- %k Stack name %e Stack description %M Stack default status (*) = default %L Stack lock status (!) = locked %i Stack head revision id prefix $I Stack head revision id %g Stack head revision message (full) %t Stack head revision message title %b Stack head revision message body %u Stack head revision committed-on %j Stack head revision committed-by %% A literal '%' =back =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/App/Pinto/Command/statistics.pm000644 000766 000024 00000003527 13141540305 021275 0ustar00jeffstaff000000 000000 # ABSTRACT: report statistics about the repository package App::Pinto::Command::statistics; use strict; use warnings; #----------------------------------------------------------------------------- use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ # TODO: Add a --stack option, just like the "list" command. #------------------------------------------------------------------------------ sub command_names { return qw( statistics stats ) } #------------------------------------------------------------------------------ sub validate_args { my ( $self, $opts, $args ) = @_; $self->usage_error('Multiple arguments are not allowed') if @{$args} > 1; $opts->{stack} = $args->[0] if $args->[0]; return 1; } #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME App::Pinto::Command::statistics - report statistics about the repository =head1 VERSION version 0.14 =head1 SYNOPSIS pinto --root=REPOSITORY_ROOT statistics [STACK] =head1 DESCRIPTION !! THIS COMMAND IS EXPERIMENTAL !! This command reports some statistics about the repository. =head1 COMMAND ARGUMENTS The argument is the name of the stack you wish to see the statistics for. If you do not specify a stack, then the default stack will be used. =head1 COMMAND OPTIONS None. =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/App/Pinto/Command/thanks.pm000644 000766 000024 00000002761 13141540305 020372 0ustar00jeffstaff000000 000000 # ABSTRACT: show some gratitude package App::Pinto::Command::thanks; use strict; use warnings; use Path::Class qw(dir); use Pod::Usage qw(pod2usage); use base qw(App::Pinto::Command); #------------------------------------------------------------------------------- our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------- sub execute { my ( $self, $opts, $args ) = @_; my $path; for my $dir (@INC) { my $maybe = dir($dir)->file(qw(Pinto Manual Thanks.pod)); do { $path = $maybe->stringify; last } if -f $maybe; } die "Could not find the Thanks pod.\n" if not $path; pod2usage( -verbose => 99, -sections => 'THANK YOU', -input => $path, -exitval => 0, ); return 1; } #------------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME App::Pinto::Command::thanks - show some gratitude =head1 VERSION version 0.14 =head1 SYNOPSIS pinto thanks =head1 DESCRIPTION This command shows our appreciation to those who contributed to the Pinto crowdfunding campaign. =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/App/Pinto/Command/unlock.pm000644 000766 000024 00000004473 13141540305 020377 0ustar00jeffstaff000000 000000 # ABSTRACT: mark a stack as writable package App::Pinto::Command::unlock; use strict; use warnings; #----------------------------------------------------------------------------- use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ sub opt_spec { my ( $self, $app ) = @_; return ( [ 'stack|s=s' => 'Unlock this stack' ], ); } #------------------------------------------------------------------------------ sub validate_args { my ( $self, $opts, $args ) = @_; $self->usage_error('Multiple arguments are not allowed') if @{$args} > 1; $opts->{stack} = $args->[0] if $args->[0]; return 1; } #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME App::Pinto::Command::unlock - mark a stack as writable =head1 VERSION version 0.14 =head1 SYNOPSIS pinto --root=REPOSITORY_ROOT unlock [OPTIONS] =head1 DESCRIPTION This command unlocks a stack so that its packages can be changed. Unlocking a stack does not cause an event in the revision history, so reverting the stack will not restore the lock. To lock a stack, use the L command. =head1 COMMAND ARGUMENTS As an alternative to the C<--stack> option, you can also specify the stack as an argument. So the following examples are equivalent: pinto --root REPOSITORY_ROOT unlock --stack dev pinto --root REPOSITORY_ROOT unlock dev A stack specified as an argument in this fashion will override any stack specified with the C<--stack> option. =head1 COMMAND OPTIONS =over 4 =item --stack NAME =item -s NAME Unlock the stack with the given NAME. Defaults to the name of whichever stack is currently marked as the default stack. Use the L command to see the stacks in the repository. =back =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/App/Pinto/Command/unpin.pm000644 000766 000024 00000010267 13141540305 020233 0ustar00jeffstaff000000 000000 package App::Pinto::Command::unpin; # ABSTRACT: free packages that have been pinned use strict; use warnings; #------------------------------------------------------------------------------ use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #----------------------------------------------------------------------------- sub opt_spec { my ( $self, $app ) = @_; return ( [ 'diff-style=s' => 'Set style of diff reports' ], [ 'dry-run' => 'Do not commit any changes' ], [ 'message|m=s' => 'Message to describe the change' ], [ 'stack|s=s' => 'Unpin targets from this stack' ], [ 'use-default-message|M' => 'Use the generated message' ], ); } #------------------------------------------------------------------------------ sub args_attribute { return 'targets' } #------------------------------------------------------------------------------ sub args_from_stdin { return 1 } #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME App::Pinto::Command::unpin - free packages that have been pinned =head1 VERSION version 0.14 =head1 SYNOPSIS pinto --root=REPOSITORY_ROOT unpin [OPTIONS] TARGET ... =head1 DESCRIPTION This command unpins package in the stack, so that the stack can be merged into another stack with a newer packages, or so the packages can be upgraded to a newer version within this stack. =head1 COMMAND ARGUMENTS Arguments are the targets you wish to unpin. Targets can be specified as packages or distributions, such as: Some::Package Some::Other::Package AUTHOR/Some-Dist-1.2.tar.gz AUTHOR/Some-Other-Dist-1.3.zip When unpinning a distribution, all the packages in that distribution become unpinned. Likewise when unpinning a package, all its sister packages in the same distribution also become unpinned. You can also pipe arguments to this command over STDIN. In that case, blank lines and lines that look like comments (i.e. starting with "#" or ';') will be ignored. =head1 COMMAND OPTIONS =over 4 =item --diff-style=STYLE Controls the style of the diff reports. STYLE must be either C or C. Concise reports show only one record for each distribution added or deleted. Detailed reports show one record for every package added or deleted. The default style is C. However, the default style can changed by setting the C environment variable to your preferred STYLE. This variable affects the default style for diff reports generated by all other commands too. =item --dry-run Go through all the motions, but do not actually commit any changes to the repository. Use this option to see how the command would potentially impact the stack. =item --message=TEXT =item -m TEXT Use TEXT as the revision history log message. If you do not use the C<--message> option or the C<--use-default-message> option, then you will be prompted to enter the message via your text editor. Use the C or C or C environment variables to control which editor is used. A log message is not required whenever the C<--dry-run> option is set, or if the action did not yield any changes to the repository. =item --stack=NAME Unpins the package on the stack with the given NAME. Defaults to the name of whichever stack is currently marked as the default stack. Use the L command to see your stacks. =item --use-default-message =item -M Use the default value for the revision history log message. Pinto will generate a semi-informative log message just based on the command and its arguments. If you set an explicit message with C<--message>, the C<--use-default-message> option will be silently ignored. =back =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/App/Pinto/Command/unregister.pm000644 000766 000024 00000011417 13141540305 021267 0ustar00jeffstaff000000 000000 # ABSTRACT: remove packages from a stack package App::Pinto::Command::unregister; use strict; use warnings; #------------------------------------------------------------------------------ use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #----------------------------------------------------------------------------- sub opt_spec { my ( $self, $app ) = @_; return ( [ 'diff-style=s' => 'Set style of diff reports' ], [ 'dry-run' => 'Do not commit any changes' ], [ 'force' => 'Remove packages even if pinned' ], [ 'message|m=s' => 'Message to describe the change' ], [ 'stack|s=s' => 'Remove packages from this stack' ], [ 'use-default-message|M' => 'Use the generated message' ], ); } #------------------------------------------------------------------------------ sub args_attribute { return 'targets' } #------------------------------------------------------------------------------ sub args_from_stdin { return 1 } #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME App::Pinto::Command::unregister - remove packages from a stack =head1 VERSION version 0.14 =head1 SYNOPSIS pinto --root=REPOSITORY_ROOT unregister [OPTIONS] TARGET ... =head1 DESCRIPTION !! THIS COMMAND IS EXPERIMENTAL !! This command unregisters packages from a stack, so that they no longer appear in its index. However, the archives that contain the packages will remain in the repository. When unregistering, all the sister packages in the same distribution are also unregistered. To permanently remove an archive from the repository, use the L command. To re-register packages on a stack, use the L command. =head1 COMMAND ARGUMENTS Arguments are the targets that you want to unregister. Targets can be specified as packages (with or without version number) or distributions. For example: Foo::Bar # Unregisters any version of Foo::Bar Foo::Bar~1.2 # Unregisters Foo::Bar 1.2 or higher SHAKESPEARE/King-Lear-1.2.tar.gz # Unregisters a specific distribuion You can also pipe arguments to this command over STDIN. In that case, blank lines and lines that look like comments (i.e. starting with "#" or ';') will be ignored. =head1 COMMAND OPTIONS =over 4 =item --diff-style=STYLE Controls the style of the diff reports. STYLE must be either C or C. Concise reports show only one record for each distribution added or deleted. Detailed reports show one record for every package added or deleted. The default style is C. However, the default style can changed by setting the C environment variable to your preferred STYLE. This variable affects the default style for diff reports generated by all other commands too. =item --dry-run Go through all the motions, but do not actually commit any changes to the repository. Use this option to see how the command would potentially impact the stack. =item --force Unregister packages even if they are pinned to the stack. Take care when unregistering pinned packages, as it usually means that particular package is important to someone. =item --message=TEXT =item -m TEXT Use TEXT as the revision history log message. If you do not use the C<--message> option or the C<--use-default-message> option, then you will be prompted to enter the message via your text editor. Use the C or C or C environment variables to control which editor is used. A log message is not required whenever the C<--dry-run> option is set, or if the action did not yield any changes to the repository. =item --stack=NAME Unregisters the targets from the stack with the given NAME. Defaults to the name of whichever stack is currently marked as the default stack. Use the L command to see the stacks in the repository. =item --use-default-message =item -M Use the default value for the revision history log message. Pinto will generate a semi-informative log message just based on the command and its arguments. If you set an explicit message with C<--message>, the C<--use-default-message> option will be silently ignored. =back =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/App/Pinto/Command/update.pm000644 000766 000024 00000021170 13141540305 020357 0ustar00jeffstaff000000 000000 # ABSTRACT: update packages to latest versions package App::Pinto::Command::update; use strict; use warnings; #------------------------------------------------------------------------------ use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #------------------------------------------------------------------------------ sub command_names { return qw(update up) } #----------------------------------------------------------------------------- sub opt_spec { my ( $self, $app ) = @_; return ( [ 'all' => 'Update all packages in the stack' ], [ 'cascade' => 'Always pick latest upstream package' ], [ 'diff-style=s' => 'Set style of diff reports' ], [ 'dry-run' => 'Do not commit any changes' ], [ 'force' => 'Force update, even if pinned' ], [ 'message|m=s' => 'Message to describe the change' ], [ 'no-fail' => 'Do not fail when there is an error' ], [ 'recurse!' => 'Recursively pull prereqs (negatable)' ], [ 'pin' => 'Pin the packages to the stack' ], [ 'roots' => 'Update all root packages in the stack' ], [ 'skip-missing-prerequisite|k=s@' => 'Skip missing prereq (repeatable)' ], [ 'skip-all-missing-prerequisites|K' => 'Skip all missing prereqs' ], [ 'stack|s=s' => 'Update packages in this stack' ], [ 'use-default-message|M' => 'Use the generated message' ], [ 'with-development-prerequisites|wd' => 'Also pull prereqs for development' ], ); } #------------------------------------------------------------------------------ sub args_attribute { return 'targets' } #------------------------------------------------------------------------------ sub args_from_stdin { return not ($_[1]->{all} || $_[1]->{roots}) } #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer norecurse =head1 NAME App::Pinto::Command::update - update packages to latest versions =head1 VERSION version 0.14 =head1 SYNOPSIS pinto --root=REPOSITORY_ROOT update [OPTIONS] TARGET ... =head1 DESCRIPTION !! THIS COMMAND IS EXPERIMENTAL !!! This command updates packages in your repository to the newer versions in an updstream repository. By default, Pinto takes the first newer version that it finds. If the C<--cascade> option is used, then Pinto will take the newest version it finds among all the upstream repositories. =head1 COMMAND ARGUMENTS Arguments are the names of the pakcages you want to install. If using the C<--all> or C<--roots> options then arguments are not allowed. You can also pipe arguments to this command over STDIN. In that case, blank lines and lines that look like comments (i.e. starting with "#" or ';') will be ignored. If using the C<--all> or C<--roots> options, then input will not be read from STDIN. =head1 COMMAND OPTIONS =over 4 =item --all Update all distributions in the stack. We do not attempt to update locally added distributions unless C<--force> is used. If this option is used, then package names cannot be given as command arguments. See also the C<--roots> option. =item --cascade !! THIS OPTION IS EXPERIMENTAL !! When searching for a package (or one of its prerequisites), always take the latest satisfactory version of the package found amongst B the upstream repositories, rather than just taking the B newer version that is found. Remember that Pinto only searches the upstream repositories when the local repository does not already contain a satisfactory version of the package. =item --diff-style=STYLE Controls the style of the diff reports. STYLE must be either C or C. Concise reports show only one record for each distribution added or deleted. Detailed reports show one record for every package added or deleted. The default style is C. However, the default style can changed by setting the C environment variable to your preferred STYLE. This variable affects the default style for diff reports generated by all other commands too. =item --dry-run Go through all the motions, but do not actually commit any changes to the repository. At the conclusion, a diff showing the changes that would have been made will be displayed. Use this option to see how upgrades would potentially impact the stack. =item --force Forcibly unpin any packages that require updating. The pins will not be restored after a succesful update. =item --no-fail !! THIS OPTION IS EXPERIMENTAL !! Normally, failure to pull a target (or its prerequisites) causes the command to immediately abort and rollback the changes to the repository. But if C <--no-fail> is set, then only the changes caused by the failed target (and its prerequisites) will be rolled back and the command will continue processing the remaining targets. This option is useful if you want to throw a list of targets into a repository and see which ones are problematic. Once you've fixed the broken ones, you can throw the whole list at the repository again. =item --message=TEXT =item -m TEXT Use TEXT as the revision history log message. If you do not use the C<--message> option or the C<--use-default-message> option, then you will be prompted to enter the message via your text editor. Use the C or C or C environment variables to control which editor is used. A log message is not required whenever the C<--dry-run> option is set, or if the action did not yield any changes to the repository. =item --pin Pins the packages to the stack, so they cannot be changed until you unpin them. Only the packages in the requested targets will be pinned -- packages in prerequisites will not be pinned. However, you may pin them separately with the L command if you so desire. =item --recurse =item --no-recurse Recursively pull any distributions required to satisfy prerequisites for the targets. The default value for this option can be configured in the F configuration file for the repository (it is usually set to 1). To disable recursion, use C<--no-recurse>. =item --roots Updates the root distributions of the stack. We do not attempt to update locally added distributions unless C<--force> is used. If this option is used, then package names cannot be given as command arguments. See also the C<--all> option. =item --skip-missing-prerequisite=PACKAGE =item -k PACKAGE !! THIS OPTION IS EXPERIMENTAL !! Skip any prerequisite with name PACKAGE if a satisfactory version cannot be found. However, a warning will be given whenever this occurrs. This option only has effect when recursively fetching prerequisites for the targets (See also the C<--recurse> option). This option can be repeated. =item --skip-all-missing-prerequisites =item -K !! THIS OPTION IS EXPERIMENTAL !! Skips all missing prerequisites if a satisfactory version cannot be found. However, a warning will be given whenever this occurrs. This option will silently override the C<--skip-missing-prerequisite> option and only has effect when recursively fetching prerequisites for the targets (See also the C<--recurse> option). =item --stack=NAME =item -s NAME Puts all the packages onto the stack with the given NAME. Defaults to the name of whichever stack is currently marked as the default stack. Use the L command to see the stacks in the repository. =item --use-default-message =item -M Use the default value for the revision history log message. Pinto will generate a semi-informative log message just based on the command and its arguments. If you set an explicit message with C<--message>, the C<--use- default-message> option will be silently ignored. =item --with-development-prerequisites =item --wd Also pull development prerequisites so you'll have everything you need to work on those distributions, in the event that you need to patch them in the future. Be aware that most distributions do not actually declare their development prerequisites. =back =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/lib/App/Pinto/Command/verify.pm000644 000766 000024 00000002747 13141540305 020412 0ustar00jeffstaff000000 000000 package App::Pinto::Command::verify; # ABSTRACT: report archives that are missing use strict; use warnings; #----------------------------------------------------------------------------- use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.14'; # VERSION #----------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME App::Pinto::Command::verify - report archives that are missing =head1 VERSION version 0.14 =head1 SYNOPSIS pinto --root=REPOSITORY_ROOT verify =head1 DESCRIPTION This command reports distributions that are defined in the repository database, but the archives are not actually present. This could occur when L aborts unexpectedly due to an exception or you terminate a command prematurely. At the moment, it isn't clear how to fix this situation. In a future release you might be able to replace the archive for the distribution. But for now, this command simply lets you know if something has gone wrong in your repository. =head1 COMMAND ARGUMENTS None =head1 COMMAND OPTIONS None =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/etc/benchmark000755 000766 000024 00000004147 13141540305 015242 0ustar00jeffstaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use Pinto; use Pinto::Initializer; use Pinto::DistributionSpec; use File::Temp; use List::Util qw(sum); use Getopt::Long::Descriptive; #----------------------------------------------------------------------------- # Copyright 2013 Jeffrey Ryan Thalhammer #----------------------------------------------------------------------------- my @ops = qw(pin unpin unregister register); my ($opt, $usage) = describe_options( "$0 %o TARGETS", [ 'root|r=s', "Root of repository", ], [ 'ops|o=s@', "Operations to perform", ], [ 'iterations|i=i', "Number of iterations", { default => 100 } ], ); my @targets = @ARGV ? @ARGV : qw(THALJEF/Pinto-0.065.tar.gz); my %ops = map { lc $_ => 1 } $opt->ops ? @{$opt->ops} : @ops; my $root = $opt->root || File::Temp->newdir; my $iters = $opt->iterations; #----------------------------------------------------------------------------- { Pinto::Initializer->new->init(root => $root) unless -e $root; my $pinto = Pinto->new(root => "$root"); for my $target (@targets) { my $spec = Pinto::DistributionSpec->new($target); next if $pinto->repo->get_distribution(spec => $spec); $pinto->run(Pull => (targets => $target, message => "pulled $target")); } } #----------------------------------------------------------------------------- my @runs; for my $i (1..$iters) { print "Iteration $i: "; DB::enable_profile() if $i == $iters && defined $Devel::NYTProf::VERSION; my $start = time; my $pinto = Pinto->new(root => "$root"); $pinto->run(Pin => (targets => \@targets, message => 'pin')) if $ops{pin}; $pinto->run(Unpin => (targets => \@targets, message => 'unpin')) if $ops{unpin}; $pinto->run(Unregister => (targets => \@targets, message => 'unreg')) if $ops{unregister}; $pinto->run(Register => (targets => \@targets, message => 'reg')) if $ops{register}; my $elapsed = time - $start; print "$elapsed seconds\n"; push @runs, $elapsed; } my $average = sum( @runs ) / scalar @runs; print "Average: $average seconds\n";Pinto-0.14/etc/cpanm000755 000766 000024 00001114011 13141540305 014377 0ustar00jeffstaff000000 000000 #!/usr/bin/env 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.7024";1; APP_CPANMINUS $fatpacked{"App/cpanminus/CPANVersion.pm"} = '#line '.(1+__LINE__).' "'.__FILE__."\"\n".<<'APP_CPANMINUS_CPANVERSION'; package App::cpanminus::CPANVersion;use strict;sub vcmp {my($self,$l,$r)=@_;local($^W)=0;return 0 if$l eq $r;for ($l,$r){s/_//g}for ($l,$r){next unless tr/.// > 1 || /^v/;s/^v?/v/;1 while s/\.0+(\d)/.$1/}if ($l=~/^v/ <=> $r=~/^v/){for ($l,$r){next if /^v/;$_=$self->float2vv($_)}}my$lvstring="v0";my$rvstring="v0";if ($] >= 5.006 && $l =~ /^v/ && $r =~ /^v/){$lvstring=$self->vstring($l);$rvstring=$self->vstring($r)}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 "CPAN::Version::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){warn("Suspicious version string seen [$n]\n");return$n}my$better=sprintf "v%vd",$n;return$better}1; APP_CPANMINUS_CPANVERSION $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,$prereq,$phases,$types)=@_;my@deps;for my$type (@$types){my$req=CPAN::Meta::Requirements->new;$req->add_requirements($prereq->requirements_for($_,$type))for @$phases;push@deps,$class->from_versions($req->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 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 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 JSON::PP;require CPAN::Meta::YAML;require CPAN::Meta::Prereqs;require version::vpp;require File::pushd;require Parse::PMFile}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,showdeps=>0,scandeps=>0,scandeps_tree=>[],format=>'tree',save_dists=>undef,skip_configure=>0,verify=>0,report_perl_version=>1,build_args=>{},features=>{},pure_perl=>0,cpanfile_path=>'cpanfile',@_,},$class}sub env {my($self,$key)=@_;$ENV{"PERL_CPANM_" .$key}}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'=>\$self->{mirror_index},'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},'report-perl-version!'=>\$self->{report_perl_version},'configure-timeout=i'=>\$self->{configure_timeout},'build-timeout=i'=>\$self->{build_timeout},'test-timeout=i'=>\$self->{test_timeout},'with-develop'=>\$self->{with_develop},'without-develop'=>sub {$self->{with_develop}=0},'with-feature=s'=>sub {$self->{features}{$_[1]}=1},'without-feature=s'=>sub {$self->{features}{$_[1]}=0},'with-all-features'=>sub {$self->{features}{__all}=1},'pp|pureperl!'=>\$self->{pure_perl},"cpanfile=s"=>\$self->{cpanfile_path},$self->install_type_handlers,$self->build_args_handlers,);if (!@ARGV && $0 ne '-' &&!-t STDIN){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 <{_checked}++;$self->bootstrap_local_lib;if (@{$self->{bootstrap_deps}|| []}){local$self->{notest}=1;local$self->{scandeps}=0;$self->install_deps(Cwd::cwd,0,@{$self->{bootstrap_deps}})}}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);$json =~ s/([^a-zA-Z0-9_\-.])/uc sprintf("%%%02x",ord($1))/eg;$json}sub version_to_query {my($self,$module,$version)=@_;require CPAN::Meta::Requirements;my$requirements=CPAN::Meta::Requirements->new;$requirements->add_string_requirement($module,$version || '0');my$req=$requirements->requirements_for_module($module);if ($req =~ s/^==\s*//){return {term=>{'module.version'=>$req },}}elsif ($req !~ /\s/){return {range=>{'module.version_numified'=>{'gte'=>$self->numify_ver_metacpan($req)}},}}else {my%ops=qw(< lt <= lte > gt >= gte);my(%range,@exclusion);my@requirements=split /,\s*/,$req;for my$r (@requirements){if ($r =~ s/^([<>]=?)\s*//){$range{$ops{$1}}=$self->numify_ver_metacpan($r)}elsif ($r =~ s/\!=\s*//){push@exclusion,$self->numify_ver_metacpan($r)}}my@filters=({range=>{'module.version_numified'=>\%range }},);if (@exclusion){push@filters,{not=>{or=>[map {+{term=>{'module.version_numified'=>$self->numify_ver_metacpan($_)}}}@exclusion ]},}}return@filters}}sub numify_ver_metacpan {my($self,$ver)=@_;$ver =~ s/_//g;version->new($ver)->numify}sub numify_ver {my($self,$ver)=@_;eval version->new($ver)->numify}sub maturity_filter {my($self,$module,$version)=@_;my@filters;if (!$self->with_version_range($version)or $self->{dev_release}){push@filters,{not=>{term=>{status=>'backpan' }}}}unless ($self->{dev_release}or $version =~ /==/){push@filters,{term=>{maturity=>'released' }}}return@filters}sub by_version {my%s=qw(latest 3 cpan 2 backpan 1);$b->{_score}<=> $a->{_score}|| $s{$b->{fields}{status}}<=> $s{$a->{fields}{status}}}sub by_first_come {$a->{fields}{date}cmp $b->{fields}{date}}sub by_date {$b->{fields}{date}cmp $a->{fields}{date}}sub find_best_match {my($self,$match,$version)=@_;return unless$match && @{$match->{hits}{hits}|| []};my@hits=$self->{dev_release}? sort {by_version || by_date}@{$match->{hits}{hits}}: sort {by_version || by_first_come}@{$match->{hits}{hits}};$hits[0]->{fields}}sub search_metacpan {my($self,$module,$version)=@_;require JSON::PP;$self->chat("Searching $module ($version) on metacpan ...\n");my$metacpan_uri='http://api.metacpan.org/v0';my@filter=$self->maturity_filter($module,$version);my$query={filtered=>{(@filter ? (filter=>{and=>\@filter }): ()),query=>{nested=>{score_mode=>'max',path=>'module',query=>{custom_score=>{metacpan_script=>"score_version_numified",query=>{constant_score=>{filter=>{and=>[{term=>{'module.authorized'=>JSON::PP::true()}},{term=>{'module.indexed'=>JSON::PP::true()}},{term=>{'module.name'=>$module }},$self->version_to_query($module,$version),]}}},}},}},}};my$module_uri="$metacpan_uri/file/_search?source=";$module_uri .= $self->encode_json({query=>$query,fields=>['date','release','author','module','status' ],});my($release,$author,$module_version);my$module_json=$self->get($module_uri);my$module_meta=eval {JSON::PP::decode_json($module_json)};my$match=$self->find_best_match($module_meta);if ($match){$release=$match->{release};$author=$match->{author};my$module_matched=(grep {$_->{name}eq $module}@{$match->{module}})[0];$module_version=$module_matched->{version}}unless ($release){$self->chat("! Could not find a release matching $module ($version) on MetaCPAN.\n");return}my$dist_uri="$metacpan_uri/release/_search?source=";$dist_uri .= $self->encode_json({filter=>{and=>[{term=>{'release.name'=>$release }},{term=>{'release.author'=>$author }},]},fields=>['download_url','stat','status' ],});my$dist_json=$self->get($dist_uri);my$dist_meta=eval {JSON::PP::decode_json($dist_json)};if ($dist_meta){$dist_meta=$dist_meta->{hits}{hits}[0]{fields}}if ($dist_meta && $dist_meta->{download_url}){(my$distfile=$dist_meta->{download_url})=~ s!.+/authors/id/!!;local$self->{mirrors}=$self->{mirrors};if ($dist_meta->{status}eq 'backpan'){$self->{mirrors}=['http://backpan.perl.org' ]}elsif ($dist_meta->{stat}{mtime}> time()-24*60*60){$self->{mirrors}=['http://cpan.metacpan.org' ]}return$self->cpan_module($module,$distfile,$module_version)}$self->diag_fail("Finding $module on metacpan failed.");return}sub search_database {my($self,$module,$version)=@_;my$found;my$range=($self->with_version_range($version)|| $self->{dev_release});if ($range){$found=$self->search_metacpan($module,$version)and return$found;$found=$self->search_cpanmetadb($module,$version)and return$found}else {$found=$self->search_cpanmetadb($module,$version)and return$found;$found=$self->search_metacpan($module,$version)and return$found}}sub search_cpanmetadb {my($self,$module,$version)=@_;require CPAN::Meta::YAML;$self->chat("Searching $module on cpanmetadb ...\n");(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_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 <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})){$self->bootstrap_local_lib_deps;return}$self->setup_local_lib;$self->diag(<resolve_path(local::lib->install_base_arch_path($base)),local::lib->resolve_path(local::lib->install_base_perl_path($base)),(!$self->{exclude_vendor}? grep {$_}@Config{qw(vendorarch vendorlibexp)}: ()),@Config{qw(archlibexp privlibexp)},)}sub _diff {my($self,$old,$new)=@_;my@diff;my%old=map {$_=>1}@$old;for my$n (@$new){push@diff,$n unless exists$old{$n}}@diff}sub _setup_local_lib_env {my($self,$base)=@_;$self->diag(<setup_env_hash_for($base,0)}sub setup_local_lib {my($self,$base,$no_env)=@_;$base=undef if$base eq '_';require local::lib;{local $0='cpanm';$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}$self->bootstrap_local_lib_deps}sub bootstrap_local_lib_deps {my$self=shift;push @{$self->{bootstrap_deps}},App::cpanminus::Dependency->new('ExtUtils::MakeMaker'=>6.58),App::cpanminus::Dependency->new('ExtUtils::Install'=>1.46)}sub prompt_bool {my($self,$mess,$def)=@_;my$val=$self->prompt($mess,$def);return lc$val eq 'y'}sub prompt {my($self,$mess,$def)=@_;my$isa_tty=-t STDIN && (-t STDOUT ||!(-f STDOUT || -c STDOUT));my$dispdef=defined$def ? "[$def] " : " ";$def=defined$def ? $def : "";if (!$self->{prompt}|| (!$isa_tty && eof STDIN)){return$def}local $|=1;local $\;my$ans;eval {local$SIG{ALRM}=sub {undef$ans;die "alarm\n"};print STDOUT "$mess $dispdef";alarm$self->{prompt_timeout}if$self->{prompt_timeout};$ans=;alarm 0};if (defined$ans){chomp$ans}else {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"}$cmd=$self->append_args($cmd,'configure')if$depth==0;local$self->{verbose}=$self->{verbose}|| $self->{interactive};$self->run_timeout($cmd,$self->{configure_timeout})}sub build {my($self,$cmd,$distname,$depth)=@_;local$ENV{PERL_MM_USE_DEFAULT}=!$self->{interactive};$cmd=$self->append_args($cmd,'build')if$depth==0;return 1 if$self->run_timeout($cmd,$self->{build_timeout});while (1){my$ans=lc$self->prompt("Building $distname failed.\nYou can s)kip, r)etry, e)xamine build log, or l)ook ?","s");return if$ans eq 's';return$self->build($cmd,$distname,$depth)if$ans eq 'r';$self->show_build_log if$ans eq 'e';$self->look if$ans eq 'l'}}sub test {my($self,$cmd,$distname,$depth)=@_;return 1 if$self->{notest};local$ENV{PERL_MM_USE_DEFAULT}=!$self->{interactive};local$ENV{NONINTERACTIVE_TESTING}=!$self->{interactive};$cmd=$self->append_args($cmd,'test')if$depth==0;return 1 if$self->run_timeout($cmd,$self->{test_timeout});if ($self->{force}){$self->diag_fail("Testing $distname failed but installing it anyway.");return 1}else {$self->diag_fail;while (1){my$ans=lc$self->prompt("Testing $distname failed.\nYou can s)kip, r)etry, f)orce install, e)xamine build log, or l)ook ?","s");return if$ans eq 's';return$self->test($cmd,$distname,$depth)if$ans eq 'r';return 1 if$ans eq 'f';$self->show_build_log if$ans eq 'e';$self->look if$ans eq 'l'}}}sub install {my($self,$cmd,$uninst_opts,$depth)=@_;if ($depth==0 && $self->{test_only}){return 1}if ($self->{sudo}){unshift @$cmd,"sudo"}if ($self->{uninstall_shadows}&&!$ENV{PERL_MM_OPT}){push @$cmd,@$uninst_opts}$cmd=$self->append_args($cmd,'install')if$depth==0;$self->run($cmd)}sub look {my$self=shift;my$shell=$ENV{SHELL};$shell ||= $ENV{COMSPEC}if WIN32;if ($shell){my$cwd=Cwd::cwd;$self->diag("Entering $cwd with $shell\n");system$shell}else {$self->diag_fail("You don't seem to have a SHELL :/")}}sub show_build_log {my$self=shift;my@pagers=($ENV{PAGER},(WIN32 ? (): ('less')),'more');my$pager;while (@pagers){$pager=shift@pagers;next unless$pager;$pager=$self->which($pager);next unless$pager;last}if ($pager){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(<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_checksums_signature {my($self,$chk_file)=@_;require Module::Signature;$self->chat("Verifying the signature of CHECKSUMS\n");my$rv=eval {local$SIG{__WARN__}=sub {};my$v=Module::Signature::_verify($chk_file);$v==Module::Signature::SIGNATURE_OK()};if ($rv){$self->chat("Verified OK!\n")}else {$self->diag_fail("Verifying CHECKSUMS signature failed: $rv\n");return}return 1}sub verify_archive {my($self,$file,$uri,$dist)=@_;unless ($dist->{cpanid}){$self->chat("Archive '$file' does not seem to be from PAUSE. Skip verification.\n");return 1}(my$mirror=$uri)=~ s!/authors/id.*$!!;(my$chksum_uri=$uri)=~ s!/[^/]*$!/CHECKSUMS!;my$chk_file=$self->source_for($mirror)."/$dist->{cpanid}.CHECKSUMS";$self->mask_output(diag_progress=>"Fetching $chksum_uri");$self->mirror($chksum_uri,$chk_file);unless (-e $chk_file){$self->diag_fail("Fetching $chksum_uri failed.\n");return}$self->diag_ok;$self->verify_checksums_signature($chk_file)or return;$self->verify_checksum($file,$chk_file)}sub verify_checksum {my($self,$file,$chk_file)=@_;$self->chat("Verifying the SHA1 for $file\n");open my$fh,"<$chk_file" or die "$chk_file: $!";my$data=join '',<$fh>;$data =~ s/\015?\012/\n/g;require Safe;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 verificaion for $dist->{filename} failed\n");return}}sub resolve_name {my($self,$module,$version)=@_;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 =~ /(?:^git:|\.git(?:@.+)?$)/){return$self->git_uri($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,$version)=@_;my$dist=$self->cpan_dist($dist);$dist->{module}=$module;$dist->{module_version}=$version if$version && $version ne 'undef';return$dist}sub cpan_dist {my($self,$dist,$url)=@_;$dist =~ s!^([A-Z]{2})!substr($1,0,1)."/".substr($1,0,2)."/".$1!e;require CPAN::DistnameInfo;my$d=CPAN::DistnameInfo->new($dist);if ($url){$url=[$url ]unless ref$url eq 'ARRAY'}else {my$id=$d->cpanid;my$fn=substr($id,0,1)."/" .substr($id,0,2)."/" .$id ."/" .$d->filename;my@mirrors=@{$self->{mirrors}};my@urls=map "$_/authors/id/$fn",@mirrors;$url=\@urls,}return {$d->properties,source=>'cpan',uris=>$url,}}sub git_uri {my ($self,$uri)=@_;($uri,my$commitish)=split /(?<=\.git)@/i,$uri,2;my$dir=File::Temp::tempdir(CLEANUP=>1);$self->mask_output(diag_progress=>"Cloning $uri");$self->run(['git','clone',$uri,$dir ]);unless (-e "$dir/.git"){$self->diag_fail("Failed cloning git repository $uri",1);return}if ($commitish){require File::pushd;my$dir=File::pushd::pushd($dir);unless ($self->run(['git','checkout',$commitish ])){$self->diag_fail("Failed to checkout '$commitish' in git repository $uri\n");return}}$self->diag_ok;return {source=>'local',dir=>$dir,}}sub setup_module_build_patch {my$self=shift;open my$out,">$self->{base}/ModuleBuildSkipMan.pm" or die $!;print$out <{search_inc}||= do {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->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.36' },'configure',)}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");$dist->{provides}=$self->extract_packages($dist->{cpanmeta},".")if$dist->{cpanmeta}&& $dist->{source}eq 'cpan';my$root_target=(($self->{installdeps}or $self->{showdeps})and $depth==0);$dist->{want_phases}=$self->{notest}&&!$root_target ? [qw(build runtime)]: [qw(build test runtime)];push @{$dist->{want_phases}},'develop' if$self->{with_develop}&& $depth==0;my@deps=$self->find_prereqs($dist);my$module_name=$self->find_module_name($configure_state)|| $dist->{meta}{name};$module_name =~ s/-/::/g;if ($self->{showdeps}){for my$dep (@config_deps,@deps){print$dep->module,($dep->version ? ("~".$dep->version): ""),"\n"}return 1}my$distname=$dist->{meta}{name}? "$dist->{meta}{name}-$dist->{meta}{version}" : $stuff;my$walkup;if ($self->{scandeps}){$walkup=$self->scandeps_append_child($dist)}$self->install_deps_bailout($distname,$dist->{dir},$depth,@deps)or return;if ($self->{scandeps}){unless ($configure_state->{configured_ok}){my$diag=<{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)}return@deps}sub extract_meta_prereqs {my($self,$dist)=@_;if ($dist->{cpanfile}){my@features=$self->configure_features($dist,$dist->{cpanfile}->features);my$prereqs=$dist->{cpanfile}->prereqs_with(@features);return App::cpanminus::Dependency->from_prereqs($prereqs,$dist->{want_phases},$self->{install_types})}require CPAN::Meta;my@deps;my($meta_file)=grep -f,qw(MYMETA.json MYMETA.yml);if ($meta_file){$self->chat("Checking dependencies from $meta_file ...\n");my$mymeta=eval {CPAN::Meta->load_file($meta_file,{lazy_validation=>1 })};if ($mymeta){$dist->{meta}{name}=$mymeta->name;$dist->{meta}{version}=$mymeta->version;return$self->extract_prereqs($mymeta,$dist)}}if (-e '_build/prereqs'){$self->chat("Checking dependencies from _build/prereqs ...\n");my$prereqs=do {open my$in,"_build/prereqs";$self->safe_eval(join "",<$in>)};my$meta=CPAN::Meta->new({name=>$dist->{meta}{name},version=>$dist->{meta}{version},%$prereqs },{lazy_validation=>1 },);@deps=$self->extract_prereqs($meta,$dist)}elsif (-e 'Makefile'){$self->chat("Finding PREREQ from Makefile ...\n");open my$mf,"Makefile";while (<$mf>){if (/^\#\s+PREREQ_PM => \{\s*(.*?)\s*\}/){my@all;my@pairs=split ', ',$1;for (@pairs){my ($pkg,$v)=split '=>',$_;push@all,[$pkg,$v ]}my$list=join ", ",map {"'$_->[0]' => $_->[1]"}@all;my$prereq=$self->safe_eval("no strict; +{ $list }");push@deps,App::cpanminus::Dependency->from_versions($prereq)if$prereq;last}}}return@deps}sub bundle_deps {my($self,$dist)=@_;my@files;File::Find::find({wanted=>sub {push@files,File::Spec->rel2abs($_)if /\.pm/i},no_chdir=>1,},'.');my@deps;for my$file (@files){open my$pod,"<",$file or next;my$in_contents;while (<$pod>){if (/^=head\d\s+CONTENTS/){$in_contents=1}elsif (/^=/){$in_contents=0}elsif ($in_contents){/^(\S+)\s*(\S+)?/ and push@deps,App::cpanminus::Dependency->new($1,$self->maybe_version($2))}}}return@deps}sub maybe_version {my($self,$string)=@_;return$string && $string =~ /^\.?\d/ ? $string : undef}sub extract_prereqs {my($self,$meta,$dist)=@_;my@features=$self->configure_features($dist,$meta->features);return App::cpanminus::Dependency->from_prereqs($meta->effective_prereqs(\@features),$dist->{want_phases},$self->{install_types})}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);File::Copy::copy($file,$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;chomp$root;$root =~ s{^\s+testing:\s+([^/]+)/.*?\s+OK$}{$1};system "$unzip $opt $zipfile";return$root if -d $root;$self->diag_fail("Bad archive: [$root] $zipfile");return undef}}else {$self->{_backends}{unzip}=sub {eval {require Archive::Zip}or die "Failed to extract $_[1] - You need to have unzip or Archive::Zip installed.\n";my($self,$file)=@_;my$zip=Archive::Zip->new();my$status;$status=$zip->read($file);$self->diag_fail("Read of file[$file] failed")if$status!=Archive::Zip::AZ_OK();my@members=$zip->members();for my$member (@members){my$af=$member->fileName();next if ($af =~ m!^(/|\.\./)!);$status=$member->extractToFileNamed($af);$self->diag_fail("Extracting of file[$af] from zipfile[$file failed")if$status!=Archive::Zip::AZ_OK()}my ($root)=$zip->membersMatching(qr<^[^/]+/$>);$root &&= $root->fileName;return -d $root ? $root : undef}}}sub safeexec {my$self=shift;my$rdr=$_[0]||= Symbol::gensym();if (WIN32){my$cmd=$self->shell_quote(@_[1..$#_]);return open($rdr,"$cmd |")}if (my$pid=open($rdr,'-|')){return$pid}elsif (defined$pid){exec(@_[1 .. $#_ ]);exit 1}else {return}}sub mask_uri_passwords {my($self,@strings)=@_;s{ (https?://) ([^:/]+) : [^@/]+ @ }{$1$2:********@}gx for@strings;return@strings}1; 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 your existing local::lib in this 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(?=-) )(? 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;$CPAN::Meta::VERSION='2.143240';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();$data=$backend->new->pretty->canonical->encode($struct)}else {$backend=Parse::CPAN::Meta->yaml_backend();$data=eval {no strict 'refs';&{"$backend\::Dump"}($struct)};if ($@){croak$backend->can('errstr')? $backend->errstr : $@}}return$data}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.009';use strict;use warnings;use Exporter 5.57 'import';our@EXPORT=qw//;our@EXPORT_OK=qw/check_requirements requirements_for verify_dependencies/;our%EXPORT_TAGS=(all=>[@EXPORT,@EXPORT_OK ]);use CPAN::Meta::Requirements 2.120920;use Module::Metadata;sub _check_dep {my ($reqs,$module,$dirs)=@_;$module eq 'perl' and return ($reqs->accepts_module($module,$])? (): sprintf "Your Perl (%s) is not in the range '%s'",$],$reqs->requirements_for_module($module));my$metadata=Module::Metadata->new_from_module($module,inc=>$dirs);return "Module '$module' is not installed" if not defined$metadata;my$version=eval {$metadata->version};return "Missing version info for module '$module'" if$reqs->requirements_for_module($module)and not $version;return sprintf 'Installed version (%s) of %s is not in range \'%s\'',$version,$module,$reqs->requirements_for_module($module)if not $reqs->accepts_module($module,$version || 0);return}sub _check_conflict {my ($reqs,$module,$dirs)=@_;my$metadata=Module::Metadata->new_from_module($module,inc=>$dirs);return if not defined$metadata;my$version=eval {$metadata->version};return "Missing version info for module '$module'" if not $version;return sprintf 'Installed version (%s) of %s is in range \'%s\'',$version,$module,$reqs->requirements_for_module($module)if$reqs->accepts_module($module,$version);return}sub requirements_for {my ($meta,$phases,$type)=@_;my$prereqs=ref($meta)eq 'CPAN::Meta' ? $meta->effective_prereqs : $meta;return$prereqs->merged_requirements(ref($phases)? $phases : [$phases ],[$type ])}sub check_requirements {my ($reqs,$type,$dirs)=@_;my%ret;if ($type ne 'conflicts'){for my$module ($reqs->required_modules){$ret{$module}=_check_dep($reqs,$module,$dirs)}}else {for my$module ($reqs->required_modules){$ret{$module}=_check_conflict($reqs,$module,$dirs)}}return \%ret}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;$CPAN::Meta::Converter::VERSION='2.143240';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 || "");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->{file}}if (exists$no_index->{modules}){$no_index->{module}=delete$no_index->{module}}return _convert($no_index,$no_index_spec_1_2)}sub _no_index_directory {my ($element,$key,$meta,$version)=@_;return unless$element;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->{file}}if (exists$element->{modules}){$element->{module}=delete$element->{module}}my$spec=$version==2 ? $no_index_spec_2 : $no_index_spec_1_3;return _convert($element,$spec)}sub _is_module_name {my$mod=shift;return unless defined$mod && length$mod;return$mod =~ m{^[A-Za-z][A-Za-z0-9_]*(?:::[A-Za-z0-9_]+)*$}}sub _clean_version {my ($element)=@_;return 0 if!defined$element;$element =~ s{^\s*}{};$element =~ s{\s*$}{};$element =~ s{^\.}{0.};return 0 if!length$element;return 0 if ($element eq 'undef' || $element eq '');my$v=eval {version->new($element)};if (defined$v){return _is_qv($v)? $v->normal : $element}else {return 0}}sub _bad_version_hook {my ($v)=@_;$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 ''){$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_from_version,'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;$CPAN::Meta::Feature::VERSION='2.143240';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;$CPAN::Meta::History::VERSION='2.143240';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;$CPAN::Meta::Merge::VERSION='2.143240';use Carp qw/croak/;use Scalar::Util qw/blessed/;use CPAN::Meta::Converter;sub _identical {my ($left,$right,$path)=@_;croak sprintf "Can't merge attribute %s: '%s' does not equal '%s'",join('.',@{$path}),$left,$right unless$left eq $right;return$left}sub _merge {my ($current,$next,$mergers,$path)=@_;for my$key (keys %{$next}){if (not exists$current->{$key}){$current->{$key}=$next->{$key}}elsif (my$merger=$mergers->{$key}){$current->{$key}=$merger->($current->{$key},$next->{$key},[@{$path},$key ])}elsif ($merger=$mergers->{':default'}){$current->{$key}=$merger->($current->{$key},$next->{$key},[@{$path},$key ])}else {croak sprintf "Can't merge unknown attribute '%s'",join '.',@{$path},$key}}return$current}sub _uniq {my%seen=();return grep {not $seen{$_}++}@_}sub _set_addition {my ($left,$right)=@_;return [+_uniq(@{$left},@{$right})]}sub _uniq_map {my ($left,$right,$path)=@_;for my$key (keys %{$right}){if (not exists$left->{$key}){$left->{$key}=$right->{$key}}else {croak 'Duplication of element ' .join '.',@{$path},$key}}return$left}sub _improvize {my ($left,$right,$path)=@_;my ($name)=reverse @{$path};if ($name =~ /^x_/){if (ref($left)eq 'ARRAY'){return _set_addition($left,$right,$path)}elsif (ref($left)eq 'HASH'){return _uniq_map($left,$right,$path)}else {return _identical($left,$right,$path)}}croak sprintf "Can't merge '%s'",join '.',@{$path}}sub _optional_features {my ($left,$right,$path)=@_;for my$key (keys %{$right}){if (not exists$left->{$key}){$left->{$key}=$right->{$key}}else {for my$subkey (keys %{$right->{$key}}){next if$subkey eq 'prereqs';if (not exists$left->{$key}{$subkey}){$left->{$key}{$subkey}=$right->{$key}{$subkey}}else {Carp::croak "Cannot merge two optional_features named '$key' with different '$subkey' values" if do {no warnings 'uninitialized';$left->{$key}{$subkey}ne $right->{$key}{$subkey}}}}require CPAN::Meta::Prereqs;$left->{$key}{prereqs}=CPAN::Meta::Prereqs->new($left->{$key}{prereqs})->with_merged_prereqs(CPAN::Meta::Prereqs->new($right->{$key}{prereqs}))->as_string_hash}}return$left}my%default=(abstract=>\&_identical,author=>\&_set_addition,dynamic_config=>sub {my ($left,$right)=@_;return$left || $right},generated_by=>sub {my ($left,$right)=@_;return join ', ',_uniq(split(/, /,$left),split(/, /,$right))},license=>\&_set_addition,'meta-spec'=>{version=>\&_identical,url=>\&_identical },name=>\&_identical,release_status=>\&_identical,version=>\&_identical,description=>\&_identical,keywords=>\&_set_addition,no_index=>{map {($_=>\&_set_addition)}qw/file directory package namespace/ },optional_features=>\&_optional_features,prereqs=>sub {require CPAN::Meta::Prereqs;my ($left,$right)=map {CPAN::Meta::Prereqs->new($_)}@_[0,1];return$left->with_merged_prereqs($right)->as_string_hash},provides=>\&_uniq_map,resources=>{license=>\&_set_addition,homepage=>\&_identical,bugtracker=>\&_uniq_map,repository=>\&_uniq_map,':default'=>\&_improvize,},':default'=>\&_improvize,);sub new {my ($class,%arguments)=@_;croak 'default version required' if not exists$arguments{default_version};my%mapping=%default;my%extra=%{$arguments{extra_mappings}|| {}};for my$key (keys%extra){if (ref($mapping{$key})eq 'HASH'){$mapping{$key}={%{$mapping{$key}},%{$extra{$key}}}}else {$mapping{$key}=$extra{$key}}}return bless {default_version=>$arguments{default_version},mapping=>_coerce_mapping(\%mapping,[]),},$class}my%coderef_for=(set_addition=>\&_set_addition,uniq_map=>\&_uniq_map,identical=>\&_identical,improvize=>\&_improvize,);sub _coerce_mapping {my ($orig,$map_path)=@_;my%ret;for my$key (keys %{$orig}){my$value=$orig->{$key};if (ref($orig->{$key})eq 'CODE'){$ret{$key}=$value}elsif (ref($value)eq 'HASH'){my$mapping=_coerce_mapping($value,[@{$map_path},$key ]);$ret{$key}=sub {my ($left,$right,$path)=@_;return _merge($left,$right,$mapping,[@{$path}])}}elsif ($coderef_for{$value}){$ret{$key}=$coderef_for{$value}}else {croak "Don't know what to do with " .join '.',@{$map_path},$key}}return \%ret}sub merge {my ($self,@items)=@_;my$current={};for my$next (@items){if (blessed($next)&& $next->isa('CPAN::Meta')){$next=$next->as_struct}elsif (ref($next)eq 'HASH'){my$cmc=CPAN::Meta::Converter->new($next,default_version=>$self->{default_version});$next=$cmc->upgrade_fragment}else {croak "Don't know how to merge '$next'"}$current=_merge($current,$next,$self->{mapping},[])}return$current}1; 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;$CPAN::Meta::Prereqs::VERSION='2.143240';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.131';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;if ($INC{'version/vpp.pm'}|| $INC{'ExtUtils/MakeMaker/version/vpp.pm'}){my$magic=_find_magic_vstring($version);$version=$magic if length$magic}eval {if (not defined$version or $version eq '0'){$vobj=$V0}elsif (ref($version)eq 'version' || _isa_version($version)){$vobj=$version}else {local$SIG{__WARN__}=sub {die "Invalid version: $_[0]"};$vobj=version->new($version)}};if (my$err=$@){my$hook=$self->{bad_version_hook};$vobj=eval {$hook->($version,$module)}if ref$hook eq 'CODE';unless (eval {$vobj->isa("version")}){$err =~ s{ at .* line \d+.*$}{};die "Can't convert '$version': $err"}}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;$CPAN::Meta::Spec::VERSION='2.143240';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;$CPAN::Meta::Validator::VERSION='2.143240';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 || "";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='' unless(defined$value);$self->_error("'$value' for '$key' is not a valid version.");return 0}sub version {my ($self,$key,$value)=@_;if(defined$value){return 0 unless($value || $value =~ /0/);return 1 if($value =~ /^\s*((<|<=|>=|>|!=|==)\s*)?v?\d+((\.\d+((_|\.)\d+)?)?)/)}else {$value=''}$self->_error("'$value' for '$key' is not a valid version.");return 0}sub boolean {my ($self,$key,$value)=@_;if(defined$value){return 1 if($value =~ /^(0|1|true|false)$/)}else {$value=''}$self->_error("'$value' for '$key' is not a boolean value.");return 0}my%v1_licenses=('perl'=>'http://dev.perl.org/licenses/','gpl'=>'http://www.opensource.org/licenses/gpl-license.php','apache'=>'http://apache.org/licenses/LICENSE-2.0','artistic'=>'http://opensource.org/licenses/artistic-license.php','artistic_2'=>'http://opensource.org/licenses/artistic-license-2.0.php','lgpl'=>'http://www.opensource.org/licenses/lgpl-license.php','bsd'=>'http://www.opensource.org/licenses/bsd-license.php','gpl'=>'http://www.opensource.org/licenses/gpl-license.php','mit'=>'http://opensource.org/licenses/mit-license.php','mozilla'=>'http://opensource.org/licenses/mozilla1.1.php','open_source'=>undef,'unrestricted'=>undef,'restrictive'=>undef,'unknown'=>undef,);my%v2_licenses=map {$_=>1}qw(agpl_3 apache_1_1 apache_2_0 artistic_1 artistic_2 bsd freebsd gfdl_1_2 gfdl_1_3 gpl_1 gpl_2 gpl_3 lgpl_2_1 lgpl_3_0 mit mozilla_1_0 mozilla_1_1 openssl perl_5 qpl_1_0 ssleay sun zlib open_source restricted unrestricted unknown);sub license {my ($self,$key,$value)=@_;my$licenses=$self->{spec}< 2 ? \%v1_licenses : \%v2_licenses;if(defined$value){return 1 if($value && exists$licenses->{$value})}else {$value=''}$self->_error("License '$value' is invalid");return 0}sub custom_1 {my ($self,$key)=@_;if(defined$key){return 1 if($key && $key =~ /^[_a-z]+$/i && $key =~ /[A-Z]/)}else {$key=''}$self->_error("Custom resource '$key' must be in CamelCase.");return 0}sub custom_2 {my ($self,$key)=@_;if(defined$key){return 1 if($key && $key =~ /^x_/i)}else {$key=''}$self->_error("Custom key '$key' must begin with 'x_' or 'X_'.");return 0}sub identifier {my ($self,$key)=@_;if(defined$key){return 1 if($key && $key =~ /^([a-z][_a-z]+)$/i)}else {$key=''}$self->_error("Key '$key' is not a legal identifier.");return 0}sub module {my ($self,$key)=@_;if(defined$key){return 1 if($key && $key =~ /^[A-Za-z0-9_]+(::[A-Za-z0-9_]+)*$/)}else {$key=''}$self->_error("Key '$key' is not a legal module name.");return 0}my@valid_phases=qw/configure build test runtime develop/;sub phase {my ($self,$key)=@_;if(defined$key){return 1 if(length$key && grep {$key eq $_}@valid_phases);return 1 if$key =~ /x_/i}else {$key=''}$self->_error("Key '$key' is not a legal phase.");return 0}my@valid_relations=qw/requires recommends suggests conflicts/;sub relation {my ($self,$key)=@_;if(defined$key){return 1 if(length$key && grep {$key eq $_}@valid_relations);return 1 if$key =~ /x_/i}else {$key=''}$self->_error("Key '$key' is not a legal prereq relationship.");return 0}sub _error {my$self=shift;my$mess=shift;$mess .= ' ('.join(' -> ',@{$self->{stack}}).')' if($self->{stack});$mess .= " [Validation: $self->{spec}]";push @{$self->{errors}},$mess}1; 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.012';BEGIN {$CPAN::Meta::YAML::AUTHORITY='cpan:ADAMK'};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]'"}}};if (ref $@ eq 'SCALAR'){$self->_error(${$@})}elsif ($@){$self->_error($@)}return$self}sub _unquote_single {my ($self,$string)=@_;return '' unless length$string;$string =~ s/\'\'/\'/g;return$string}sub _unquote_double {my ($self,$string)=@_;return '' unless length$string;$string =~ s/\\"/"/g;$string =~ s{\\([Nnever\\fartz0b]|x([0-9a-fA-F]{2}))} 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 (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}}BEGIN {local $@;if (eval {require Scalar::Util}&& $Scalar::Util::VERSION && eval($Scalar::Util::VERSION)>= 1.18){*refaddr=*Scalar::Util::refaddr}else {eval <<'END_PERL'}}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.053';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))}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@]:/\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[127]/ && $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 missmatch (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 {die(qq/IO::Socket::SSL 1.42 must be installed for https support\n/)unless eval {require IO::Socket::SSL;IO::Socket::SSL->VERSION(1.42)};die(qq/Net::SSLeay 1.49 must be installed for https support\n/)unless eval {require Net::SSLeay;Net::SSLeay->VERSION(1.49)}}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();return$self->{SSL_options}->{SSL_ca_file}if$self->{SSL_options}->{SSL_ca_file}and -e $self->{SSL_options}->{SSL_ca_file};return Mozilla::CA::SSL_ca_file()if eval {require Mozilla::CA};for my$ca_bundle (qw{/etc/ssl/certs/ca-certificates.crt /etc/pki/tls/certs/ca-bundle.crt /etc/ssl/ca-bundle.pem}){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(<{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.000025';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'}){Log::Contextual->import('log_info')}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.34';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$dont_delete;my$err=JSON::PP::decode_json($pp->{version});if ($err->{x_normalize}){$errors{$package}={normalize=>$err->{version},infile=>$pp->{infile},};$pp->{version}="undef";$dont_delete=1}elsif ($err->{openerr}){$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 {$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},}}unless ($dont_delete){delete$ppp->{$package};next}}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};$DB::single++;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 (? 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 (){$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 /(?<=])\=(?![=>])/;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 vars qw(@ISA $VERSION $CLASS $STRICT $LAX *declare *qv);$VERSION=0.9909;$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;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;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.9909;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 Config;use vars qw($VERSION $CLASS @ISA $LAX $STRICT);$VERSION=0.9909;$CLASS='version::vpp';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,);eval "use warnings";if ($@){eval ' package warnings; sub enabled {return $^W;} 1; '}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'})}}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 (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 '.'){$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);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$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)>= 3 && $value !~ /[._]/ && _is_non_alphanumeric($value)){my$tvalue;if ($] ge 5.008_001){$tvalue=_find_magic_vstring($value);$value=$tvalue if length$tvalue}elsif ($] ge 5.006_000){$tvalue=sprintf("v%vd",$value);if ($tvalue =~ /^v\d+(\.\d+){2,}$/){$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]}) { return sub { return 0 unless length $fat; $fat =~ s/^([^\n]*\n?)//; $_ = $1; return 1; }; } return; }; } else { *{"${class}::INC"} = sub { if (my $fat = $_[0]{$_[1]}) { open my $fh, '<', \$fat or die "FatPacker error loading $_[1] (could be a perl installation issue?)"; return $fh; } return; }; } unshift @INC, bless \%fatpacked, $class; } # END OF FATPACK CODE use strict; use App::cpanminus::script; unless (caller) { my $app = App::cpanminus::script->new; $app->parse_options(@ARGV); exit $app->doit; } __END__ =head1 NAME cpanm - get, unpack build and install modules from CPAN =head1 SYNOPSIS cpanm Test::More # install Test::More cpanm MIYAGAWA/Plack-0.99_05.tar.gz # full distribution path cpanm http://example.org/LDS/CGI.pm-3.20.tar.gz # install from URL cpanm ~/dists/MyCompany-Enterprise-1.00.tar.gz # install from a local file cpanm --interactive Task::Kensho # Configure interactively cpanm . # install from local directory cpanm --installdeps . # install all the deps for the current directory cpanm -L extlib Plack # install Plack and all non-core deps into extlib cpanm --mirror http://cpan.cpantesters.org/ DBI # use the fast-syncing mirror cpanm --from https://cpan.metacpan.org/ Plack # use only the HTTPS mirror =head1 COMMANDS =over 4 =item (arguments) Command line arguments can be either a module name, distribution file, local file path, HTTP URL or git repository URL. Following commands will all work as you expect. cpanm Plack cpanm Plack/Request.pm cpanm MIYAGAWA/Plack-1.0000.tar.gz cpanm /path/to/Plack-1.0000.tar.gz cpanm http://cpan.metacpan.org/authors/id/M/MI/MIYAGAWA/Plack-0.9990.tar.gz cpanm git://github.com/plack/Plack.git Additionally, you can use the notation using C<~> and C<@> to specify version for a given module. C<~> specifies the version requirement in the L format, while C<@> pins the exact version, and is a shortcut for C<~"== VERSION">. cpanm Plack~1.0000 # 1.0000 or later cpanm Plack~">= 1.0000, < 2.0000" # latest of 1.xxxx cpanm Plack@0.9990 # specific version. same as Plack~"== 0.9990" The version query including specific version or range will be sent to L to search for previous releases. The query will search for BackPAN archives by default, unless you specify C<--dev> option, in which case, archived versions will be filtered out. For a git repository, you can specify a branch, tag, or commit SHA to build. The default is C cpanm git://github.com/plack/Plack.git@1.0000 # tag cpanm git://github.com/plack/Plack.git@devel # branch =item -i, --install Installs the modules. This is a default behavior and this is just a compatibility option to make it work like L or L. =item --self-upgrade Upgrades itself. It's just an alias for: cpanm App::cpanminus =item --info Displays the distribution information in C format in the standard out. =item --installdeps Installs the dependencies of the target distribution but won't build itself. Handy if you want to try the application from a version controlled repository such as git. cpanm --installdeps . =item --look Download and unpack the distribution and then open the directory with your shell. Handy to poke around the source code or do manual testing. =item -h, --help Displays the help message. =item -V, --version Displays the version number. =back =head1 OPTIONS You can specify the default options in C environment variable. =over 4 =item -f, --force Force install modules even when testing failed. =item -n, --notest Skip the testing of modules. Use this only when you just want to save time for installing hundreds of distributions to the same perl and architecture you've already tested to make sure it builds fine. Defaults to false, and you can say C<--no-notest> to override when it is set in the default options in C. =item --test-only Run the tests only, and do not install the specified module or distributions. Handy if you want to verify the new (or even old) releases pass its unit tests without installing the module. Note that if you specify this option with a module or distribution that has dependencies, these dependencies will be installed if you don't currently have them. =item -S, --sudo Switch to the root user with C when installing modules. Use this if you want to install modules to the system perl include path. Defaults to false, and you can say C<--no-sudo> to override when it is set in the default options in C. =item -v, --verbose Makes the output verbose. It also enables the interactive configuration. (See --interactive) =item -q, --quiet Makes the output even more quiet than the default. It only shows the successful/failed dependencies to the output. =item -l, --local-lib Sets the L compatible path to install modules to. You don't need to set this if you already configure the shell environment variables using L, but this can be used to override that as well. =item -L, --local-lib-contained Same with C<--local-lib> but with L<--self-contained> set. All non-core dependencies will be installed even if they're already installed. For instance, cpanm -L extlib Plack would install Plack and all of its non-core dependencies into the directory C, which can be loaded from your application with: use local::lib '/path/to/extlib'; Note that this option does B reliably work with perl installations supplied by operating system vendors that strips standard modules from perl, such as RHEL, Fedora and CentOS, B you also install packages supplying all the modules that have been stripped. For these systems you will probably want to install the C meta-package which does just that. =item --self-contained When examining the dependencies, assume no non-core modules are installed on the system. Handy if you want to bundle application dependencies in one directory so you can distribute to other machines. =item --exclude-vendor Don't include modules installed under the 'vendor' paths when searching for core modules when the C<--self-contained> flag is in effect. This restores the behaviour from before version 1.7023 =item --mirror Specifies the base URL for the CPAN mirror to use, such as C (you can omit the trailing slash). You can specify multiple mirror URLs by repeating the command line option. You can use a local directory that has a CPAN mirror structure (created by tools such as L or L) by using a special URL scheme C. If the given URL begins with `/` (without any scheme), it is considered as a file scheme as well. cpanm --mirror file:///path/to/mirror cpanm --mirror ~/minicpan # Because shell expands ~ to /home/user Defaults to C. =item --mirror-only Download the mirror's 02packages.details.txt.gz index file instead of querying the CPAN Meta DB. This will also effectively opt out sending your local perl versions to backend database servers such as CPAN Meta DB and MetaCPAN. Select this option if you are using a local mirror of CPAN, such as minicpan when you're offline, or your own CPAN index (a.k.a darkpan). =item --from, -M cpanm -M https://cpan.metacpan.org/ cpanm --from https://cpan.metacpan.org/ Use the given mirror URL and its index as the I source to search and download modules from. It works similar to C<--mirror> and C<--mirror-only> combined, with a small difference: unlike C<--mirror> which I the URL to the list of mirrors, C<--from> (or C<-M> for short) uses the specified URL as its I source to download index and modules from. This makes the option always override the default mirror, which might have been set via global options such as the one set by C environment variable. B It might be useful if you name these options with your shell aliases, like: alias minicpanm='cpanm --from ~/minicpan' alias darkpan='cpanm --from http://mycompany.example.com/DPAN' =item --mirror-index B: Specifies the file path to C<02packages.details.txt> for module search index. =item --cpanmetadb B: Specifies an alternate URI for CPAN MetaDB index lookups. =item --cpanfile B: Specified an alternate path for cpanfile to search for, when C<--installdeps> command is in use. Defaults to C. =item --prompt Prompts when a test fails so that you can skip, force install, retry or look in the shell to see what's going wrong. It also prompts when one of the dependency failed if you want to proceed the installation. Defaults to false, and you can say C<--no-prompt> to override if it's set in the default options in C. =item --dev B: search for a newer developer release as well. Defaults to false. =item --reinstall cpanm, when given a module name in the command line (i.e. C), checks the locally installed version first and skips if it is already installed. This option makes it skip the check, so: cpanm --reinstall Plack would reinstall L even if your locally installed version is latest, or even newer (which would happen if you install a developer release from version control repositories). Defaults to false. =item --interactive Makes the configuration (such as C and C) interactive, so you can answer questions in the distribution that requires custom configuration or Task:: distributions. Defaults to false, and you can say C<--no-interactive> to override when it's set in the default options in C. =item --pp, --pureperl Prefer Pure perl build of modules by setting C for MakeMaker and C<--pureperl-only> for Build.PL based distributions. Note that not all of the CPAN modules support this convention yet. =item --with-recommends, --with-suggests B: Installs dependencies declared as C and C respectively, per META spec. When these dependencies fail to install, cpanm continues the installation, since they're just recommendation/suggestion. Enabling this could potentially make a circular dependency for a few modules on CPAN, when C adds a module that C back the module in return. There's also C<--without-recommend> and C<--without-suggests> to override the default decision made earlier in C. Defaults to false for both. =item --with-develop B: Installs develop phase dependencies in META files or C when used with C<--installdeps>. Defaults to false. =item --with-feature, --without-feature, --with-all-features B: Specifies the feature to enable, if a module supports optional features per META spec 2.0. cpanm --with-feature=opt_csv Spreadsheet::Read the features can also be interactively chosen when C<--interactive> option is enabled. C<--with-all-features> enables all the optional features, and C<--without-feature> can select a feature to disable. =item --configure-timeout, --build-timeout, --test-timeout Specify the timeout length (in seconds) to wait for the configure, build and test process. Current default values are: 60 for configure, 3600 for build and 1800 for test. =item --configure-args, --build-args, --test-args, --install-args B: Pass arguments for configure/build/test/install commands respectively, for a given module to install. cpanm DBD::mysql --configure-args="--cflags=... --libs=..." The argument is only enabled for the module passed as a command line argument, not dependencies. =item --scandeps B: Scans the depencencies of given modules and output the tree in a text format. (See C<--format> below for more options) Because this command doesn't actually install any distributions, it will be useful that by typing: cpanm --scandeps Catalyst::Runtime you can make sure what modules will be installed. This command takes into account which modules you already have installed in your system. If you want to see what modules will be installed against a vanilla perl installation, you might want to combine it with C<-L> option. =item --format B: Determines what format to display the scanned dependency tree. Available options are C, C, C and C. =over 8 =item tree Displays the tree in a plain text format. This is the default value. =item json, yaml Outputs the tree in a JSON or YAML format. L and L modules need to be installed respectively. The output tree is represented as a recursive tuple of: [ distribution, dependencies ] and the container is an array containing the root elements. Note that there may be multiple root nodes, since you can give multiple modules to the C<--scandeps> command. =item dists C is a special output format, where it prints the distribution filename in the I after the dependency resolution, like: GAAS/MIME-Base64-3.13.tar.gz GAAS/URI-1.58.tar.gz PETDANCE/HTML-Tagset-3.20.tar.gz GAAS/HTML-Parser-3.68.tar.gz GAAS/libwww-perl-5.837.tar.gz which means you can install these distributions in this order without extra dependencies. When combined with C<-L> option, it will be useful to replay installations on other machines. =back =item --save-dists Specifies the optional directory path to copy downloaded tarballs in the CPAN mirror compatible directory structure i.e. I If the distro tarball did not come from CPAN, for example from a local file or from GitHub, then it will be saved under I. =item --uninst-shadows Uninstalls the shadow files of the distribution that you're installing. This eliminates the confusion if you're trying to install core (dual-life) modules from CPAN against perl 5.10 or older, or modules that used to be XS-based but switched to pure perl at some version. If you run cpanm as root and use C or equivalent to specify custom installation path, you SHOULD disable this option so you won't accidentally uninstall dual-life modules from the core include path. Defaults to true if your perl version is smaller than 5.12, and you can disable that with C<--no-uninst-shadows>. B: Since version 1.3000 this flag is turned off by default for perl newer than 5.12, since with 5.12 @INC contains site_perl directory I the perl core library path, and uninstalling shadows is not necessary anymore and does more harm by deleting files from the core library path. =item --uninstall, -U Uninstalls a module from the library path. It finds a packlist for given modules, and removes all the files included in the same distribution. If you enable local::lib, it only removes files from the local::lib directory. If you try to uninstall a module in C directory (i.e. core module), an error will be thrown. A dialog will be prompted to confirm the files to be deleted. If you pass C<-f> option as well, the dialog will be skipped and uninstallation will be forced. =item --cascade-search B: Specifies whether to cascade search when you specify multiple mirrors and a mirror doesn't have a module or has a lower version of the module than requested. Defaults to false. =item --skip-installed Specifies whether a module given in the command line is skipped if its latest version is already installed. Defaults to true. B: The C environment variable have to be correctly set for this to work with modules installed using L, unless you always use the C<-l> option. =item --skip-satisfied B: Specifies whether a module (and version) given in the command line is skipped if it's already installed. If you run: cpanm --skip-satisfied CGI DBI~1.2 cpanm won't install them if you already have CGI (for whatever versions) or have DBI with version higher than 1.2. It is similar to C<--skip-installed> but while C<--skip-installed> checks if the I version of CPAN is installed, C<--skip-satisfied> checks if a requested version (or not, which means any version) is installed. Defaults to false. =item --verify Verify the integrity of distribution files retrieved from PAUSE using CHECKSUMS and SIGNATURES (if found). Defaults to false. =item --report-perl-version Whether it report the locally installed perl version to the various web server as part of User-Agent. Defaults to true, and you can disable it by using C<--no-report-perl-version>. =item --auto-cleanup Specifies the number of days in which cpanm's work directories expire. Defaults to 7, which means old work directories will be cleaned up in one week. You can set the value to C<0> to make cpan never cleanup those directories. =item --man-pages Generates man pages for executables (man1) and libraries (man3). Defaults to true (man pages generated) unless C<-L|--local-lib-contained> option is supplied in which case it's set to false. You can disable it with C<--no-man-pages>. =item --lwp Uses L module to download stuff over HTTP. Defaults to true, and you can say C<--no-lwp> to disable using LWP, when you want to upgrade LWP from CPAN on some broken perl systems. =item --wget Uses GNU Wget (if available) to download stuff. Defaults to true, and you can say C<--no-wget> to disable using Wget (versions of Wget older than 1.9 don't support the C<--retry-connrefused> option used by cpanm). =item --curl Uses cURL (if available) to download stuff. Defaults to true, and you can say C<--no-curl> to disable using cURL. Normally with C<--lwp>, C<--wget> and C<--curl> options set to true (which is the default) cpanm tries L, Wget, cURL and L (in that order) and uses the first one available. =back =head1 SEE ALSO L =head1 COPYRIGHT Copyright 2010- Tatsuhiko Miyagawa. =head1 AUTHOR Tatsuhiko Miyagawa =cut Pinto-0.14/etc/install.sh000755 000766 000024 00000014577 13141540305 015377 0ustar00jeffstaff000000 000000 #!/bin/bash ############################################################################## # THIS IS THE PINTO INSTALLER # # This bash script will install pinto as a standalone application. # # By default, pinto and all of its dependencies will be built into the # ~/opt/local/pinto directory. You can change this location by setting the # PINTO_HOME environment variable before running this script. # # The purpose of a standalone installation is to isolate pinto from whatever # other Perl modules you may have in your environment. So if you ever upgrade # or change those modules, pinto will not be affected. Nor does installing # pinto affect any of the modules your other apps are using. # # The most common way to run this installer is like this: # # curl -L http://getpinto.stratopan.com | bash # # Or if you prefer to use wget then run this command: # # wget -O - http://getpinto.stratopan.com | bash # # After a succesful installation, you'll be instructed on how to amend your # ~/.profile (or ~/.bashrc, or whatever you prefer) so that pinto runs # naturally in your everyday shell environment. # # All the depndencies for pinto come from a curated repository hosted at # http://stratopan.com. That repository contains specific versions of all # the modules that pinto needs. So those may not be the latest versions, # but they are versions that I know will work (and that's the whole point # of having a pinto repository anyway). # # If this installer doesn't work for you, then you can fallback to installing # the App::Pinto module from CPAN. Again, cpanm(1) is really excellent for # that, but you can use cpan(1) too. When installing from CPAN, you'll be # getting the versions of modules that are in the CPAN index at that moment, # which may or may not be 100% compatible with pinto (usually they are, but # you never know). # # CONFIGURATION # # The following environment variables can be used to control the installation: # # PINTO_HOME # # Sets the directory where pinto will be installed. # Defaults to $HOME/opt/local/pinto # # PINTO_REPO_URL # # Sets the URL of the repository that provides pinto's dependencies # Defaults to https://www.stratopan.com/thaljef/OpenSource/pinto-release # # PINTO_INSTALLER_AGENT # # Sets the name of the tool that will be used to fetch cpanm. If set, # it must be either 'curl' or 'wget'. If not set, the installer will # fallback to either 'curl' or 'wget' (in that order) depending on what # you already have installed. # # PERL_CPANM_OPT # # Sets the default options for cpanm, which is used to install pinto. This # can be useful if you need to specify a certain agent such as lwp, curl, # or wget. See https://metacpan.org/module/cpanm for more details. # # Copyright 2013 Jeffrey Ryan Thalhammer # ############################################################################## set -ue #----------------------------------------------------------------------------- # You can set these variables beforehand to override defaults PINTO_REPO_URL=${PINTO_REPO_URL:="https://www.stratopan.com/thaljef/OpenSource/pinto-release"} PINTO_HOME=${PINTO_HOME:="$HOME/opt/local/pinto"} #----------------------------------------------------------------------------- # Decide which agent to use. Set PINTO_INSTALLER_AGENT to override if [ -z ${PINTO_INSTALLER_AGENT:-} ]; then if type curl > /dev/null 2>&1; then PINTO_INSTALLER_AGENT='curl' elif type wget > /dev/null 2>&1; then PINTO_INSTALLER_AGENT='wget' else echo "Must have curl or wget to install pinto" exit 1 fi fi #----------------------------------------------------------------------------- # Bootstrap cpanm PINTO_CPANM_URL=${PINTO_CPANM_URL:="https://raw.githubusercontent.com/thaljef/Pinto/master/etc/cpanm"} PINTO_SBIN="$PINTO_HOME/sbin" PINTO_CPANM_EXE="$PINTO_SBIN/cpanm" mkdir -p "$PINTO_SBIN" if [ $PINTO_INSTALLER_AGENT = 'curl' ]; then curl --silent --show-error --location $PINTO_CPANM_URL > "$PINTO_CPANM_EXE" elif [ $PINTO_INSTALLER_AGENT = 'wget' ]; then wget --no-verbose --output-document - $PINTO_CPANM_URL > "$PINTO_CPANM_EXE" else echo "Invalid PINTO_INSTALLER_AGENT ($PINTO_INSTALLER_AGENT)." echo "If set, PINTO_INSTALLER_AGENT must be 'curl' or 'wget'". exit 1; fi chmod 755 "$PINTO_CPANM_EXE" #----------------------------------------------------------------------------- # Do installation echo "Installing pinto into $PINTO_HOME" # Workaround for removal of "." from @INC in perl 5.26.0 export PERL_USE_UNSAFE_INC=1 "$PINTO_CPANM_EXE" --notest --quiet --mirror $PINTO_REPO_URL --mirror-only \ --local-lib-contained "$PINTO_HOME" --man-pages Pinto # TODO: send the build log and `perl -V` back for analysis if [ $? -ne 0 ] ; then echo "Installation failed."; exit 1; fi #----------------------------------------------------------------------------- # Remove scripts and man pages that aren't from pinto (cd "$PINTO_HOME/bin"; ls | grep -iv pinto | xargs rm -f) (cd "$PINTO_HOME/man/man1"; ls | grep -iv pinto | xargs rm -f) (cd "$PINTO_HOME/man/man3"; ls | grep -iv pinto | xargs rm -f) #----------------------------------------------------------------------------- # Create the etc/ directory PINTO_ETC="$PINTO_HOME/etc" mkdir -p "$PINTO_ETC" #----------------------------------------------------------------------------- # Write the bash setup file in etc/ PINTO_BASHRC="$PINTO_ETC/bashrc" cat > "$PINTO_BASHRC" <parent; my $libdir = $distdir->subdir('lib'); push @INC, $libdir->stringify; #----------------------------------------------------------------------------- # Copyright 2013 Jeffrey Ryan Thalhammer #----------------------------------------------------------------------------- # Read DDL from inside the Database class require Pinto::Database; my $ddl = Pinto::Database->ddl; #----------------------------------------------------------------------------- # Create a temp directory to stash the database my $tmpdir = $distdir->subdir('tmp'); mkpath $tmpdir->stringify if not -e $tmpdir; #----------------------------------------------------------------------------- # Create database, feeding in the DDL my $dbfile = $tmpdir->file('pinto.db'); unlink $dbfile or die $!; open my $fh, '|-', "sqlite3 $dbfile" or die $!; print $fh $ddl; #----------------------------------------------------------------------------- # Run the schema generator system <<"END_COMMAND"; dbicdump -Ilib \\ -o skip_load_external=1 \\ -o dump_directory=lib \\ -o 'use_moose=1' \\ -o 'result_roles=[ qw(Pinto::Role::Schema::Result) ]' \\ Pinto::Schema \\ dbi:SQLite:$dbfile END_COMMAND #----------------------------------------------------------------------------- exit; Pinto-0.14/etc/smoke000755 000766 000024 00000003342 13141540305 014422 0ustar00jeffstaff000000 000000 #!/bin/bash -ue ###################################################################### # # THIS IS THE Pinto SMOKER # # I use this little script to build & test Pinto against several # common versions of Perl that I have on my machine. The key thing # is that all the dependencies come from a curated repository on # Stratopan. So these are not the latest versions, but versions # that I have blessed. In comparison, the builds on Travis are # done with the latest versions from CPAN, which don't always work. # # Copyright 2013 Jeffrey Ryan Thalhammer # ###################################################################### unset PINTO_HOME; MODULES_TO_SMOKE=${1:-Pinto}; SMOKE_BASE_DIR=$HOME/tmp/smoke CPAN_MIRROR_URL=https://stratopan.com/thaljef/OpenSource/pinto-release PERLS_TO_SMOKE=${2:-'5.8.9 5.10.1 5.12.5 5.14.4 5.16.3 5.18.4 5.20.3 5.22.2 5.24.0'} for pv in $PERLS_TO_SMOKE; do SMOKE_WORK_DIR="$SMOKE_BASE_DIR/$pv"; # TODO: add a command-line option to control whether # or not to blow away an existing local-lib directory # rm -rf "$SMOKE_WORK_DIR"; mkdir -p "$SMOKE_WORK_DIR"; for mod in $MODULES_TO_SMOKE; do echo "=============================================================="; echo "Smoking $mod with perl-$pv in $SMOKE_WORK_DIR"; perlbrew exec --with $pv \ cpanm --mirror "$CPAN_MIRROR_URL" \ --local-lib-contained "$SMOKE_WORK_DIR" \ --mirror-only \ --quiet \ $mod \ 2>&1 | tee "$SMOKE_WORK_DIR/smoke.log" done; done; Pinto-0.14/etc/TODO.pod000644 000766 000024 00000004451 13141540305 014631 0ustar00jeffstaff000000 000000 =head1 HIGH PRIORITY =over 4 =item Fallback if upstream repo does not respond =item Add --with-recommended-dependencies =item Apply --no-index to prereqs too? =item Fix line buffering in Pinto::Remote::Action. =item Create command to list outdated packages. =item Move repository configuration into the DB =item Heirarchy of exception classes =item Create a hook mechanism to do stuff before or after an Action =back =head1 MEDIUM PRORITY =over 4 =item Enable locks on all stacks (repo lock) =item Lookup dists without the extension (e.g. .zip or .tar.gz or .tgz) =item Consider pinning at dist level, not pkg =item Create command to list dependors and dependants =item Create command to verify prereqs on a stack =item Create command to list outdated packages =item Create command to package whole repo in tar.gz =item Stack property: allow devel releases =item Repo property: default devel option =item Profile and look for performance optimizations. =item Verify archive checksums during 'verify' =item Standardize API, using named parameters except where it makes sense not to. =item Tests, tests, tests. =back =head1 LOW PRIORITY =over 4 =item Optimize generation of CHECKSUMS files. =item Improve Perl::Critic compliance. =item Document, document, document. =item Look for better ways to use Moose roles. =item Issue warning if META indicates that configuration is dynamic. =back =head1 QUESTIONABLE =over 4 =item Give revisions properties =item Try to ensure integrity of commits (what does this mean?) =item Stack property: strict (no overlapping dists) =item Add versioning to the stack props =item Consider using natural keys for package/dists. =item Make the Store transactional =item Extract versioning stuff to a separate dist. =item Rewrite tests with Test::Class =item Mark stacks as merged after merge =item Warn if an unmerged stack is being deleted =back =head1 SCRAPPED =over 4 =item Generate a RECENT file. =item Command options to specify provided/required packages (maybe not) =item Enable plugins for visiting and filtering. =item news: list recent additions. maybe something from Changes file =item ack: Do an ack command across all distributions =item look: Unpack archive in temp dir and launch shell there =item Mark stacks as deleted after delete =back =cut Pinto-0.14/bin/pinto000755 000766 000024 00000024017 13141540305 014434 0ustar00jeffstaff000000 000000 #!perl # ABSTRACT: Curate a custom repository of Perl modules # PODNAME: pinto #----------------------------------------------------------------------------- use strict; use warnings; #----------------------------------------------------------------------------- our $VERSION = '0.14'; # VERSION #----------------------------------------------------------------------------- my $home_var = 'PINTO_HOME'; my $home_dir = $ENV{$home_var}; if ($home_dir) { require File::Spec; my $lib_dir = File::Spec->catfile($home_dir, qw(lib perl5)); die "$home_var ($home_dir) does not exist!\n" unless -e $home_dir; eval qq{use lib '$lib_dir'; 1} or die $@; ## no critic (Eval) } unless ( eval {require App::Pinto; 1} ) { die $home_dir ? $@ : $@ . "Do you need to set $home_var?\n"; } #----------------------------------------------------------------------------- exit App::Pinto->run if not caller; #----------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME pinto - Curate a custom repository of Perl modules =head1 VERSION version 0.14 =head1 SYNOPSIS pinto --root=REPOSITORY_ROOT [global options] COMMAND [command options] [args] =head1 DESCRIPTION pinto is a tool for creating and managing a custom CPAN-like repository of Perl modules. The purpose of such a repository is to provide a stable, curated stack of dependencies from which you can reliably build, test, and deploy your application using the standard Perl tool chain. pinto provides various commands for gathering and managing distribution dependencies within the repository, so that you can control precisely which dependencies go into your application. =head1 COMMANDS pinto supports several commands that perform various operations on your repository, or report information about your repository. To get a listing of all the available commands: $> pinto commands Each command has its own options and arguments. To get a brief summary: $> pinto help COMMAND To see the complete manual for a command: $> pinto manual COMMAND =head1 GLOBAL OPTIONS The following options are available for all commands. =over 4 =item --root DIRECTORY | URI =item -r DIRECTORY | URI Specifies the root of your repository. This is mandatory for (almost) all commands unless you set it via the C environment variable. The root can be the path to a local directory or an equivalent C URI. The root can also be the URI where a L server is listening. Depending on your server configuration, you may need to specify the port number in the URI, which is usually 3111. =item --color =item --colour =item --no-color =item --no-colour Enable or disable colorized command output. By default, color is enabled unless the output is being sent to a pipe or file. Set the C environment variable to disable color by default. =item --password PASS =item -p PASS The password to use for server authentication. This is only relevant if using a remote repository. If the PASS is "-" then you will be prompted for a password. =item --quiet =item -q Report only fatal errors. This option silently overrides the C<--verbose> options. Also suppresses the progress meter. Note: The progress meter is always suppressed when using a remote repository. This will hopefully be fixed a future release. =item --username NAME =item -u NAME The username to user for server authentication. This is only relevant if using a remote repository. Defaults to your current login. =item --verbose =item -v Display more diagnostic messages. This switch can be repeated multiple times for greater effect. Diagnostic messages are always sent to STDERR. =back =head1 CONFIGURATION Each repository has a configuration file that lives inside the repository at F<.pinto/config/pinto.ini>. This file is generated for you with default values when you create the repository. You can influence the initial value for some of the properties when you run the L command. Thereafter, you can change these properties by editing the configuraiton file directly. The following configuration parameters are supported: =over 4 =item sources = URL1 [URL2 URL3 ...] This is a space-delimited list of the URLs for the upstream repositories that this repository will pull archives from. These can point to CPAN mirrors, minicpan mirrors, or stacks within other Pinto repositories. Pinto will search the source repositories in the order they are listed here. The default value is C. =item target_perl_version = X.X.X Sets the default C property for all new stacks. Otherwise, all new stacks will target the version of perl that you first used to create the repository. You can always configure the target perl for each stack independently by using the L command. =item intermingle = 1 | 0 If true, stacks will be allowed to "intermingle" distributions that have partially overlapping packages. This makes pinto behave like PAUSE which allows a package to remain in the index until it is replaced by a distribution containing the same package. Thus, it becomes possible to have an index that contains just C of the packages in a particular distribution. This typically occurrs when a package in a prior release is absent from a subsequent release. The default is false. =back B The above configuration properties are global -- they affect every stack in the repository. They also have a major affect on how the repository behaves. For these reasons, it is generally unwise to change these parameters once you have established the repository and filled it with content. If you do change them, be sure and notify your team about it. Each stack also has some stack-specific configuration properties. Those can be shown or set using the L command. =head1 ENVIRONMENT VARIABLES The following environment variables influence the behavior of pinto. If you have installed pinto as a stand-alone application as described in L, then the best place to set these variables is in your F<~/.pintorc> file. =over 4 =item C Sets the default path or URL of the pinto repository, if the C<--root> is not specified. The C<--root> is required for almost all commands. So if you usually only work with one repository, then setting this can save you quite a bit of typing. =item C Sets the path to editor application that will be used to compose log messages. If not set, defaults to C or C. If none of those are set, either C, C, or C will be used (in that order). =item C =item C If set to a true value, suppresses color in all command output. =item C A comma-separated list of exactly three color names. Any name supported by L is allowed. These will be the colors that pinto uses to colorize various output. For example: PINTO_PALETTE='red, light blue, green on_white' Listing too many or too few colors will cause an exception, as will using an invalid color name. For backward compatibility the variables C and C can also be used (but they are deprecated). =item C Sets the default username when C<--username> is not specified. This is only used for authentication with a L server. Defaults to your current shell username. =item C Sets the default author identity when the C<--author> option is not specified (currently, only used by the L command). Defaults to your current shell username. By PAUSE convention, all author id's are forced to uppercase. =item C Sets the path to the pager application that will be used to paginate output from each command. Defaults to C. If none of these are set, then no pager is used. =item C Sets the options that will be passed to the pager (if there is one). For example, you could use the C<-R> option to instruct C to pass through the colors that pinto usually displays: export PINTO_PAGER_OPTIONS=-R Most pagers have their own environment variables to control their default behavior. C gives you a way to set defaults that are specific to when you are using it with pinto. =item C Sets the default style for diff reports. Valid styles are C and C. The default is C. For commands that produce diff reports, this can be overriden with the C<--diff-style> option. This variable only has effect when using a local repository. =item C If set to 1, pinto will emit more diagnostic messages to STDERR. If set to 2, pinto will emit even more diagnostic messages. This variable only has effect when using a local repository. =item C Sets the timeout (in seconds) for obtaining a lock on the repository. The default is 50. This variable only has effect when using a local repository. =item C Sets the timeout (in seconds) to consider a lock on the repository stale and expire it. The default is 0 (don't expire). This variable only has effect when using a local repository. =item C Sets the path to the command pinto will use for interactive shells (like with the L command). If this is not set, pinto defaults to either C or C. =back =head1 SEE ALSO L to allow remote access to your Pinto repository. L for general information on using Pinto. L for hosting your Pinto repository in the cloud. =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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 Pinto-0.14/bin/pintod000755 000766 000024 00000015167 13141540305 014606 0ustar00jeffstaff000000 000000 #!perl # ABSTRACT: Web interface to a Pinto repository # PODNAME: pintod #----------------------------------------------------------------------------- use strict; use warnings; #----------------------------------------------------------------------------- BEGIN { my $home_var = 'PINTO_HOME'; my $home_dir = $ENV{$home_var}; if ($home_dir) { require File::Spec; my $lib_dir = File::Spec->catfile($home_dir, qw(lib perl5)); die "$home_var ($home_dir) does not exist!\n" unless -e $home_dir; eval qq{use lib '$lib_dir'; 1} or die $@; ## no critic (Eval) } unless ( eval {require Pinto::Server; 1} ) { die $home_dir ? $@ : $@ . "Do you need to set $home_var?\n"; } } #----------------------------------------------------------------------------- use Pod::Usage; use Plack::Runner; use List::MoreUtils qw(none); use Getopt::Long qw(:config pass_through); # to retain unrecognized options #----------------------------------------------------------------------------- our $VERSION = '0.14'; # VERSION #----------------------------------------------------------------------------- my @opt_spec = qw(root|r=s auth=s%); GetOptions(\my %opts, @opt_spec) or pod2usage; $opts{root} ||= $ENV{PINTO_REPOSITORY_ROOT}; pod2usage(-message => 'Must specify a repository root') if not $opts{root}; # HACK: To avoid defaulting to the Plack default port, we must wedge # in our own --port argument, unless the user has specified their own. push @ARGV, ('--port' => Pinto::Server->default_port) if none { /^ --? p(?: ort)?/x } @ARGV; # HACK: Wedge in our own --server argument, unless the user has # specified one or has set the PLACK_SERVER environment variable push @ARGV, ('--server' => 'Starman') if !$ENV{PLACK_SERVER} and none { /^ --? s(?: erver)?/x } @ARGV; # TODO: Consider sending the server access log into the log directory # for the repository by default, so everything is in one place. my $runner = Plack::Runner->new; $runner->parse_options(@ARGV); my $server = Pinto::Server->new(%opts); my $app = $server->to_app; $runner->run($app); #---------------------------------------------------------------------------- __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer pintod =head1 NAME pintod - Web interface to a Pinto repository =head1 VERSION version 0.14 =head1 SYNOPSIS pintod --root=/path/to/repository [--auth key=value] [--port=N] =head1 DESCRIPTION C provides a web API to a L repository. Clients (like L) can use this API to manage and inspect the repository. In addition, C serves up the distributions within the repository, so you can use it as the backend for L or L. Before running C you must first create a Pinto repository. For example: pinto --root=/path/to/repository init See L for more information about creating a reposiotry. =head1 ARGUMENTS =over 4 =item --root PATH =item -r PATH The path to the root directory of the Pinto repository you wish to serve. Alternatively, you may set the C environment variable. =back =head1 OPTIONS =over 4 =item --auth KEY=VALUE Sets an option for the authentication scheme (default is no authentication). Each time this is used, a key=value pair must follow; one of them must be 'backend', which should correspond to a class in the L namespace. The remaining options will be passed as-is to the authentication backend. See L<"USING BASIC HTTP AUTHENTICATION"> for more guidance on enabling authenticaion with minimal fuss, or see L<"USING OTHER AUTHENTICATION SCHEMES"> for more complex options. =item --port INTEGER =item -p INTEGER Specifies the port number that the server will listen on. The default is B<3111>. If you specify a different port, all clients will also have to specify that port. So you probably don't want to change the port unless you have a very good reason. =item other options All other options supported by L are supported too, such as C<--server>, C<--daemonize>, C<--access-log>, C<--error-log> etc. These will be passed to L. By default, C uses on the L for the server backend. Be aware that not all servers support the same options. =back =head1 USING BASIC HTTP AUTHENTICATION C ships with L, so the easiest way to run the server with basic HTTP authentication is to create a password file using the C utility: htpasswd -c /path/to/htpasswd USER You will be prompted to enter the password for C twice. Then repeat that command B for each additional user. You may want to put the F file inside the top of your repository. Then launch pintod like this: pintod --root path/to/repository --auth backend=Passwd --auth path=path/to/htpasswd If you already have an F file somewhere, you may just point to it directly, or create a symlink. In any case, the F file needs to be readable by the user that will be running C. =head1 USING OTHER AUTHENTICATION SCHEMES If you wish to use a different authenticaion scheme, then you'll first need to install the appropriate L backend module. Then configure L accordingly. For example, this would be a valid configuration for Kerberos: --auth backend=Kerberos --auth realm=REALM.YOUR_COMPANY.COM and this is how the authentication backend will be constructed: my $auth = Authen::Simple::Kerberos->new( realm => 'REALM.YOUR_COMPANY.COM' ); =head1 DEPLOYMENT C is PSGI compatible, running under L by default. It will use whatever backend you specify on the command line or have configured in your environment (defaults to L). If you wish to add your own middleware and/or customize the backend in other ways, you can use L in a custom F<.psgi> script like this: # my-pintod.psgi my %opts = (...); my $server = Pinto::Server->new(%opts); my $app = $server->to_app; # wrap $app with middlewares here and/or # insert code customized for your backend # which operates on the $app Then you may directly launch F using L. =head1 SEE ALSO L to create and manage a Pinto repository. L for general information on using Pinto. L for hosting your Pinto repository in the cloud. =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015 by Jeffrey Ryan Thalhammer. 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