pinto-0.097+dfsg.orig/0000755000076500007650000000000012264262436011501 5ustar pinto-0.097+dfsg.orig/xt/0000755000000000000000000000000012264262436013700 5ustar rootrootpinto-0.097+dfsg.orig/xt/release/0000755000076500007650000000000012264262436013554 5ustar pinto-0.097+dfsg.orig/xt/release/02-workarounds.t0000644000076500007650000000245112263155037016535 0ustar #!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)) { 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" ); } #------------------------------------------------------------------------------ done_testing; pinto-0.097+dfsg.orig/xt/release/test-version.t0000644000076500007650000000064312263155037016403 0ustar use strict; use warnings; use Test::More; # generated by Dist::Zilla::Plugin::Test::Version 0.002004 BEGIN { eval "use Test::Version; 1;" or die $@; } my @imports = ( 'version_all_ok' ); my $params = { is_strict => 0, has_version => 1, }; push @imports, $params if version->parse( $Test::Version::VERSION ) >= version->parse('1.002'); Test::Version->import(@imports); version_all_ok; done_testing; pinto-0.097+dfsg.orig/xt/release/distmeta.t0000644000076500007650000000033212263155037015546 0ustar #!perl # This file was automatically generated by Dist::Zilla::Plugin::MetaTests. use Test::More; eval "use Test::CPAN::Meta"; plan skip_all => "Test::CPAN::Meta required for testing META.yml" if $@; meta_yaml_ok(); pinto-0.097+dfsg.orig/xt/release/99-memory-cycle.t0000644000076500007650000000214512263155037016604 0ustar #!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.097+dfsg.orig/xt/release/pod-syntax.t0000644000076500007650000000033212263155037016042 0ustar #!perl # This file was automatically generated by Dist::Zilla::Plugin::PodSyntaxTests. use Test::More; eval "use Test::Pod 1.41"; plan skip_all => "Test::Pod 1.41 required for testing POD" if $@; all_pod_files_ok(); pinto-0.097+dfsg.orig/xt/help/0000755000076500007650000000000012263155037013061 5ustar pinto-0.097+dfsg.orig/xt/help/50-manual_cmd.t0000644000076500007650000000275112263155037015575 0ustar #!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'; my @cmd = ( "perl", "-Ilib", "bin/${program_name}" ); diag("\$ $program_name @args"); my @r = trap { system( @cmd, @args ) }; return @r; } #------------------------------------------------------------------------------- done_testing; pinto-0.097+dfsg.orig/Build.PL0000644000076500007650000001151312263155037012773 0ustar # This file was automatically generated by Dist::Zilla::Plugin::ModuleBuild v5.008. use strict; use warnings; use Module::Build 0.3601; use lib qw{inc}; use Pinto::Module::Build; my %module_build_args = ( "build_requires" => { "Module::Build" => "0.4005", "Module::Build::CleanInstall" => "0.05" }, "configure_requires" => { "Module::Build" => "0.4005", "Module::Build::CleanInstall" => "0.05" }, "dist_abstract" => "Curate a repository of Perl modules", "dist_author" => [ "Jeffrey Ryan Thalhammer " ], "dist_name" => "Pinto", "dist_version" => "0.097", "license" => "perl", "module_name" => "Pinto", "recommends" => {}, "recursive_test_files" => 1, "requires" => { "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, "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.924", "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, "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" => "3.03", "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, "Package::Locator" => "0.010", "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", "Term::EditorEdit" => 0, "Throwable::Error" => "0.200005", "Try::Tiny" => 0, "URI" => 0, "UUID::Tiny" => 0, "base" => 0, "overload" => 0, "perl" => "5.008", "strict" => 0, "utf8" => 0, "version" => 0, "warnings" => 0 }, "script_files" => [ "bin/pinto", "bin/pintod" ], "test_requires" => { "Apache::Htpasswd" => 0, "Capture::Tiny" => 0, "English" => 0, "ExtUtils::MakeMaker" => 0, "File::Spec" => 0, "File::Spec::Functions" => 0, "File::Temp" => 0, "FindBin" => 0, "HTTP::Body" => 0, "HTTP::Request" => 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, "Test::TCP" => 0, "Test::Warn" => 0, "lib" => 0, "perl" => "5.008" } ); my %fallback_build_requires = ( "Apache::Htpasswd" => 0, "Capture::Tiny" => 0, "English" => 0, "ExtUtils::MakeMaker" => 0, "File::Spec" => 0, "File::Spec::Functions" => 0, "File::Temp" => 0, "FindBin" => 0, "HTTP::Body" => 0, "HTTP::Request" => 0, "HTTP::Response" => 0, "HTTP::Server::PSGI" => 0, "IO::Handle" => 0, "IPC::Open3" => 0, "Module::Build" => "0.4005", "Module::Build::CleanInstall" => "0.05", "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, "Test::TCP" => 0, "Test::Warn" => 0, "lib" => 0, "perl" => "5.008" ); unless ( eval { Module::Build->VERSION(0.4004) } ) { delete $module_build_args{test_requires}; $module_build_args{build_requires} = \%fallback_build_requires; } my $build = Pinto::Module::Build->new(%module_build_args); $build->create_build_script; pinto-0.097+dfsg.orig/LICENSE0000644000076500007650000004371412263155037012514 0ustar This software is copyright (c) 2013 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) 2013 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, Suite 500, Boston, MA 02110-1335 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) 2013 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.097+dfsg.orig/Changes0000644000076500007650000016001712263155037012776 0ustar 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! - 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 commmand. 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.097+dfsg.orig/inc/0000755000000000000000000000000012264262436014016 5ustar rootrootpinto-0.097+dfsg.orig/inc/Pinto/0000755000000000000000000000000012264262436015107 5ustar rootrootpinto-0.097+dfsg.orig/inc/Pinto/Module/0000755000076500007650000000000012263155037014565 5ustar pinto-0.097+dfsg.orig/inc/Pinto/Module/Build.pm0000644000076500007650000000027712263155037016170 0ustar package Pinto::Module::Build; use strict; use warnings; use base 'Module::Build::CleanInstall'; #------------------------------------------------------------------------------ 1; __END__ pinto-0.097+dfsg.orig/weaver.ini0000644000076500007650000000146412263155037013475 0ustar [@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.097+dfsg.orig/bin/0000755000076500007650000000000012264262436012251 5ustar pinto-0.097+dfsg.orig/bin/pintod0000755000076500007650000001554012263155037013476 0ustar #!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.097'; # 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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn pintod =head1 NAME pintod - Web interface to a Pinto repository =head1 VERSION version 0.097 =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) 2013 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.097+dfsg.orig/bin/pinto0000755000076500007650000001763012263155037013334 0ustar #!perl # ABSTRACT: Curate a custom repository of Perl modules # PODNAME: pinto #----------------------------------------------------------------------------- use strict; use warnings; #----------------------------------------------------------------------------- our $VERSION = '0.097'; # 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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME pinto - Curate a custom repository of Perl modules =head1 VERSION version 0.097 =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 | URL =item -r DIRECTORY | URL Specifies the root of your repository. This is mandatory for (almost) all commands unless you've set the C environment variable to point to your repository. The root can be a path to a local directory, or the URL where a L server is listening. =item --no-color =item --no-colour Do not colorize command output. =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 repostiory 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. =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 =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_COLORS='red, light blue, green on_white' Listing too many or too few colors will cause an exception, as will using an invalid color name. =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 If set to 1, pinto will emit more diagnostic messages to STDERR. If set to 2, pinto will emit even more diagnostic messages. =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) 2013 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.097+dfsg.orig/MANIFEST.SKIP0000644000076500007650000000012112263155037013366 0ustar ^profiles ^nytprof ^tmp$ ^[.]tags ^perltidy.LOG ^[.].tidyall.d ^[.]build ^TEST pinto-0.097+dfsg.orig/lib/0000755000076500007650000000000012264262436012247 5ustar pinto-0.097+dfsg.orig/lib/Pinto/0000755000076500007650000000000012264262436013340 5ustar pinto-0.097+dfsg.orig/lib/Pinto/Schema/0000755000000000000000000000000012264262436016304 5ustar rootrootpinto-0.097+dfsg.orig/lib/Pinto/Schema/Result/0000755000076500007650000000000012264262436016016 5ustar pinto-0.097+dfsg.orig/lib/Pinto/Schema/Result/Distribution.pm0000644000076500007650000003245412263155037021040 0ustar 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::DistributionSpec; use overload ( '""' => 'to_string', 'cmp' => 'string_compare' ); #------------------------------------------------------------------------------ our $VERSION = '0.097'; # 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 $pin = $args{pin}; my $did_register = 0; $stack->assert_is_open; $stack->assert_not_locked; # 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) { my $where = {package_name => $pkg->name}; my $incumbent = $stack->head->find_related(registrations => $where); if (not defined $incumbent) { debug( sub {"Registering $pkg on stack $stack"} ); $pkg->register(stack => $stack, pin => $pin); $did_register++; next; } 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 = $pkg->name; throw "Unable to register distribution $self: package $pkg_name is pinned to $incumbent_pkg"; } whine "Downgrading package $incumbent_pkg to $pkg on stack $stack" if $incumbent_pkg > $pkg; $incumbent->distribution->unregister(stack => $stack); $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 url { my ( $self, $base ) = @_; # TODO: Is there a sensible URL 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 a package name that matches the dist name for my $pkg (@pkgs) { return $pkg->name if $pkg->name eq $dist_name; } # Then, look for a package name that matches it's file name for my $pkg (@pkgs) { return $pkg->name if $pkg->is_simile; } # Then just use the first (i.e. shortest) package name return $pkgs[0]->name if @pkgs; # If we get here, then there are no packages, so we just guess whine "Guessing that main module for $self is $dist_name"; return $dist_name; } #------------------------------------------------------------------------------ sub package_count { my ($self) = @_; return scalar $self->packages; } #------------------------------------------------------------------------------ sub prerequisite_specs { my ($self) = @_; return map { $_->as_spec } $self->prerequisites; } #------------------------------------------------------------------------------ sub as_spec { my ($self) = @_; return Pinto::DistributionSpec->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 { $self->main_module }, '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->url }, '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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Schema::Result::Distribution - Represents a distribution archive =head1 VERSION version 0.097 =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) 2013 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.097+dfsg.orig/lib/Pinto/Schema/Result/Package.pm0000644000076500007650000002135012263155037017705 0ustar 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 Pinto::PackageSpec; use Pinto::Util qw(itis throw); use overload ( '""' => 'to_string', '<=>' => 'numeric_compare', 'cmp' => 'string_compare', fallback => undef ); #------------------------------------------------------------------------------ our $VERSION = '0.097'; # 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' ); #------------------------------------------------------------------------------ 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_spec { my ($self) = @_; return Pinto::PackageSpec->new( name => $self->name, version => $self->version ); } #------------------------------------------------------------------------------ sub is_simile { my ($self) = @_; my $name = $self->name; my $file = $self->file; $file =~ s/\//::/g; $file =~ s/\.pm$//; return $file =~ m/$name $/x ? 1 : 0; } #------------------------------------------------------------------------------ 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() }, '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->url() }, ); # 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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Schema::Result::Package - Represents a Package provided by a Distribution =head1 VERSION version 0.097 =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) 2013 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.097+dfsg.orig/lib/Pinto/Schema/Result/Stack.pm0000644000076500007650000004730512263155037017427 0ustar 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.097'; # 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; }; #------------------------------------------------------------------------------ sub get_distribution { my ( $self, %args ) = @_; my $cache = $args{cache}; my $spec = $args{spec} or throw 'Invalid arguments'; return $cache->{$spec} if $cache && exists $cache->{$spec}; if ( itis( $spec, 'Pinto::DistributionSpec' ) ) { my $attrs = { prefetch => [qw(distribution)], distinct => 1 }; my $where = { 'distribution.author' => $spec->author, 'distribution.archive' => $spec->archive }; my $reg = $self->head->search_related( registrations => $where, $attrs )->first; return if not defined $reg; my $dist = $reg->distribution; $cache->{$spec} = $dist if $cache; return $dist;; } elsif ( itis( $spec, 'Pinto::PackageSpec' ) ) { my $attrs = { prefetch => [qw(package distribution)] }; my $where = { package_name => $spec->name }; my $reg = $self->head->find_related( registrations => $where, $attrs ); return if not defined $reg; return if $reg->package->version < $spec->version; my $dist = $reg->distribution; $cache->{$spec} = $dist if $cache; return $dist; } throw 'Invalid arguments'; } #------------------------------------------------------------------------------ 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 $new_rev_id = $new_rev->id; my $old_rev_id = $self->head->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 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->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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Schema::Result::Stack - Represents a named set of Packages =head1 VERSION version 0.097 =head1 METHODS =head2 get_distribution( spec => $dist_spec ) Given a L, returns the L which contains the package with the same name as the spec B. Returns nothing if no such distribution is found in this stack. =head2 get_distribution( spec => $pkg_spec ) Given a L, returns the L from this stack with the same author id and archive attributes as the spec. 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) 2013 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.097+dfsg.orig/lib/Pinto/Schema/Result/Revision.pm0000644000076500007650000002646012263155037020157 0ustar 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.097'; # 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, time_zone => $_[0]->timezone ) }, init_arg => undef, lazy => 1, ); has timezone => ( is => 'ro', isa => 'DateTime::TimeZone', default => sub { my $offset = DateTime::TimeZone->offset_as_string( $_[0]->repo->config->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 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; $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->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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Schema::Result::Revision - Represents a set of changes to a stack =head1 VERSION version 0.097 =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) 2013 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.097+dfsg.orig/lib/Pinto/Schema/Result/RegistrationChange.pm0000644000076500007650000000176412263155037022141 0ustar # ABSTRACT: Not in use -- will be removed package Pinto::Schema::Result::RegistrationChange; use Moose; use MooseX::NonMoose; use MooseX::MarkAsMethods autoclean => 1; extends 'DBIx::Class::Core'; #----------------------------------------------------------------------------- our $VERSION = '0.097'; # VERSION #----------------------------------------------------------------------------- __PACKAGE__->table("registration_change"); #----------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Schema::Result::RegistrationChange - Not in use -- will be removed =head1 VERSION version 0.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Schema/Result/Ancestry.pm0000644000076500007650000000534712263155037020152 0ustar 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.097'; # 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.097 =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) 2013 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.097+dfsg.orig/lib/Pinto/Schema/Result/Registration.pm0000644000076500007650000001712012263155037021024 0ustar 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.097'; # 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 }, 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->url }, 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.097 =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) 2013 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.097+dfsg.orig/lib/Pinto/Schema/Result/Prerequisite.pm0000644000076500007650000001063212263155037021034 0ustar 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::PackageSpec; use overload ( '""' => 'to_string' ); #------------------------------------------------------------------------------ our $VERSION = '0.097'; # VERSION #------------------------------------------------------------------------------ __PACKAGE__->inflate_column( 'package_version' => { inflate => sub { version->parse( $_[0] ) }, deflate => sub { $_[0]->stringify() }, } ); #------------------------------------------------------------------------------ # 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_spec => ( is => 'ro', isa => 'Pinto::PackageSpec', init_arg => undef, lazy => 1, handles => [qw(is_core is_perl)], default => sub { Pinto::PackageSpec->new( name => $_[0]->package_name, version => $_[0]->package_version ); }, ); #------------------------------------------------------------------------------ sub to_string { my ($self) = @_; return $self->as_spec->to_string; } #------------------------------------------------------------------------------ __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.097 =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) 2013 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.097+dfsg.orig/lib/Pinto/Schema/ResultSet/0000755000076500007650000000000012264262436016472 5ustar pinto-0.097+dfsg.orig/lib/Pinto/Schema/ResultSet/Distribution.pm0000644000076500007650000000307312263155037021507 0ustar # ABSTRACT: Common queries for Distributions use utf8; package Pinto::Schema::ResultSet::Distribution; use strict; use warnings; use base 'DBIx::Class::ResultSet'; #------------------------------------------------------------------------------ our $VERSION = '0.097'; # 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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Schema::ResultSet::Distribution - Common queries for Distributions =head1 VERSION version 0.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Schema/ResultSet/Package.pm0000644000076500007650000000237012263155037020362 0ustar # ABSTRACT: Common queries for Packages use utf8; package Pinto::Schema::ResultSet::Package; use strict; use warnings; use base 'DBIx::Class::ResultSet'; #------------------------------------------------------------------------------ our $VERSION = '0.097'; # VERSION #------------------------------------------------------------------------------ sub with_distribution { my ( $self, $where ) = @_; return $self->search( $where || {}, { prefetch => 'distribution' } ); } #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Schema::ResultSet::Package - Common queries for Packages =head1 VERSION version 0.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Schema/ResultSet/Registration.pm0000644000076500007650000000332512263155037021502 0ustar # ABSTRACT: Common queries for Registrations use utf8; package Pinto::Schema::ResultSet::Registration; use strict; use warnings; use base 'DBIx::Class::ResultSet'; #------------------------------------------------------------------------------ our $VERSION = '0.097'; # 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.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Role/0000755000076500007650000000000012264262436014241 5ustar pinto-0.097+dfsg.orig/lib/Pinto/Role/Schema/0000755000076500007650000000000012263155037015436 5ustar pinto-0.097+dfsg.orig/lib/Pinto/Role/Schema/Result.pm0000644000076500007650000000362512263155037017260 0ustar # 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.097'; # 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.097 =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) 2013 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.097+dfsg.orig/lib/Pinto/Role/Transactional.pm0000644000076500007650000000244112263155037017377 0ustar # 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.097'; # 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.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Role/Puller.pm0000644000076500007650000001156312263155037016045 0ustar # ABSTRACT: Something pulls packages to a stack package Pinto::Role::Puller; use Moose::Role; use MooseX::Types::Moose qw(Bool); use MooseX::MarkAsMethods ( autoclean => 1 ); use Pinto::Util qw(throw); #----------------------------------------------------------------------------- our $VERSION = '0.097'; # 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 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 $dist; if ( $target->isa('Pinto::Schema::Result::Distribution') ) { $dist = $target; } elsif ( $target->isa('Pinto::DistributionSpec') ) { $dist = $self->find( target => $target ); } elsif ( $target->isa('Pinto::PackageSpec') ) { my $tpv = $stack->target_perl_version; if ( $target->is_core( in => $tpv ) ) { $self->warning("Skipping $target: included in perl $tpv core"); return; } $dist = $self->find( target => $target ); } else { throw "Illeagal arguments"; } $dist->register( stack => $stack, pin => $self->pin ); $self->do_recursion( start => $dist ) if $self->recurse; return $dist; } #----------------------------------------------------------------------------- sub find { my ( $self, %args ) = @_; my $target = $args{target}; my $stack = $self->stack; my $dist; my $msg; if ( $dist = $stack->get_distribution( spec => $target ) ) { $msg = "Found $target on stack $stack in $dist"; } elsif ( $dist = $stack->repo->get_distribution( spec => $target ) ) { $msg = "Found $target in $dist"; } elsif ( $dist = $stack->repo->ups_distribution( spec => $target, cascade => $self->cascade ) ) { $msg = "Found $target in " . $dist->source; } $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 %latest; my $cb = sub { my ($prereq) = @_; my $pkg_name = $prereq->package_name; my $pkg_vers = $prereq->package_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( $latest{$pkg_name} ) && $pkg_vers <= $latest{$pkg_name}; # I think the only time that we won't see a $dist here is when # the prereq resolves to a perl (i.e. its a core-only module). return if not my $dist = $self->find( target => $prereq->as_spec ); $dist->register( stack => $stack ); $latest{$pkg_name} = $pkg_vers; 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 $self; } #----------------------------------------------------------------------------- 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.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Role/FileFetcher.pm0000644000076500007650000001037312263155037016760 0ustar # ABSTRACT: Something that fetches remote files package Pinto::Role::FileFetcher; use Moose::Role; use MooseX::MarkAsMethods ( autoclean => 1 ); use File::Temp; use Path::Class; use LWP::UserAgent; use Pinto::Util qw(itis debug mtime throw); #------------------------------------------------------------------------------ our $VERSION = '0.097'; # VERSION #------------------------------------------------------------------------------ # Attributes has ua => ( is => 'ro', isa => 'LWP::UserAgent', builder => '_build_ua', lazy => 1, ); #------------------------------------------------------------------------------ sub fetch { my ( $self, %args ) = @_; my $from = $args{from}; my $from_uri = _make_uri($from); my $to = itis( $args{to}, 'Path::Class' ) ? $args{to} : file( $args{to} ); debug("Skipping $from: already fetched to $to") and return 0 if -e $to; $to->parent->mkpath if not -e $to->parent; my $has_changed = $self->_fetch( $from_uri, $to ); return $has_changed; } #------------------------------------------------------------------------------ sub fetch_temporary { my ( $self, %args ) = @_; my $url = URI->new( $args{url} )->canonical(); my $path = Path::Class::file( $url->path() ); return $path if $url->scheme() eq 'file'; my $base = $path->basename(); my $tempdir = File::Temp::tempdir( CLEANUP => 1 ); my $tempfile = Path::Class::file( $tempdir, $base ); $self->fetch( from => $url, to => $tempfile ); return Path::Class::file($tempfile); } #------------------------------------------------------------------------------ sub _fetch { my ( $self, $url, $to ) = @_; debug("Fetching $url"); my $result = eval { $self->ua->mirror( $url, $to ) } or throw $@; if ( $result->is_success() ) { return 1; } elsif ( $result->code() == 304 ) { return 0; } else { throw "Failed to fetch $url: " . $result->status_line; } # Should never get here } #------------------------------------------------------------------------------ sub _build_ua { my ($self) = @_; # TODO: Do we need to make some of this configurable? my $agent = sprintf "%s/%s", ref $self, 'VERSION'; my $ua = LWP::UserAgent->new( agent => $agent, env_proxy => 1, keep_alive => 5 ); return $ua; } #------------------------------------------------------------------------------ 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::Role::FileFetcher - Something that fetches remote files =head1 VERSION version 0.097 =head1 METHODS =head2 fetch(from => 'http://someplace' to => 'some/path') Fetches the file located at C to the file located at C, if the file at C is newer than the file at C. 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 and exception if anything goes wrong. The C argument can be either a L or L object, or a string that represents either of those. The C attribute can be a L object or a string that represents one. =head2 fetch_temporary(url => 'http://someplace') Fetches the file located at the C to a file in a temporary directory. The file will have the same basename as the C. 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) 2013 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.097+dfsg.orig/lib/Pinto/Role/Committable.pm0000644000076500007650000001211212263155037017031 0ustar # ABSTRACT: Role for actions that commit changes to the repository package Pinto::Role::Committable; use Moose::Role; use MooseX::Types::Moose qw(Bool Str); use MooseX::MarkAsMethods ( autoclean => 1 ); use Try::Tiny; use List::MoreUtils qw(uniq); use Pinto::Constants qw($PINTO_LOCK_TYPE_EXCLUSIVE); use Pinto::Types qw(StackName StackDefault StackObject); use Pinto::Util qw(is_interactive throw is_blank is_not_blank); #------------------------------------------------------------------------------ our $VERSION = '0.097'; # 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 lock_type => ( is => 'ro', isa => Str, default => $PINTO_LOCK_TYPE_EXCLUSIVE, 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); return $self->$orig; }; #------------------------------------------------------------------------------ around execute => sub { my ( $orig, $self, @args ) = @_; $self->repo->txn_begin; my $stack = $self->stack->start_revision; my @ok = try { $self->$orig(@args) } catch { $self->repo->txn_rollback; throw $_ }; if ( $self->dry_run ) { $self->notice('Dry run -- rolling back database'); $self->repo->txn_rollback; $self->repo->clean_files; } elsif ( $stack->refresh->has_not_changed ) { $self->warning('No index changes were made'); $self->repo->txn_rollback; } else { my $msg_title = $self->generate_message_title(@ok); my $msg = $self->compose_message( title => $msg_title, stack => $stack ); $stack->commit_revision( message => $msg ); $self->result->changed; $self->repo->txn_commit; } return $self->result; }; #------------------------------------------------------------------------------ sub compose_message { my ( $self, %args ) = @_; my $title = $args{title} || ''; my $stack = $args{stack} || throw 'Must specify a stack'; my $diff = $args{diff} || $stack->diff; 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 $cm = $self->generate_message_template($title, $stack, $diff); my $message = $self->chrome->edit( $cm ); $message =~ s/^ [#] .* $//gmsx; # Strip comments throw 'Aborting due to empty commit message' if is_blank($message); return $message; } #------------------------------------------------------------------------------ sub generate_message_title { my ( $self, @items, $extra ) = @_; my $class = ref $self; my ($action) = $class =~ m/ ( [^:]* ) $/x; my $title = "$action " . join( ', ', uniq(sort @items) ) . ( $extra ? " $extra" : '' ); return $title; } #------------------------------------------------------------------------------ sub generate_message_template { my ( $self, $title, $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.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Role/Plated.pm0000644000076500007650000000201612263155037016004 0ustar # ABSTRACT: Something that has chrome plating package Pinto::Role::Plated; use Moose::Role; use MooseX::MarkAsMethods ( autoclean => 1 ); #----------------------------------------------------------------------------- our $VERSION = '0.097'; # VERSION #----------------------------------------------------------------------------- has chrome => ( is => 'ro', isa => 'Pinto::Chrome', handles => [qw(show 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.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Role/PauseConfig.pm0000644000076500007650000000471412263155037017005 0ustar # ABSTRACT: Something that has a pause config attribute package Pinto::Role::PauseConfig; use Moose::Role; use MooseX::Types::Moose qw(HashRef); use Pinto::Types qw(File); use Path::Class; use File::HomeDir; #------------------------------------------------------------------------------ our $VERSION = '0.097'; # 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 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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn pauserc pausecfg =head1 NAME Pinto::Role::PauseConfig - Something that has a pause config attribute =head1 VERSION version 0.097 =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) 2013 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.097+dfsg.orig/lib/Pinto/Role/Installer.pm0000644000076500007650000000716012263155037016535 0ustar # 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_url_passwords); use Pinto::Constants qw($PINTO_MINIMUM_CPANM_VERSION); #----------------------------------------------------------------------------- our $VERSION = '0.097'; # 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_url ); #----------------------------------------------------------------------------- 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_url; $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_url_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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Role::Installer - Something that installs packages =head1 VERSION version 0.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Server.pm0000644000076500007650000000733412263155037015150 0ustar # 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.097'; # 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.097 =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) 2013 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.097+dfsg.orig/lib/Pinto/Difference.pm0000644000076500007650000001663512263155037015740 0ustar # 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::Util qw(itis); use overload ( q{""} => 'to_string' ); #------------------------------------------------------------------------------ our $VERSION = '0.097'; # VERSION #------------------------------------------------------------------------------ has left => ( is => 'ro', isa => 'Pinto::Schema::Result::Revision', required => 1, ); has right => ( is => 'ro', isa => 'Pinto::Schema::Result::Revision', required => 1, ); has diffs => ( traits => [qw(Array)], handles => { diffs => 'elements' }, isa => ArrayRef ['Pinto::DifferenceEntry'], builder => '_build_diffs', init_arg => undef, lazy => 1, ); has additions => ( traits => [qw(Array)], handles => { additions => 'elements' }, isa => ArrayRef ['Pinto::Schema::Result::Registration'], default => sub { [ map { $_->registration } grep { $_->op eq '+' } $_[0]->diffs ]; }, init_arg => undef, lazy => 1, ); has deletions => ( traits => [qw(Array)], handles => { deletions => 'elements' }, isa => ArrayRef ['Pinto::Schema::Result::Registration'], default => sub { [ map { $_->registration } grep { $_->op eq '-' } $_[0]->diffs ]; }, init_arg => undef, lazy => 1, ); has is_different => ( is => 'ro', isa => Bool, init_arg => undef, default => sub { shift->diffs > 0 }, lazy => 1, ); #------------------------------------------------------------------------------ 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. my @fields = qw(distribution package 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 @adds, @dels; 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->diffs; return $self; } #------------------------------------------------------------------------------ sub to_string { my ($self) = @_; return join '', $self->diffs; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; ############################################################################### ############################################################################### package Pinto::DifferenceEntry; use Moose; use MooseX::StrictConstructor; use MooseX::MarkAsMethods ( autoclean => 1 ); use MooseX::Types::Moose qw(Str); use overload ( q{""} => 'to_string', 'cmp' => 'string_compare', ); #------------------------------------------------------------------------------ our $VERSION = '0.097'; # VERSION #------------------------------------------------------------------------------ has op => ( is => 'ro', isa => Str, required => 1 ); has registration => ( is => 'ro', isa => 'Pinto::Schema::Result::Registration', required => 1, ); #------------------------------------------------------------------------------ sub to_string { my ($self) = @_; my $format = "[%F] %-40p %12v %a/%f\n"; return $self->op . $self->registration->to_string($format); } #------------------------------------------------------------------------------ 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::Difference - Compute difference between two revisions =head1 VERSION version 0.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/PackageSpec.pm0000644000076500007650000000644112263155037016046 0ustar # ABSTRACT: Specifies a package by name and version package Pinto::PackageSpec; use Moose; use MooseX::MarkAsMethods ( autoclean => 1 ); use MooseX::Types::Moose qw(Str); use Module::CoreList; use Pinto::Types qw(Version); use Pinto::Util qw(throw); use version; use overload ( '""' => 'to_string' ); #------------------------------------------------------------------------------ our $VERSION = '0.097'; # VERSION #------------------------------------------------------------------------------ has name => ( is => 'ro', isa => Str, required => 1, ); has version => ( is => 'ro', isa => Version, coerce => 1, default => sub { version->parse(0) } ); #------------------------------------------------------------------------------ around BUILDARGS => sub { my $orig = shift; my $class = shift; my @args = @_; if ( @args == 1 and not ref $args[0] ) { my ( $name, $version ) = split m{~}x, $_[0], 2; @args = ( name => $name, version => $version || 0 ); } return $class->$orig(@args); }; #------------------------------------------------------------------------------ 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($]); 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 }; # 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 0 if $self->version > $core_version; return 1; } #------------------------------------------------------------------------------- sub is_perl { my ($self) = @_; return $self->name eq 'perl' ? 1 : 0; } #------------------------------------------------------------------------------- sub to_string { my ($self) = @_; return sprintf '%s~%s', $self->name, $self->version->stringify; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::PackageSpec - Specifies a package by name and version =head1 VERSION version 0.097 =head1 METHODS =head2 is_core =head2 is_core(in => $version) Returns true if this package 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 package is perl itself. =head2 to_string() Serializes this PackageSpec to its string form. This method is called whenever the PackageSpec is evaluated in string context. =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Remote/0000755000076500007650000000000012264262436014573 5ustar pinto-0.097+dfsg.orig/lib/Pinto/Remote/Action.pm0000644000076500007650000001304612263155037016347 0ustar # 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(:server); use Pinto::Types qw(Uri); #------------------------------------------------------------------------------ our $VERSION = '0.097'; # VERSION #------------------------------------------------------------------------------ with qw(Pinto::Role::Plated); #------------------------------------------------------------------------------ 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, ); has ua => ( is => 'ro', isa => 'LWP::UserAgent', 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 $url = URI->new( $self->root ); $url->path_segments( '', 'action', lc $action_name ); my $request = POST( $url, Content_Type => 'form-data', Content => $request_body ); 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, no_color => $self->chrome->no_color, colors => $self->chrome->colors, quiet => $self->chrome->quiet }; return ( chrome => encode_json($chrome_args) ); } #------------------------------------------------------------------------------ sub _pinto_args { my ($self) = @_; my $pinto_args = { username => $self->username }; 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; # Currying in some extra args to the callback... my $callback = sub { $self->_response_callback( \$status, @_ ) }; my $response = $self->ua->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, $data ) = @_; # Each data chunk will be one or more lines ending with \n chomp $data; if ( not $data ) { # HACK: So that blank lines come out right # Need to find a better way to do this!! $self->chrome->show(''); return 1; } for my $line ( split m/\n/, $data, -1 ) { if ( $line eq $PINTO_SERVER_STATUS_OK ) { ${$status} = 1; } elsif ( $line eq $PINTO_SERVER_PROGRESS_MESSAGE ) { $self->chrome->show_progress; } elsif ( $line eq $PINTO_SERVER_NULL_MESSAGE ) { # Do nothing, discard message } elsif ( $line =~ m{^ \Q$PINTO_SERVER_DIAG_PREFIX\E (.*)}x ) { $self->chrome->diag($1); } else { $self->chrome->show($line); } } return 1; } #----------------------------------------------------------------------------- __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Remote::Action - Base class for remote Actions =head1 VERSION version 0.097 =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) 2013 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.097+dfsg.orig/lib/Pinto/Remote/Result.pm0000644000076500007650000000252312263155037016406 0ustar # ABSTRACT: The result from running a remote Action package Pinto::Remote::Result; use Moose; use MooseX::Types::Moose qw(Bool); #----------------------------------------------------------------------------- our $VERSION = '0.097'; # 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.097 =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) 2013 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.097+dfsg.orig/lib/Pinto/Remote/Action/0000755000076500007650000000000012264262436016010 5ustar pinto-0.097+dfsg.orig/lib/Pinto/Remote/Action/Add.pm0000644000076500007650000000472712263155037017045 0ustar # 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.097'; # 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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Remote::Action::Add - Add a distribution to a the repository =head1 VERSION version 0.097 =for Pod::Coverage BUILD =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Remote/Action/Install.pm0000644000076500007650000000666512263155037017766 0ustar # 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.097'; # 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_url => ( is => 'ro', isa => Str, builder => '_build_mirror_url', lazy => 1, ); #------------------------------------------------------------------------------ sub _build_mirror_url { my ($self) = @_; my $stack = $self->args->{stack}; my $stack_dir = defined $stack ? "/stacks/$stack" : ''; my $mirror_url = $self->root . $stack_dir; if ( defined $self->password ) { # Squirt username and password into URL my $credentials = $self->username . ':' . $self->password; $mirror_url =~ s{^ (https?://) }{$1$credentials\@}mx; } return $mirror_url; } #------------------------------------------------------------------------------ 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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Remote::Action::Install - Install packages from the repository =head1 VERSION version 0.097 =for Pod::Coverage BUILD =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Manual/0000755000076500007650000000000012264262436014555 5ustar pinto-0.097+dfsg.orig/lib/Pinto/Manual/Introduction.pod0000644000076500007650000001367012263155037017746 0ustar # 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.097 =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) 2013 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.097+dfsg.orig/lib/Pinto/Manual/Thanks.pod0000644000076500007650000001102412263155037016504 0ustar # 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.097 =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\xF6ll 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\xF8ren 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\xE9 Diaz Seng Al Newkirk Sawyer X Boris D\xE4ppen 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) 2013 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.097+dfsg.orig/lib/Pinto/Manual/QuickStart.pod0000644000076500007650000001160212263155037017350 0ustar # 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.097 =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 # A new repository with default stack named "dev" pinto -r /repo/dir init 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 "Foo::Bar" 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 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 =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 =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) 2013 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.097+dfsg.orig/lib/Pinto/Manual/Installing.pod0000644000076500007650000001300412263155037017360 0ustar # 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.097 =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) 2013 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.097+dfsg.orig/lib/Pinto/Manual/Tutorial.pod0000644000076500007650000004241712263155037017071 0ustar # ABSTRACT: A narrative introduction to Pinto package Pinto::Manual::Tutorial; #------------------------------------------------------------------------------ # VERSION #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Manual::Tutorial - A narrative introduction to Pinto =head1 VERSION version 0.097 =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 -r ~/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<-r> (or C<--root>) 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 -r ~/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 -r ~/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 -r ~/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 -r ~/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 -r ~/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 URL 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 look in other repositories for missing prerequisites. Usually, you only want to install things 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 URL 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 -r ~/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 -r ~/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 -r ~/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 -r ~/repo pull --stack uri_upgrade URI~1.62 Now lets compare the C and C stacks using the L command: $> pinto -r ~/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 -r ~/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 URL. 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 -r ~/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 -r ~/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 -r ~/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 upgraded until you are sure that the new release includes your patch or the author has fixed the bug by other means. $> pinto -r ~/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 -r ~/repo copy master trial But before you can upgrade URI on the C stack, you'll have to unpin it there: $> pinto -r ~/repo unpin --stack trial URI Now you can proceed to upgrade URI on the stack and try building C like this: $> pinto -r ~/repo pull --stack trial URI~1.62 $> pinto -r ~/repo install --stack trial My::App If all goes well, remove the pin from the C stack and pull your latest version of URI back to it. $> pinto -r ~/repo unpin URI $> pinto -r ~/repo pull URI~1.62 =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 -r ~/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 command) =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Action.pm0000644000076500007650000000403712263155037015114 0ustar # 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.097'; # 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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Action - Base class for all Actions =head1 VERSION version 0.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Initializer.pm0000644000076500007650000000744312263155037016166 0ustar # 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.097'; # VERSION #------------------------------------------------------------------------------ sub init { my ( $self, %args ) = @_; die "Must specify a root\n" if not $args{root}; $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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Initializer - Initializes a new Pinto repository =head1 VERSION version 0.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Migrator.pm0000644000076500007650000000410612263155037015460 0ustar # 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.097'; # 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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Migrator - Migrate an existing repository to a new version =head1 VERSION version 0.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Globals.pm0000644000076500007650000000206512263155037015261 0ustar # ABSTRACT: Global variables used across the Pinto utilities package Pinto::Globals; use strict; use warnings; #------------------------------------------------------------------------------ our $VERSION = '0.097'; # 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; #------------------------------------------------------------------------------ 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.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/IndexWriter.pm0000644000076500007650000001113012263155037016133 0ustar # 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 Path::Class qw(file); use HTTP::Date qw(time2str); use Pinto::Types qw(File); use Pinto::Util qw(debug throw); #------------------------------------------------------------------------------ our $VERSION = '0.097'; # 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 $url = '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: $url 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 @records = sort { $a->[0] cmp $b->[0] } $rs->cursor->all; return @records; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::IndexWriter - Write records to an 02packages.details.txt file =head1 VERSION version 0.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/DistributionSpec.pm0000644000076500007650000000627412263155037017176 0ustar # ABSTRACT: Specifies a distribution by author and path fragments package Pinto::DistributionSpec; use Moose; use MooseX::MarkAsMethods ( autoclean => 1 ); use MooseX::Types::Moose qw(ArrayRef Str); use Pinto::Types qw(AuthorID); use Pinto::Util qw(throw); use overload ( '""' => 'to_string' ); #------------------------------------------------------------------------------ our $VERSION = '0.097'; # 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 spec: $args[0]" if not( $author and $archive ); @args = ( author => $author, subdirs => $subdirs, archive => $archive ); } return $class->$orig(@args); }; #------------------------------------------------------------------------------ sub path { my ($self) = @_; my $author = $self->author; my @subdirs = @{ $self->subdirs }; my $archive = $self->archive; return join '/', substr( $author, 0, 1 ), substr( $author, 0, 2 ), $author, @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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::DistributionSpec - Specifies a distribution by author and path fragments =head1 VERSION version 0.097 =head1 METHODS =head2 path() Returns the canonical string form of this DistributionSpec, which is suitable for constructing a URI. =head2 to_string This method is called when the DistributionSpec is evaluated in string context. Returns the same result as the C method. =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Result.pm0000644000076500007650000000613512263155037015156 0ustar # 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.097'; # 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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Result - The result from running an Action =head1 VERSION version 0.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/IndexCache.pm0000644000076500007650000000515612263155037015675 0ustar # ABSTRACT: Manages indexes files from upstream repositories package Pinto::IndexCache; use Moose; use MooseX::StrictConstructor; use MooseX::MarkAsMethods ( autoclean => 1 ); use Package::Locator; #------------------------------------------------------------------------------- our $VERSION = '0.097'; # VERSION #------------------------------------------------------------------------------- has repo => ( is => 'ro', isa => 'Pinto::Repository', weak_ref => 1, required => 1, ); has locator => ( is => 'ro', isa => 'Package::Locator', handles => [qw(clear_cache)], builder => '_build_locator', lazy => 1, ); #------------------------------------------------------------------------------- sub _build_locator { my ($self) = @_; my @urls = $self->repo->config->sources_list; my $cache_dir = $self->repo->config->cache_dir; my $locator = Package::Locator->new( repository_urls => \@urls, cache_dir => $cache_dir ); return $locator; } #------------------------------------------------------------------------------- sub locate { my ( $self, @args ) = @_; return $self->locator->locate(@args); } #------------------------------------------------------------------------------- sub contents { my ($self) = @_; my %seen; for my $index ( $self->locator->indexes() ) { for my $dist ( values %{ $index->distributions() } ) { next if exists $seen{ $dist->{path} }; $dist->{packages} ||= []; # Prevent possible undef delete $_->{distribution} for @{ $dist->{packages} }; $seen{ $dist->{path} } = $dist; } } return @seen{ sort keys %seen }; } #------------------------------------------------------------------------------- __PACKAGE__->meta->make_immutable(); #------------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::IndexCache - Manages indexes files from upstream repositories =head1 VERSION version 0.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Schema.pm0000644000076500007650000000761012263155037015077 0ustar 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.097'; # 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.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Util.pm0000644000076500007650000004047712263155037014624 0ustar # ABSTRACT: Static utility functions for Pinto package Pinto::Util; use strict; use warnings; use version; use base qw(Exporter); use Carp; use DateTime; 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); #------------------------------------------------------------------------------- our $VERSION = '0.097'; # VERSION #------------------------------------------------------------------------------- Readonly our @EXPORT_OK => qw( author_dir body_text current_author_id current_utc_time current_time_offset current_username debug decamelize indent_text interpolate is_blank is_not_blank is_interactive is_remote_repo is_system_prop isa_perl itis md5 mksymlink mtime parse_dist_path mask_url_passwords sha256 title_text throw trim_text truncate_text user_colors uuid whine ); Readonly our %EXPORT_TAGS => ( all => \@EXPORT_OK ); #------------------------------------------------------------------------------- sub throw { my ($error) = @_; # Rethrowing... die $error if itis( $error, 'Pinto::Exception' ); ## no critic (Carping) 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_url) = @_; return $path_or_url =~ 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_colors { my $colors = $ENV{PINTO_COLORS} || $ENV{PINTO_COLOURS}; return $PINTO_DEFAULT_COLORS if not $colors; return [ split m/\s* , \s*/x, $colors ]; } #------------------------------------------------------------------------------- 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_url_passwords { my ($url) = @_; $url =~ s{ (https?://[^:/@]+ :) [^@/]+@}{$1*password*@}gx; return $url; } #------------------------------------------------------------------------------- sub is_remote_repo { my ($url) = @_; return if not $url; return $url =~ m{^https?://}x; } #------------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::Util - Static utility functions for Pinto =head1 VERSION version 0.097 =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 URL to a distribution in a CPAN repository, or the URL 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_url ) Return true if C<$path_or_url> 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_colors() Returns a reference to an array containing the names of the colors pinto can use. This can be influenced by setting the C or C environment variables. =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_url_passwords($string) Masks the parts the string that look like a password embedded in an http or https URL. For example, C would return C =head2 is_remote_repo { Returns true if the argument looks like a URL to a remote repository =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/ArchiveUnpacker.pm0000644000076500007650000000502712263155037016751 0ustar # 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.097'; # 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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::ArchiveUnpacker - Unpack an archive into a temporary directory =head1 VERSION version 0.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Locker.pm0000644000076500007650000000741012263155037015114 0ustar # 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); use Pinto::Types qw(File); #----------------------------------------------------------------------------- our $VERSION = '0.097'; # VERSION #----------------------------------------------------------------------------- our $LOCKFILE_TIMEOUT = $ENV{PINTO_LOCKFILE_TIMEOUT} || 50; # 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; my $lock = File::NFSLock->new( $lock_file, $lock_type, $LOCKFILE_TIMEOUT ) or throw 'The repository is currently in use -- please try again later'; 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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn NFS =head1 NAME Pinto::Locker - Manage locks to synchronize concurrent operations =head1 VERSION version 0.097 =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) 2013 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.097+dfsg.orig/lib/Pinto/Constants.pm0000644000076500007650000000751212263155037015654 0ustar # ABSTRACT: Constants used across the Pinto utilities package Pinto::Constants; use strict; use warnings; use Readonly; use base 'Exporter'; #------------------------------------------------------------------------------ our $VERSION = '0.097'; # VERSION #------------------------------------------------------------------------------ Readonly our @EXPORT_OK => qw( $PINTO_SERVER_DEFAULT_PORT $PINTO_SERVER_DEFAULT_HOST $PINTO_SERVER_DEFAULT_ROOT $PINTO_SERVER_STATUS_OK $PINTO_SERVER_DIAG_PREFIX $PINTO_SERVER_NULL_MESSAGE $PINTO_SERVER_PROGRESS_MESSAGE $PINTO_DEFAULT_COLORS $PINTO_COLOR_0 $PINTO_COLOR_1 $PINTO_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 ); Readonly our %EXPORT_TAGS => ( all => \@EXPORT_OK, color => [ grep {m/COLOR/x} @EXPORT_OK ], server => [ grep {m/SERVER/x} @EXPORT_OK ], regex => [ grep {m/REGEX/x} @EXPORT_OK ], lock => [ grep {m/LOCK/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_SERVER_DIAG_PREFIX => '## '; Readonly our $PINTO_SERVER_STATUS_OK => "${PINTO_SERVER_DIAG_PREFIX}Status: ok"; Readonly our $PINTO_SERVER_NULL_MESSAGE => "${PINTO_SERVER_DIAG_PREFIX}-- ##"; Readonly our $PINTO_SERVER_PROGRESS_MESSAGE => "${PINTO_SERVER_DIAG_PREFIX}. ##"; #------------------------------------------------------------------------------ Readonly our $PINTO_DEFAULT_COLORS => [qw(green yellow red)]; Readonly our $PINTO_COLOR_0 => 0; Readonly our $PINTO_COLOR_1 => 1; Readonly our $PINTO_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'; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Constants - Constants used across the Pinto utilities =head1 VERSION version 0.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Remote.pm0000644000076500007650000001144312263155037015131 0ustar # 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 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.097'; # VERSION #------------------------------------------------------------------------------ with qw(Pinto::Role::Plated); #------------------------------------------------------------------------------ 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], ); has ua => ( is => 'ro', isa => 'LWP::UserAgent', default => sub { LWP::UserAgent->new( agent => $_[0]->ua_name, env_proxy => 1 ) }, lazy => 1, ); has ua_name => ( is => 'ro', isa => Str, default => sub { sprintf '%s/%s', ref $_[0], $_[0]->VERSION || '??' }, lazy => 1, ); #------------------------------------------------------------------------------ around BUILDARGS => sub { my $orig = shift; my $class = shift; my $args = $class->$orig(@_); # Normalize the root $args->{root} = 'http://' . $args->{root} if defined $args->{root} && $args->{root} !~ m{^ https?:// }mx; $args->{root} = $args->{root} . ':' . $PINTO_SERVER_DEFAULT_PORT if defined $args->{root} && $args->{root} !~ m{ :\d+ $}mx; # Grrr. Gotta avoid passing undefs to Moose my @chrome_attrs = qw(verbose quiet no_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 ) = @_; my $action_args = ( @args == 1 and ref $args[0] eq 'HASH' ) ? $args[0] : {@args}; 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, ua => $self->ua ); return $action->execute; } #------------------------------------------------------------------------------ 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.097 =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 URL. =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) 2013 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.097+dfsg.orig/lib/Pinto/Database.pm0000644000076500007650000002022312263155037015376 0ustar # 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.097'; # 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.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Server/0000755000076500007650000000000012264262436014606 5ustar pinto-0.097+dfsg.orig/lib/Pinto/Server/Responder/0000755000076500007650000000000012264262436016547 5ustar pinto-0.097+dfsg.orig/lib/Pinto/Server/Responder/Action.pm0000644000076500007650000001227412263155037020325 0ustar # 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 Pinto; use Pinto::Result; use Pinto::Chrome::Net; use Pinto::Constants qw(:server); #------------------------------------------------------------------------------- our $VERSION = '0.097'; # VERSION #------------------------------------------------------------------------------- extends qw(Pinto::Server::Responder); #------------------------------------------------------------------------------- sub respond { my ($self) = @_; # 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 { $response = $self->parent_proc( $pipe, shift ) } error { croak "Failed to fork: $!" }; }; return $response; } #------------------------------------------------------------------------------- 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_SERVER_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->( [ 200, $headers ] ); my $socket = $self->request->env->{'psgix.io'}; my $nullmsg = $PINTO_SERVER_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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Server::Responder::Action - Responder for action requests =head1 VERSION version 0.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Server/Responder/File.pm0000644000076500007650000000624012263155037017763 0ustar # ABSTRACT: Responder for static files package Pinto::Server::Responder::File; use Moose; use Plack::Response; use Plack::MIME; use HTTP::Date (); #------------------------------------------------------------------------------- our $VERSION = '0.097'; # 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); my @stat = stat($file); unless ( -f _ ) { my $body = "File $file not found"; my $headers = [ 'Content-Type' => 'text/plain', 'Content-Length' => length($body) ]; return [ 404, $headers, [$body] ]; } 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; } #------------------------------------------------------------------------------- __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Server::Responder::File - Responder for static files =head1 VERSION version 0.097 =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) 2013 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.097+dfsg.orig/lib/Pinto/Server/Router.pm0000644000076500007650000000532612263155037016427 0ustar # ABSTRACT: Routes server requests package Pinto::Server::Router; use Moose; use Scalar::Util; use Plack::Request; use Router::Simple; #------------------------------------------------------------------------------- our $VERSION = '0.097'; # 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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn responder =head1 NAME Pinto::Server::Router - Routes server requests =head1 VERSION version 0.097 =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) 2013 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.097+dfsg.orig/lib/Pinto/Server/Responder.pm0000644000076500007650000000331312263155037017102 0ustar # ABSTRACT: Base class for responders package Pinto::Server::Responder; use Moose; use Carp; use Pinto::Types qw(Dir); #------------------------------------------------------------------------------- our $VERSION = '0.097'; # 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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn responders =head1 NAME Pinto::Server::Responder - Base class for responders =head1 VERSION version 0.097 =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) 2013 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.097+dfsg.orig/lib/Pinto/PackageExtractor.pm0000644000076500007650000001504712263155037017131 0ustar # ABSTRACT: Extract packages provided/required by a distribution archive package Pinto::PackageExtractor; use Moose; use MooseX::StrictConstructor; use MooseX::Types::Moose qw(HashRef Bool); use MooseX::MarkAsMethods ( autoclean => 1 ); use Try::Tiny; use Dist::Metadata; use Path::Class qw(dir); use Archive::Extract; use Pinto::Types qw(File Dir); use Pinto::Util qw(debug throw whine); use Pinto::ArchiveUnpacker; #----------------------------------------------------------------------------- our $VERSION = '0.097'; # 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; debug "Extracting packages provided by archive $archive"; 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 $archive: $_"; }; my @provides; for my $pkg_name ( sort keys %{$mod_info} ) { my $info = $mod_info->{$pkg_name}; my $pkg_ver = version->parse( $info->{version} ); debug "Archive $archive provides: $pkg_name-$pkg_ver"; push @provides, { name => $pkg_name, version => $pkg_ver }; } @provides = $self->__apply_workarounds if @provides == 0; whine sprintf "%s contains no packages and will not be indexed", $archive->basename 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} ) { my $prereqs_for_phase = $prereqs_meta->{$phase} || {}; my $required_prereqs = $prereqs_for_phase->{requires} || {}; for my $pkg_name ( sort keys %{$required_prereqs} ) { my $pkg_ver = version->parse( $required_prereqs->{$pkg_name} ); debug "Archive $archive requires ($phase): $pkg_name-$pkg_ver"; my $struct = { phase => $phase, name => $pkg_name, version => $pkg_ver }; push @prereqs, $struct; } } 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; } #----------------------------------------------------------------------------- # HACK: The common-sense and FCGI distributions generate the .pm file at build # time. It relies on an unusual feature of PAUSE that scans the __DATA__ # section of .PM files for potential packages. Module::Metdata doesn't have # that feature, so to us, it appears that these distributions contain no packages. # I've asked the authors to use the "provides" field of the META file so # that other tools can discover the packages in the distribution, but then have # not done so. So we work around it by just assuming the distribution contains a # package named "common::sense" or "FCGI". sub __apply_workarounds { my ($self) = @_; return $self->__common_sense_workaround if $self->archive->basename =~ m/^ common-sense /x; return $self->__fcgi_workaround if $self->archive->basename =~ m/^ FCGI-\d /x; return; } #----------------------------------------------------------------------------- # TODO: Generalize both of these workaround methods into a single method that # just guesses the package name and version based on the distribution name. sub __common_sense_workaround { my ($self) = @_; my ($version) = ( $self->archive->basename =~ m/common-sense- ([\d_.]+) \.tar\.gz/x ); return { name => 'common::sense', version => version->parse($version) }; } #----------------------------------------------------------------------------- # TODO: Generalize both of these workaround methods into a single method that # just guesses the package name and version based on the distribution name. sub __fcgi_workaround { my ($self) = @_; my ($version) = ( $self->archive->basename =~ m/FCGI- ([\d_.]+) \.tar\.gz/x ); return { name => 'FCGI', 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.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/ModlistWriter.pm0000644000076500007650000000502312263155037016503 0ustar # 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.097'; # 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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::ModlistWriter - Generates a stub 03modlist.data.gz file =head1 VERSION version 0.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Chrome.pm0000644000076500007650000000600212263155037015106 0ustar # 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.097'; # 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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Chrome - Base class for interactive interfaces =head1 VERSION version 0.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Manual.pod0000644000076500007650000000342612263155037015263 0ustar # 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.097 =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) 2013 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.097+dfsg.orig/lib/Pinto/PrerequisiteWalker.pm0000644000076500007650000000516212263155037017526 0ustar # 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.097'; # 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.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Chrome/0000755000076500007650000000000012264262436014555 5ustar pinto-0.097+dfsg.orig/lib/Pinto/Chrome/Term.pm0000644000076500007650000001453312263155037016025 0ustar # 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 Term::EditorEdit; use File::Which qw(which); use Pinto::Types qw(Io ANSIColorSet); use Pinto::Util qw(user_colors itis throw is_interactive); #----------------------------------------------------------------------------- our $VERSION = '0.097'; # VERSION #----------------------------------------------------------------------------- extends qw( Pinto::Chrome ); #----------------------------------------------------------------------------- has no_color => ( is => 'ro', isa => Bool, default => sub { !!$ENV{PINTO_NO_COLOR} || 0 }, ); has colors => ( is => 'ro', isa => ANSIColorSet, default => sub { user_colors() }, 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, ); #----------------------------------------------------------------------------- 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; open my $pager_fh, q<|->, $pager or throw "Failed to open pipe to pager $pager: $!"; return bless $pager_fh, 'IO::Handle'; # HACK! } #------------------------------------------------------------------------------ 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 ||= {}; $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 $!; } #----------------------------------------------------------------------------- sub progress_done { my ($self) = @_; 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 Term::EditorEdit->edit( document => $document ); } #----------------------------------------------------------------------------- sub colorize { my ( $self, $string, $color_number ) = @_; return '' if not $string; return $string if not defined $color_number; return $string if $self->no_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->colors->[$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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Chrome::Term - Interface for terminal-based interaction =head1 VERSION version 0.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Chrome/Net.pm0000644000076500007650000000553712263155037015650 0ustar # 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(:server); #----------------------------------------------------------------------------- our $VERSION = '0.097'; # 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_SERVER_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_SERVER_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.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Config.pm0000644000076500007650000001352512263155037015106 0ustar # 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::Types qw(Dir File Username PerlVersion); use Pinto::Util qw(current_username current_time_offset); #------------------------------------------------------------------------------ our $VERSION = '0.097'; # 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 => 'http://cpan.perl.org http://backpan.perl.org', documentation => 'URLs 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, ); #------------------------------------------------------------------------------ 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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Config - Internal configuration for a Pinto repository =head1 VERSION version 0.097 =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) 2013 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.097+dfsg.orig/lib/Pinto/Action/0000755000076500007650000000000012264262436014555 5ustar pinto-0.097+dfsg.orig/lib/Pinto/Action/Pin.pm0000644000076500007650000000463012263155037015641 0ustar # 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(SpecList); #------------------------------------------------------------------------------ our $VERSION = '0.097'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ has targets => ( isa => SpecList, traits => [qw(Array)], handles => { targets => 'elements' }, required => 1, coerce => 1, ); #------------------------------------------------------------------------------ with qw( Pinto::Role::Committable ); #------------------------------------------------------------------------------ sub execute { my ($self) = @_; my $stack = $self->stack; my @dists = map { $self->_pin( $_, $stack ) } $self->targets; return @dists; } #------------------------------------------------------------------------------ sub _pin { my ( $self, $target, $stack ) = @_; my $dist = $stack->get_distribution( spec => $target ); throw "$target is not registered on stack $stack" if not defined $dist; $self->notice("Pinning distribution $dist to stack $stack"); my $did_pin = $dist->pin( stack => $stack ); $self->warning("Distribution $dist is already pinned to stack $stack") unless $did_pin; return $did_pin ? $dist : (); } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Action::Pin - Force a package to stay in a stack =head1 VERSION version 0.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Action/Stacks.pm0000644000076500007650000000434512263155037016346 0ustar # 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.097'; # 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_COLOR_0 : $stack->is_locked ? $PINTO_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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Action::Stacks - List known stacks in the repository =head1 VERSION version 0.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Action/Add.pm0000644000076500007650000001250212263155037015600 0ustar # 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.097'; # 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; $self->stack->assert_not_locked; return $self; } #------------------------------------------------------------------------------ sub execute { my ($self) = @_; my ( @successful, @failed ); for my $archive ( $self->archives ) { try { $self->repo->svp_begin; my $dist = $self->_add($archive); push @successful, $dist ? $dist : (); } catch { throw $_ unless $self->no_fail; $self->result->failed( because => $_ ); $self->repo->svp_rollback; $self->error("$_"); $self->error("Archive $archive failed...continuing anyway"); push @failed, $archive; } finally { my ($error) = @_; $self->repo->svp_release unless $error; }; } $self->chrome->progress_done; return @successful; } #------------------------------------------------------------------------------ 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 ); $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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Action::Add - Add a local distribution into the repository =head1 VERSION version 0.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Action/Log.pm0000644000076500007650000000374612263155037015643 0ustar # ABSTRACT: Show revision log for a stack package Pinto::Action::Log; use Moose; use MooseX::StrictConstructor; use MooseX::Types::Moose qw(Str); use MooseX::MarkAsMethods ( autoclean => 1 ); use Pinto::RevisionWalker; use Pinto::Constants qw(:color); use Pinto::Types qw(StackName StackDefault); #------------------------------------------------------------------------------ our $VERSION = '0.097'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ has stack => ( is => 'ro', isa => StackName | StackDefault, default => undef, ); has format => ( is => 'ro', isa => Str, predicate => 'has_format', ); #------------------------------------------------------------------------------ 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_COLOR_1 } ); my $rest = $revision->to_string("Date: %u\nUser: %j\n\n%{4}G\n"); $self->show($rest); } 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.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Action/Verify.pm0000644000076500007650000000340212263155037016353 0ustar # 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.097'; # 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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Action::Verify - Report distributions that are missing =head1 VERSION version 0.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Action/Delete.pm0000644000076500007650000000410412263155037016311 0ustar # 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(DistSpecList); #------------------------------------------------------------------------------ our $VERSION = '0.097'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ with qw( Pinto::Role::Transactional ); #------------------------------------------------------------------------------ has targets => ( isa => DistSpecList, 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( spec => $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.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Action/Props.pm0000644000076500007650000000563012263155037016217 0ustar # 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.097'; # 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_COLOR_2 : undef; $self->show( $string, { color => $color } ); } return; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Action::Props - Show or change stack properties =head1 VERSION version 0.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Action/Diff.pm0000644000076500007650000000556012263155037015766 0ustar # ABSTRACT: Show the difference between two stacks package Pinto::Action::Diff; use Moose; use MooseX::StrictConstructor; use MooseX::MarkAsMethods ( autoclean => 1 ); use Pinto::Difference; use Pinto::Constants qw(:color); use Pinto::Types qw(StackName StackDefault StackObject RevisionID); use Pinto::Util qw(throw); #------------------------------------------------------------------------------ our $VERSION = '0.097'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ has left => ( is => 'ro', isa => StackName | StackDefault | StackObject | RevisionID, default => undef, ); has right => ( is => 'ro', isa => StackName | StackObject | RevisionID, required => 1, ); #------------------------------------------------------------------------------ sub execute { my ($self) = @_; my $error_message = qq{"%s" does not match any stack or revision}; my $left = $self->repo->get_stack( $self->left, ( nocroak => 1 ) ) || $self->repo->get_revision( $self->left ) || throw sprintf $error_message, $self->left; my $right = $self->repo->get_stack( $self->right, ( nocroak => 1 ) ) || $self->repo->get_revision( $self->right ) || throw sprintf $error_message, $self->right; my $diff = Pinto::Difference->new( left => $left, right => $right ); if ( $diff->is_different ) { $self->show( "--- $left", { color => $PINTO_COLOR_1 } ); $self->show( "+++ $right", { color => $PINTO_COLOR_1 } ); } for my $entry ( $diff->diffs ) { my $op = $entry->op; my $reg = $entry->registration; my $color = $op eq '+' ? $PINTO_COLOR_0 : $PINTO_COLOR_2; my $string = $op . $reg->to_string('[%F] %-40p %12v %a/%f'); $self->show( $string, { color => $color } ); } return $self->result; } #------------------------------------------------------------------------------- __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Action::Diff - Show the difference between two stacks =head1 VERSION version 0.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Action/Pull.pm0000644000076500007650000000563512263155037016035 0ustar # 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(SpecList); #------------------------------------------------------------------------------ our $VERSION = '0.097'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ has targets => ( isa => SpecList, 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 BUILD { my ($self) = @_; $self->stack->assert_not_locked; return $self; } #------------------------------------------------------------------------------ sub execute { my ($self) = @_; my ( @successful, @failed ); for my $target ( $self->targets ) { try { $self->repo->svp_begin; $self->notice( "Pulling target $target to stack " . $self->stack ); my $dist = $self->pull( target => $target ); push @successful, $dist ? $dist : (); } catch { throw $_ unless $self->no_fail; $self->result->failed( because => $_ ); $self->repo->svp_rollback; $self->error($_); $self->error("Target $target failed...continuing anyway"); push @failed, $target; } finally { my ($error) = @_; $self->repo->svp_release unless $error; }; } $self->chrome->progress_done; return @successful; } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Action::Pull - Pull upstream distributions into the repository =head1 VERSION version 0.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Action/Copy.pm0000644000076500007650000000510412263155037016022 0ustar # 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.097'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ with qw( Pinto::Role::Transactional ); #------------------------------------------------------------------------------ has from_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->from_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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Action::Copy - Create a new stack by copying another =head1 VERSION version 0.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Action/Default.pm0000644000076500007650000000423512263155037016500 0ustar # 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.097'; # 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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Action::Default - Set the default stack =head1 VERSION version 0.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Action/Rename.pm0000644000076500007650000000373212263155037016324 0ustar # 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.097'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ with qw( Pinto::Role::Transactional ); #------------------------------------------------------------------------------ has from_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->from_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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Action::Rename - Change the name of a stack =head1 VERSION version 0.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Action/Roots.pm0000644000076500007650000000461212263155037016221 0ustar # 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.097'; # 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 @dists = $stack->head->distributions->all; 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 ) { next if $is_prereq_dist{$dist}; for my $prereq ($dist->prerequisites) { my %args = (spec => $prereq->as_spec, cache => \%cache); next unless my $prereq_dist = $stack->get_distribution(%args); $is_prereq_dist{$prereq_dist}++; } } my @roots = grep { ! $is_prereq_dist{$_} } @dists; my @output = sort map { $_->to_string($self->format) } @roots; $self->show($_) for @output; 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.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Action/Clean.pm0000644000076500007650000000300712263155037016132 0ustar # ABSTRACT: Remove orphaned archives package Pinto::Action::Clean; use Moose; use MooseX::StrictConstructor; use MooseX::MarkAsMethods ( autoclean => 1 ); #------------------------------------------------------------------------------ our $VERSION = '0.097'; # 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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Action::Clean - Remove orphaned archives =head1 VERSION version 0.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Action/Unpin.pm0000644000076500007650000000465612263155037016214 0ustar # 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(SpecList); #------------------------------------------------------------------------------ our $VERSION = '0.097'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ has targets => ( isa => SpecList, traits => [qw(Array)], handles => { targets => 'elements' }, required => 1, coerce => 1, ); #------------------------------------------------------------------------------ with qw( Pinto::Role::Committable ); #------------------------------------------------------------------------------ sub execute { my ($self) = @_; my $stack = $self->stack; my @dists = map { $self->_unpin( $_, $stack ) } $self->targets; return @dists; } #------------------------------------------------------------------------------ sub _unpin { my ( $self, $target, $stack ) = @_; my $dist = $stack->get_distribution( spec => $target ); throw "$target is not registered on stack $stack" if not defined $dist; $self->notice("Unpinning distribution $dist from stack $stack"); my $did_unpin = $dist->unpin( stack => $stack ); $self->warning("Distribution $dist is not pinned to stack $stack") unless $did_unpin; return $did_unpin ? $dist : (); } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Action::Unpin - Loosen a package that has been pinned =head1 VERSION version 0.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Action/Register.pm0000644000076500007650000000446612263155037016706 0ustar # 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(DistSpecList); #------------------------------------------------------------------------------ our $VERSION = '0.097'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ has targets => ( isa => DistSpecList, 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; my @dists = map { $self->_register( $_, $stack ) } $self->targets; return @dists; } #------------------------------------------------------------------------------ sub _register { my ( $self, $spec, $stack ) = @_; my $dist = $self->repo->get_distribution( spec => $spec ); throw "Distribution $spec is not in the repository" if not defined $dist; $self->notice("Registering distribution $dist on stack $stack"); my $did_register = $dist->register( stack => $stack, pin => $self->pin ); return $did_register ? $dist : (); } #------------------------------------------------------------------------------ __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.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Action/Lock.pm0000644000076500007650000000375512263155037016012 0ustar # 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.097'; # 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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Action::Lock - Lock a stack to prevent future changes =head1 VERSION version 0.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Action/Unlock.pm0000644000076500007650000000376012263155037016351 0ustar # 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.097'; # 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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Action::Unlock - Unlock a stack to allow future changes =head1 VERSION version 0.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Action/Unregister.pm0000644000076500007650000000476712263155037017255 0ustar # 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(SpecList); #------------------------------------------------------------------------------ our $VERSION = '0.097'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ has targets => ( isa => SpecList, 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; my @dists = map { $self->_unregister( $_, $stack ) } $self->targets; return @dists; } #------------------------------------------------------------------------------ sub _unregister { my ( $self, $target, $stack ) = @_; my $dist = $stack->get_distribution( spec => $target ); throw "Target $target is not in the repository" if not defined $dist; $self->notice("Unregistering distribution $dist from stack $stack"); my $did_unregister = $dist->unregister( stack => $stack, force => $self->force ); return $did_unregister ? $dist : (); } #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Action::Unregister - Unregister packages from a stack =head1 VERSION version 0.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Action/Nop.pm0000644000076500007650000000321312263155037015643 0ustar # 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.097'; # 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.097 =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) 2013 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.097+dfsg.orig/lib/Pinto/Action/Statistics.pm0000644000076500007650000000354312263155037017247 0ustar # 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.097'; # 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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Action::Statistics - Report statistics about the repository =head1 VERSION version 0.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Action/Kill.pm0000644000076500007650000000345112263155037016006 0ustar # 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.097'; # 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.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Action/List.pm0000644000076500007650000000764312263155037016035 0ustar # 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(HashRef Str Bool); use Pinto::Constants qw(:color); use Pinto::Types qw(AuthorID StackName StackDefault StackObject); #------------------------------------------------------------------------------ our $VERSION = '0.097'; # VERSION #------------------------------------------------------------------------------ extends qw( Pinto::Action ); #------------------------------------------------------------------------------ has stack => ( is => 'ro', isa => StackName | StackDefault | StackObject, default => undef, ); has pinned => ( is => 'ro', isa => Bool, ); has author => ( is => 'ro', isa => AuthorID, coerce => 1, ); has packages => ( is => 'ro', isa => Str, ); has distributions => ( is => 'ro', isa => Str, ); has format => ( is => 'ro', isa => Str, default => '[%F] %-40p %12v %a/%f', lazy => 1, ); has where => ( is => 'ro', isa => HashRef, builder => '_build_where', lazy => 1, ); #------------------------------------------------------------------------------ sub _build_where { my ($self) = @_; my $where = {}; my $stack = $self->repo->get_stack( $self->stack ); $where = { revision => $stack->head->id }; if ( my $pkg_name = $self->packages ) { $where->{'package.name'} = { like => "%$pkg_name%" }; } if ( my $dist_name = $self->distributions ) { $where->{'distribution.archive'} = { like => "%$dist_name%" }; } if ( my $author = $self->author ) { $where->{'distribution.author'} = uc $author; } if ( my $pinned = $self->pinned ) { $where->{is_pinned} = 1; } return $where; } #------------------------------------------------------------------------------ sub execute { my ($self) = @_; my $where = $self->where; my $attrs = { prefetch => [qw(revision package distribution)] }; my $rs = $self->repo->db->schema->search_registration( $where, $attrs ); # I'm not sure why, but the results appear to come out sorted by # package name, even though I haven't specified how to order them. # This is fortunate, because adding and "ORDER BY" clause is slow. # I'm guessing it is because there is a UNIQUE INDEX on package_name # in the registration table. my $did_match = 0; while ( my $reg = $rs->next ) { $did_match++; my $string = $reg->to_string( $self->format ); my $color = $reg->is_pinned ? $PINTO_COLOR_1 : $reg->distribution->is_local ? $PINTO_COLOR_0 : undef; $self->show( $string, { color => $color } ); } # 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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Action::List - List the contents of a stack =head1 VERSION version 0.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Action/Install.pm0000644000076500007650000000476612263155037016533 0ustar # 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::SpecFactory; #------------------------------------------------------------------------------ our $VERSION = '0.097'; # 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_url => ( is => 'ro', isa => Str, builder => '_build_mirror_url', lazy => 1, ); #------------------------------------------------------------------------------ with qw( Pinto::Role::Committable Pinto::Role::Puller Pinto::Role::Installer); #------------------------------------------------------------------------------ sub _build_mirror_url { my ($self) = @_; my $stack = $self->stack; my $stack_dir = defined $stack ? "/stacks/$stack" : ''; my $mirror_url = 'file://' . $self->repo->root->absolute . $stack_dir; return $mirror_url; } #------------------------------------------------------------------------------ sub execute { my ($self) = @_; my @dists; if ( $self->do_pull ) { for my $target ( $self->targets ) { next if -d $target or -f $target; require Pinto::SpecFactory; $target = Pinto::SpecFactory->make_spec($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.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Action/New.pm0000644000076500007650000000500012263155037015634 0ustar # 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.097'; # 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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Action::New - Create a new empty stack =head1 VERSION version 0.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/SpecFactory.pm0000644000076500007650000000317512263155037016123 0ustar # ABSTRACT: Create Spec objects from strings package Pinto::SpecFactory; use strict; use warnings; use Class::Load; use Pinto::Util qw(throw); #------------------------------------------------------------------------------- our $VERSION = '0.097'; # VERSION #------------------------------------------------------------------------------- sub make_spec { my ( $class, $arg ) = @_; my $type = ref $arg; my $spec_class; if ( not $type ) { $spec_class = ( $arg =~ m{/}x ) ? 'Pinto::DistributionSpec' : 'Pinto::PackageSpec'; } elsif ( ref $arg eq 'HASH' ) { $spec_class = ( exists $arg->{author} ) ? 'Pinto::DistributionSpec' : 'Pinto::PackageSpec'; } else { throw "Don't know how to make spec from $arg"; } Class::Load::load_class($spec_class); return $spec_class->new($arg); } #------------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer =head1 NAME Pinto::SpecFactory - Create Spec objects from strings =head1 VERSION version 0.097 =head1 METHODS =head2 make_spec( $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) 2013 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.097+dfsg.orig/lib/Pinto/Statistics.pm0000644000076500007650000000636412263155037016036 0ustar # 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.097'; # 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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Statistics - Report statistics about a Pinto repository =head1 VERSION version 0.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Store.pm0000644000076500007650000000650412263155037014774 0ustar # 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.097'; # VERSION #------------------------------------------------------------------------------ with qw( Pinto::Role::FileFetcher ); #------------------------------------------------------------------------------ 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->fetch( from => $origin, to => $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.097 =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) 2013 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.097+dfsg.orig/lib/Pinto/Repository.pm0000644000076500007650000006077712263155037016073 0ustar # 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 Pinto::Store; use Pinto::Config; use Pinto::Locker; use Pinto::Database; use Pinto::IndexCache; use Pinto::PackageExtractor; use Pinto::PrerequisiteWalker; use Pinto::Util qw(itis debug mksymlink throw); use Pinto::Types qw(Dir); use version; #------------------------------------------------------------------------------- our $VERSION = '0.097'; # VERSION #------------------------------------------------------------------------------- Readonly our $REPOSITORY_VERSION => 1; #------------------------------------------------------------------------------- with qw( Pinto::Role::FileFetcher ); #------------------------------------------------------------------------------- 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 cache => ( is => 'ro', isa => 'Pinto::IndexCache', handles => [qw(locate)], clearer => '_clear_cache', default => sub { Pinto::IndexCache->new( repo => $_[0] ) }, 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, %opts ) = @_; return $stack if itis( $stack, 'Pinto::Schema::Result::Stack' ); return $self->get_default_stack if not $stack; my $where = { name => $stack }; my $got_stack = $self->db->schema->find_stack($where); throw "Stack $stack does not exist" unless $got_stack or $opts{nocroak}; return $got_stack; } #------------------------------------------------------------------------------- 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 ) = @_; 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 $spec = $args{spec}; my $pkg_name = $args{name}; my $dist_path = $args{path}; # Retrieve latest version of package that meets the spec if ($spec) { my $pkg_name = $spec->name; my $version = $spec->version; my @pkgs = $self->db->schema->search_package( { name => $pkg_name } )->with_distribution; my $latest = ( sort { $a <=> $b } @pkgs )[-1]; return $latest->version >= $spec->version ? $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 }; my @pkgs = $self->db->schema->search_package($where)->with_distribution; return @pkgs ? $pkgs[0] : (); } # Retrieve latest version of package in the entire repository elsif ($pkg_name) { my $where = { name => $pkg_name }; my @pkgs = $self->db->schema->search_package($where)->with_distribution; my $latest = ( sort { $a <=> $b } @pkgs )[-1]; return defined $latest ? $latest : (); } throw 'Invalid arguments'; } #------------------------------------------------------------------------------- sub get_distribution { my ( $self, %args ) = @_; # Retrieve a distribution by DistSpec or PackageSpec if ( my $spec = $args{spec} ) { if ( itis( $spec, 'Pinto::DistributionSpec' ) ) { my $author = $spec->author; my $archive = $spec->archive; return $self->db->schema->distribution_rs->with_packages->find_by_author_archive( $author, $archive ); } elsif ( itis( $spec, 'Pinto::PackageSpec' ) ) { my $pkg = $self->get_package( name => $spec->name ); return () if !defined($pkg) or $pkg->version < $spec->version; 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 $self->db->schema->distribution_rs->with_packages->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 $self->db->schema->distribution_rs->with_packages->find_by_author_archive( $author, $archive ); } throw 'Invalid arguments'; } #------------------------------------------------------------------------------- sub ups_distribution { my ( $self, %args ) = @_; my $spec = $args{spec}; my $cascade = $args{cascade} || 0; my $dist_url; if ( Pinto::Util::itis( $spec, 'Pinto::PackageSpec' ) ) { $dist_url = $self->locate( package => $spec->name, version => $spec->version, latest => $cascade ); } elsif ( Pinto::Util::itis( $spec, 'Pinto::DistributionSpec' ) ) { $dist_url = $self->locate( distribution => $spec->path ); } else { throw 'Invalid arguments'; } throw "Cannot find $spec anywhere" if not $dist_url; return $self->fetch_distribution( url => $dist_url ); } #------------------------------------------------------------------------------- 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 $url = $args{url}; my $path = $url->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->fetch_temporary( url => $url ); my $dist = $self->add_distribution( archive => $archive, author => $author, source => $url ); 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( $stk_name, nocroak => 1 ); 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( $copy_name, nocroak => 1 ) ) { 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( $new_name, nocroak => 1 )) { 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 is not writable by you" unless -r $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->cache->clear_cache; # Clears cache file from disk $self->_clear_cache; # Clears object from memory 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.097 =head1 ATTRIBUTES =head2 root =head2 config =head2 db =head2 store =head2 cache =head2 locker =head1 METHODS =head2 locate( package => ); =head2 locate( distribution => ); =head2 lock( $LOCK_TYPE ) =head2 unlock =head2 get_stack() =head2 get_stack( $stack_name ) =head2 get_stack( $stack_object ) =head2 get_stack( $stack_name_or_object, nocroak => 1 ) 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 the C option is true, than an exception will not be thrown and undef will be returned. 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_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_package( spec => $pkg_spec ) Returns a L representing the latest version of the package in the repository with the same name as the package spec B as the package spec. See L for the definition of a package spec. =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. =head2 get_distribution( spec => $pkg_spec ) Given a L, returns the L that contains the B in this repository with the same name as the spec B. Returns nothing if no such distribution is found. =head2 get_distribution( spec => $dist_spec ) Given a L, returns the L from this repository with the same author id and archive attributes as the spec. 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. =head2 ups_distribution( spec => $pkg_spec ) Given a L, locates the distribution that contains the latest version of the package across all upstream repositories with the same name as the spec, and the same or higher version as the spec. If such distribution is found, it is fetched and added to this repository. If it is not found, then an exception is thrown. =head2 ups_distribution( spec => $dist_spec ) Given a L, locates the first distribution in any upstream repository with the same author and archive as the spec. If such distribution is found, it is fetched and added to this repository. If it is not found, then an exception is thrown. =head2 add( archive => $path, author => $id ) =head2 add( archive => $path, author => $id, source => $url ) 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 URL 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( url => $url ) Fetches a distribution archive from a remote URL 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) 2013 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.097+dfsg.orig/lib/Pinto/RevisionWalker.pm0000644000076500007650000000373312263155037016645 0ustar # 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.097'; # 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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::RevisionWalker - Iterates through revision history =head1 VERSION version 0.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Exception.pm0000644000076500007650000000233512263155037015634 0ustar # ABSTRACT: Base class for Pinto exceptions package Pinto::Exception; use Moose; use MooseX::MarkAsMethods ( autoclean => 1 ); #------------------------------------------------------------------------------ our $VERSION = '0.097'; # VERSION #------------------------------------------------------------------------------ extends qw(Throwable::Error); #------------------------------------------------------------------------------ __PACKAGE__->meta->make_immutable; #------------------------------------------------------------------------------ 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Exception - Base class for Pinto exceptions =head1 VERSION version 0.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/Pinto/Types.pm0000644000076500007650000001673012263155037015006 0ustar # ABSTRACT: Moose types used within Pinto package Pinto::Types; use strict; use warnings; use version; use MooseX::Types -declare => [ qw( AuthorID Username Uri Dir File FileList Io Version StackName StackAll StackDefault PropertyName PkgSpec PkgSpecList StackObject DistSpec DistSpecList Spec SpecList RevisionID RevisionHead ANSIColor ANSIColorSet PerlVersion) ]; 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::SpecFactory; use Pinto::Constants qw(:all); #----------------------------------------------------------------------------- our $VERSION = '0.097'; # 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"}; 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 ANSIColorSet, 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' }; coerce Dir, from Str, via { Path::Class::Dir->new($_) }, from ArrayRef, via { Path::Class::Dir->new( @{$_} ) }; #----------------------------------------------------------------------------- class_type File, { class => 'Path::Class::File' }; coerce File, from Str, via { Path::Class::File->new($_) }, from ArrayRef, via { Path::Class::File->new( @{$_} ) }; #----------------------------------------------------------------------------- subtype FileList, as ArrayRef [File]; coerce FileList, from File, via { [$_] }, from Str, via { [ Path::Class::File->new($_) ] }, from ArrayRef [Str], via { [ map { Path::Class::File->new($_) } @$_ ]; }; #----------------------------------------------------------------------------- class_type PkgSpec, { class => 'Pinto::PackageSpec' }; coerce PkgSpec, from Str, via { Pinto::SpecFactory->make_spec($_) }, from HashRef, via { Pinto::SpecFactory->make_spec($_) }; #----------------------------------------------------------------------------- class_type DistSpec, { class => 'Pinto::DistributionSpec' }; coerce DistSpec, from Str, via { Pinto::SpecFactory->make_spec($_) }, from HashRef, via { Pinto::SpecFactory->make_spec($_) }; #----------------------------------------------------------------------------- subtype SpecList, as ArrayRef [ PkgSpec | DistSpec ]; ## no critic qw(ProhibitBitwiseOperators); coerce SpecList, from PkgSpec, via { [$_] }, from DistSpec, via { [$_] }, from Str, via { [ Pinto::SpecFactory->make_spec($_) ] }, from ArrayRef [Str], via { [ map { Pinto::SpecFactory->make_spec($_) } @$_ ]; }; #----------------------------------------------------------------------------- subtype DistSpecList, as ArrayRef [DistSpec]; ## no critic qw(ProhibitBitwiseOperators); coerce DistSpecList, from DistSpec, via { [$_] }, from Str, via { [ Pinto::DistributionSpec->new($_) ] }, from ArrayRef [Str], via { [ map { Pinto::DistributionSpec->new($_) } @$_ ]; }; #----------------------------------------------------------------------------- subtype PkgSpecList, as ArrayRef [PkgSpec]; ## no critic qw(ProhibitBitwiseOperators); coerce PkgSpecList, from DistSpec, via { [$_] }, from Str, via { [ Pinto::PackageSpec->new($_) ] }, from ArrayRef [Str], via { [ map { Pinto::PackageSpec->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; #----------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME Pinto::Types - Moose types used within Pinto =head1 VERSION version 0.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/App/0000755000076500007650000000000012264262436012767 5ustar pinto-0.097+dfsg.orig/lib/App/Pinto/0000755000076500007650000000000012264262436014060 5ustar pinto-0.097+dfsg.orig/lib/App/Pinto/Command.pm0000644000076500007650000000702312263155037015773 0ustar # 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.097'; # 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($args); my $result = $self->pinto->run( $self->action_name, %{$opts}, %args ); return $result->exit_status; } #----------------------------------------------------------------------------- sub process_args { my ( $self, $args ) = @_; my $attr_name = $self->args_attribute or return; if ( !@{$args} && $self->args_from_stdin ) { 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.097 =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/App/Pinto/Command/0000755000076500007650000000000012264262436015436 5ustar pinto-0.097+dfsg.orig/lib/App/Pinto/Command/statistics.pm0000644000076500007650000000353112263155037020165 0ustar # ABSTRACT: report statistics about the repository package App::Pinto::Command::statistics; use strict; use warnings; #----------------------------------------------------------------------------- use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.097'; # 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.097 =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) 2013 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.097+dfsg.orig/lib/App/Pinto/Command/unpin.pm0000644000076500007650000000747512263155037017137 0ustar package App::Pinto::Command::unpin; # ABSTRACT: free packages that have been pinned use strict; use warnings; #------------------------------------------------------------------------------ use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.097'; # VERSION #----------------------------------------------------------------------------- sub opt_spec { my ( $self, $app ) = @_; return ( [ '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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME App::Pinto::Command::unpin - free packages that have been pinned =head1 VERSION version 0.097 =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 --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 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) 2013 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.097+dfsg.orig/lib/App/Pinto/Command/help.pm0000644000076500007650000000373012263155037016724 0ustar # 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.097'; # 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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME App::Pinto::Command::help - display a command's help screen =head1 VERSION version 0.097 =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) 2013 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.097+dfsg.orig/lib/App/Pinto/Command/props.pm0000644000076500007650000000735712263155037017150 0ustar # 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.097'; # 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.097 =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. =back =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/App/Pinto/Command/pin.pm0000644000076500007650000000761112263155037016564 0ustar # 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.097'; # VERSION #----------------------------------------------------------------------------- sub opt_spec { my ( $self, $app ) = @_; return ( [ '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.097 =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 --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 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) 2013 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.097+dfsg.orig/lib/App/Pinto/Command/install.pm0000644000076500007650000001733312263155037017446 0ustar # ABSTRACT: install stuff from the repository package App::Pinto::Command::install; use strict; use warnings; #----------------------------------------------------------------------------- use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.097'; # 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' ], [ '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' => 'Use the index for this stack' ], ); } #------------------------------------------------------------------------------ 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; $self->usage_error('--message is only useful with --pull') if $opts->{message} and not $opts->{pull}; 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.097 =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, URLs, 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 !! This option only matters when the C<--do-pull> option is also used. 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 --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 --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. This only has effect when using the C<--pull> option. =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<--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 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 --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 --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. =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 URL of your Pinto repository. Each client has a slightly different interface for setting the URL. 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 add it to the URL. 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 URL to one of the stacks as shown above. =head1 COMPATIBILITY The C 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) 2013 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.097+dfsg.orig/lib/App/Pinto/Command/new.pm0000644000076500007650000000540412263155037016565 0ustar # ABSTRACT: create a new empty stack package App::Pinto::Command::new; use strict; use warnings; #----------------------------------------------------------------------------- use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.097'; # 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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME App::Pinto::Command::new - create a new empty stack =head1 VERSION version 0.097 =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) 2013 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.097+dfsg.orig/lib/App/Pinto/Command/pull.pm0000644000076500007650000001465412263155037016757 0ustar # ABSTRACT: pull archives from upstream repositories package App::Pinto::Command::pull; use strict; use warnings; #------------------------------------------------------------------------------ use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.097'; # VERSION #----------------------------------------------------------------------------- sub opt_spec { my ( $self, $app ) = @_; return ( [ 'cascade' => 'Always pick latest upstream package' ], [ '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' ], [ '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.097 =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 minimum version number) or a distributions. For example: Foo::Bar # Pulls any version of Foo::Bar Foo::Bar~1.2 # Pulls Foo::Bar 1.2 or higher SHAKESPEARE/King-Lear-1.2.tar.gz # Pulls a specific distribuion SHAKESPEARE/tragedies/Hamlet-4.2.tar.gz # Ditto, but from a subdirectory 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 --dry-run Go through all the motions, but do not actually commit any changes to the repository. 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 --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 --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 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 --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) 2013 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.097+dfsg.orig/lib/App/Pinto/Command/unlock.pm0000644000076500007650000000503112263155037017263 0ustar # ABSTRACT: mark a stack as writable package App::Pinto::Command::unlock; use strict; use warnings; #----------------------------------------------------------------------------- use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.097'; # 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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME App::Pinto::Command::unlock - mark a stack as writable =head1 VERSION version 0.097 =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) 2013 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.097+dfsg.orig/lib/App/Pinto/Command/init.pm0000644000076500007650000001220712263155037016736 0ustar # 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.097'; # 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@' => 'URL of upstream repository (repeatable)' ], [ 'target-perl-version|tpv=s' => 'Default perl version for new stacks' ], ); } #------------------------------------------------------------------------------ sub validate_args { my ( $self, $opts, $args ) = @_; $self->usage_error('Only one stack argument is allowed') if @{$args} > 1; $self->usage_error('Cannot use --description without specifying a stack') if $opts->{description} and not @{$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 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}; # Stuff the stack argument into the options hash (if it exists) $opts->{stack} = $args->[0] if $args->[0]; 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.097 =head1 SYNOPSIS pinto --root=REPOSITORY_ROOT init [OPTIONS] [STACK] =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 argument is the name of the initial stack. Stack names must be alphanumeric plus hyphens, underscores and periods, and are not case-sensitive. Defaults to C. =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=URL The URL of the upstream repository where distributions will be pulled from. This is usually the URL 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 URLs 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. =back =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/App/Pinto/Command/migrate.pm0000644000076500007650000000516512263155037017430 0ustar # 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.097'; # 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.097 =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) 2013 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.097+dfsg.orig/lib/App/Pinto/Command/stacks.pm0000644000076500007650000000475712263155037017276 0ustar # 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.097'; # 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.097 =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) 2013 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.097+dfsg.orig/lib/App/Pinto/Command/nop.pm0000644000076500007650000000377112263155037016575 0ustar # ABSTRACT: do nothing package App::Pinto::Command::nop; use strict; use warnings; #----------------------------------------------------------------------------- use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.097'; # 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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME App::Pinto::Command::nop - do nothing =head1 VERSION version 0.097 =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) 2013 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.097+dfsg.orig/lib/App/Pinto/Command/verify.pm0000644000076500007650000000330512263155037017276 0ustar package App::Pinto::Command::verify; # ABSTRACT: report archives that are missing use strict; use warnings; #----------------------------------------------------------------------------- use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.097'; # VERSION #----------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME App::Pinto::Command::verify - report archives that are missing =head1 VERSION version 0.097 =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) 2013 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.097+dfsg.orig/lib/App/Pinto/Command/thanks.pm0000644000076500007650000000331712263155037017265 0ustar # 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.097'; # 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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME App::Pinto::Command::thanks - show some gratitude =head1 VERSION version 0.097 =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) 2013 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.097+dfsg.orig/lib/App/Pinto/Command/diff.pm0000644000076500007650000000627612263155037016714 0ustar #ABSTRACT: show difference between two stacks package App::Pinto::Command::diff; use strict; use warnings; #----------------------------------------------------------------------------- use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.097'; # VERSION #------------------------------------------------------------------------------ sub command_names { return qw(diff) } #------------------------------------------------------------------------------ sub opt_spec { my ( $self, $app ) = @_; return (); } #------------------------------------------------------------------------------ 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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME App::Pinto::Command::diff - show difference between two stacks =head1 VERSION version 0.097 =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 None. =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) 2013 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.097+dfsg.orig/lib/App/Pinto/Command/delete.pm0000644000076500007650000000604512263155037017240 0ustar # ABSTRACT: permanently remove an archive package App::Pinto::Command::delete; use strict; use warnings; #------------------------------------------------------------------------------ use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.097'; # 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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME App::Pinto::Command::delete - permanently remove an archive =head1 VERSION version 0.097 =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 archives that you want to delete. 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 --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) 2013 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.097+dfsg.orig/lib/App/Pinto/Command/register.pm0000644000076500007650000000716012263155037017621 0ustar # ABSTRACT: put existing packages on a stack package App::Pinto::Command::register; use strict; use warnings; #------------------------------------------------------------------------------ use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.097'; # VERSION #----------------------------------------------------------------------------- sub opt_spec { my ( $self, $app ) = @_; return ( [ '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.097 =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 --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 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) 2013 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.097+dfsg.orig/lib/App/Pinto/Command/copy.pm0000644000076500007650000000644112263155037016750 0ustar # 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.097'; # 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 FROM_STACK and TO_STACK') if @{$args} != 2; return 1; } #------------------------------------------------------------------------------ sub execute { my ( $self, $opts, $args ) = @_; my %stacks = ( from_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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME App::Pinto::Command::copy - create a new stack by copying another =head1 VERSION version 0.097 =head1 SYNOPSIS pinto --root=REPOSITORY_ROOT copy [OPTIONS] FROM_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 FROM_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) 2013 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.097+dfsg.orig/lib/App/Pinto/Command/list.pm0000644000076500007650000001252112263155037016745 0ustar 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.097'; # VERSION #------------------------------------------------------------------------------ sub command_names { return qw( list ls ) } #------------------------------------------------------------------------------ sub opt_spec { my ( $self, $app ) = @_; return ( [ 'author|A=s' => 'Limit to distributions by author' ], [ '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]; 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.097 =head1 SYNOPSIS pinto --root=REPOSITORY_ROOT list [OPTIONS] =head1 DESCRIPTION This command lists the distributions and packages that are registered on a stack. 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 --author AUTHOR =item -A AUTHOR Limit the listing to records where the distribution author is AUTHOR. Note this is an exact match, not a pattern match. However, it is not case sensitive. =item --distributions PATTERN =item -D PATTERN Limit the listing to records where the distribution archive name matches C. Note that C is just a plain string, not a regular expression. The C will match if it appears anywhere in the distribution archive name. =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 %y Pin status: (!) = is pinned %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 %d Distribution name %D Distribution name-version %V Distribution version %u Distribution url %% 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 %-38n %12v %a/%f\n =item --packages PATTERN =item -P PATTERN Limit the listing to records where the package name matches C. Note that C is just a plain string, not a regular expression. The C will match if it appears anywhere in the package name. =item --pinned Limit the listing to records for packages that are pinned. =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. =back =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/lib/App/Pinto/Command/roots.pm0000644000076500007650000001216712263155037017146 0ustar 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.097'; # 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.097 =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 url %% 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 -f '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) 2013 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.097+dfsg.orig/lib/App/Pinto/Command/manual.pm0000644000076500007650000000516512263155037017255 0ustar # 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.097'; # 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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME App::Pinto::Command::manual - show the full manual for a command =head1 VERSION version 0.097 =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) 2013 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.097+dfsg.orig/lib/App/Pinto/Command/default.pm0000644000076500007650000000571412263155037017424 0ustar # ABSTRACT: mark the default stack package App::Pinto::Command::default; use strict; use warnings; #----------------------------------------------------------------------------- use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.097'; # 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.097 =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) 2013 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.097+dfsg.orig/lib/App/Pinto/Command/add.pm0000644000076500007650000001717412263155037016533 0ustar package App::Pinto::Command::add; # ABSTRACT: add local archives to the repository use strict; use warnings; #------------------------------------------------------------------------------ use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.097'; # VERSION #----------------------------------------------------------------------------- sub opt_spec { my ( $self, $app ) = @_; return ( [ 'author=s' => 'The ID of the archive author' ], [ 'cascade' => 'Always pick latest upstream package' ], [ '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' ], [ '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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME App::Pinto::Command::add - add local archives to the repository =head1 VERSION version 0.097 =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 --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 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 --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 --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 --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) 2013 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.097+dfsg.orig/lib/App/Pinto/Command/kill.pm0000644000076500007650000000512012263155037016722 0ustar # ABSTRACT: permanently delete a stack package App::Pinto::Command::kill; use strict; use warnings; #----------------------------------------------------------------------------- use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.097'; # 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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME App::Pinto::Command::kill - permanently delete a stack =head1 VERSION version 0.097 =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) 2013 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.097+dfsg.orig/lib/App/Pinto/Command/lock.pm0000644000076500007650000000471112263155037016724 0ustar # ABSTRACT: mark a stack as read-only package App::Pinto::Command::lock; use strict; use warnings; #----------------------------------------------------------------------------- use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.097'; # 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.097 =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) 2013 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.097+dfsg.orig/lib/App/Pinto/Command/log.pm0000644000076500007650000000525712263155037016563 0ustar # 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.097'; # VERSION #------------------------------------------------------------------------------ sub command_names { return qw(log history) } #------------------------------------------------------------------------------ sub opt_spec { my ( $self, $app ) = @_; return ( [ 'stack|s=s' => 'Show history for 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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME App::Pinto::Command::log - show the revision logs of a stack =head1 VERSION version 0.097 =head1 SYNOPSIS pinto --root=REPOSITORY_ROOT log [STACK] [OPTIONS] =head1 DESCRIPTION !! THIS COMMAND IS EXPERIMENTAL !! This command shows the commit logs for the stack. To see the precise changes in any particular commit, use the L command. =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 --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) 2013 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.097+dfsg.orig/lib/App/Pinto/Command/clean.pm0000644000076500007650000000347412263155037017063 0ustar # ABSTRACT: remove orphaned distribution archives package App::Pinto::Command::clean; use strict; use warnings; #------------------------------------------------------------------------------ use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.097'; # VERSION #----------------------------------------------------------------------------- 1; __END__ =pod =encoding UTF-8 =for :stopwords Jeffrey Ryan Thalhammer BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME App::Pinto::Command::clean - remove orphaned distribution archives =head1 VERSION version 0.097 =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) 2013 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.097+dfsg.orig/lib/App/Pinto/Command/rename.pm0000644000076500007650000000406512263155037017245 0ustar # ABSTRACT: change the name of a stack package App::Pinto::Command::rename; use strict; use warnings; #----------------------------------------------------------------------------- use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.097'; # VERSION #------------------------------------------------------------------------------ sub command_names { return qw(rename mv) } #------------------------------------------------------------------------------ sub validate_args { my ( $self, $opts, $args ) = @_; $self->usage_error('Must specify FROM_STACK and TO_STACK') if @{$args} != 2; $opts->{from_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.097 =head1 SYNOPSIS pinto --root=REPOSITORY_ROOT rename [OPTIONS] FROM_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) 2013 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.097+dfsg.orig/lib/App/Pinto/Command/unregister.pm0000644000076500007650000001062512263155037020164 0ustar # ABSTRACT: remove packages from a stack package App::Pinto::Command::unregister; use strict; use warnings; #------------------------------------------------------------------------------ use base 'App::Pinto::Command'; #------------------------------------------------------------------------------ our $VERSION = '0.097'; # VERSION #----------------------------------------------------------------------------- sub opt_spec { my ( $self, $app ) = @_; return ( [ '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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn =head1 NAME App::Pinto::Command::unregister - remove packages from a stack =head1 VERSION version 0.097 =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 --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 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) 2013 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.097+dfsg.orig/lib/App/Pinto.pm0000644000076500007650000000562112263155037014417 0ustar # 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.097'; # VERSION #------------------------------------------------------------------------------ sub global_opt_spec { return ( [ 'root|r=s' => 'Path to your repository root directory' ], [ 'no-color|no-colour' => 'Do not colorize any output' ], [ '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'); $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.097 =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) 2013 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.097+dfsg.orig/lib/Pinto.pm0000644000076500007650000002750112263155037013700 0ustar # 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.097'; # 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 no_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 @_ }; my $result = try { my $action = $self->create_action( $action_name => @action_args ); my $lock_type = $action->lock_type; $self->repo->assert_sanity_ok; $self->repo->assert_version_ok; $self->repo->lock($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 BenRifkah Fowler Jakob Voss Karen Etheridge Michael G. Bergsten-Buret Schwern Oleg Gashev Steffen Schwigon Tommy Stanton Wolfgang Kinkeldei Yanick Boris Champoux hesco popl Däppen Cory G Watson David Steinbrunner Glenn 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.097 =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 =over 4 =item * BenRifkah Bergsten-Buret =item * Boris Däppen =item * Cory G Watson =item * David Steinbrunner =item * Glenn Fowler =item * Jakob Voss =item * Jeffrey Ryan Thalhammer =item * Karen Etheridge =item * Michael G. Schwern =item * Oleg Gashev =item * Steffen Schwigon =item * Tommy Stanton =item * Wolfgang Kinkeldei =item * Yanick Champoux =item * hesco =item * popl =back =head1 AUTHOR Jeffrey Ryan Thalhammer =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2013 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.097+dfsg.orig/META.yml0000644000076500007650000003253612263155037012760 0ustar --- abstract: 'Curate a repository of Perl modules' author: - 'Jeffrey Ryan Thalhammer ' build_requires: Apache::Htpasswd: 0 Capture::Tiny: 0 English: 0 ExtUtils::MakeMaker: 0 File::Spec: 0 File::Spec::Functions: 0 File::Temp: 0 FindBin: 0 HTTP::Body: 0 HTTP::Request: 0 HTTP::Response: 0 HTTP::Server::PSGI: 0 IO::Handle: 0 IPC::Open3: 0 Module::Build: 0.4005 Module::Build::CleanInstall: 0.05 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 Test::TCP: 0 Test::Warn: 0 lib: 0 perl: 5.008 configure_requires: Module::Build: 0.4005 Module::Build::CleanInstall: 0.05 dynamic_config: 0 generated_by: 'Dist::Zilla version 5.008, CPAN::Meta::Converter version 2.133380' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Pinto no_index: directory: - t - xt - etc - t/lib - examples - corpus provides: App::Pinto: file: lib/App/Pinto.pm version: 0.097 App::Pinto::Command: file: lib/App/Pinto/Command.pm version: 0.097 App::Pinto::Command::add: file: lib/App/Pinto/Command/add.pm version: 0.097 App::Pinto::Command::clean: file: lib/App/Pinto/Command/clean.pm version: 0.097 App::Pinto::Command::copy: file: lib/App/Pinto/Command/copy.pm version: 0.097 App::Pinto::Command::default: file: lib/App/Pinto/Command/default.pm version: 0.097 App::Pinto::Command::delete: file: lib/App/Pinto/Command/delete.pm version: 0.097 App::Pinto::Command::diff: file: lib/App/Pinto/Command/diff.pm version: 0.097 App::Pinto::Command::help: file: lib/App/Pinto/Command/help.pm version: 0.097 App::Pinto::Command::init: file: lib/App/Pinto/Command/init.pm version: 0.097 App::Pinto::Command::install: file: lib/App/Pinto/Command/install.pm version: 0.097 App::Pinto::Command::kill: file: lib/App/Pinto/Command/kill.pm version: 0.097 App::Pinto::Command::list: file: lib/App/Pinto/Command/list.pm version: 0.097 App::Pinto::Command::lock: file: lib/App/Pinto/Command/lock.pm version: 0.097 App::Pinto::Command::log: file: lib/App/Pinto/Command/log.pm version: 0.097 App::Pinto::Command::manual: file: lib/App/Pinto/Command/manual.pm version: 0.097 App::Pinto::Command::migrate: file: lib/App/Pinto/Command/migrate.pm version: 0.097 App::Pinto::Command::new: file: lib/App/Pinto/Command/new.pm version: 0.097 App::Pinto::Command::nop: file: lib/App/Pinto/Command/nop.pm version: 0.097 App::Pinto::Command::pin: file: lib/App/Pinto/Command/pin.pm version: 0.097 App::Pinto::Command::props: file: lib/App/Pinto/Command/props.pm version: 0.097 App::Pinto::Command::pull: file: lib/App/Pinto/Command/pull.pm version: 0.097 App::Pinto::Command::register: file: lib/App/Pinto/Command/register.pm version: 0.097 App::Pinto::Command::rename: file: lib/App/Pinto/Command/rename.pm version: 0.097 App::Pinto::Command::roots: file: lib/App/Pinto/Command/roots.pm version: 0.097 App::Pinto::Command::stacks: file: lib/App/Pinto/Command/stacks.pm version: 0.097 App::Pinto::Command::statistics: file: lib/App/Pinto/Command/statistics.pm version: 0.097 App::Pinto::Command::thanks: file: lib/App/Pinto/Command/thanks.pm version: 0.097 App::Pinto::Command::unlock: file: lib/App/Pinto/Command/unlock.pm version: 0.097 App::Pinto::Command::unpin: file: lib/App/Pinto/Command/unpin.pm version: 0.097 App::Pinto::Command::unregister: file: lib/App/Pinto/Command/unregister.pm version: 0.097 App::Pinto::Command::verify: file: lib/App/Pinto/Command/verify.pm version: 0.097 Pinto: file: lib/Pinto.pm version: 0.097 Pinto::Action: file: lib/Pinto/Action.pm version: 0.097 Pinto::Action::Add: file: lib/Pinto/Action/Add.pm version: 0.097 Pinto::Action::Clean: file: lib/Pinto/Action/Clean.pm version: 0.097 Pinto::Action::Copy: file: lib/Pinto/Action/Copy.pm version: 0.097 Pinto::Action::Default: file: lib/Pinto/Action/Default.pm version: 0.097 Pinto::Action::Delete: file: lib/Pinto/Action/Delete.pm version: 0.097 Pinto::Action::Diff: file: lib/Pinto/Action/Diff.pm version: 0.097 Pinto::Action::Install: file: lib/Pinto/Action/Install.pm version: 0.097 Pinto::Action::Kill: file: lib/Pinto/Action/Kill.pm version: 0.097 Pinto::Action::List: file: lib/Pinto/Action/List.pm version: 0.097 Pinto::Action::Lock: file: lib/Pinto/Action/Lock.pm version: 0.097 Pinto::Action::Log: file: lib/Pinto/Action/Log.pm version: 0.097 Pinto::Action::New: file: lib/Pinto/Action/New.pm version: 0.097 Pinto::Action::Nop: file: lib/Pinto/Action/Nop.pm version: 0.097 Pinto::Action::Pin: file: lib/Pinto/Action/Pin.pm version: 0.097 Pinto::Action::Props: file: lib/Pinto/Action/Props.pm version: 0.097 Pinto::Action::Pull: file: lib/Pinto/Action/Pull.pm version: 0.097 Pinto::Action::Register: file: lib/Pinto/Action/Register.pm version: 0.097 Pinto::Action::Rename: file: lib/Pinto/Action/Rename.pm version: 0.097 Pinto::Action::Roots: file: lib/Pinto/Action/Roots.pm version: 0.097 Pinto::Action::Stacks: file: lib/Pinto/Action/Stacks.pm version: 0.097 Pinto::Action::Statistics: file: lib/Pinto/Action/Statistics.pm version: 0.097 Pinto::Action::Unlock: file: lib/Pinto/Action/Unlock.pm version: 0.097 Pinto::Action::Unpin: file: lib/Pinto/Action/Unpin.pm version: 0.097 Pinto::Action::Unregister: file: lib/Pinto/Action/Unregister.pm version: 0.097 Pinto::Action::Verify: file: lib/Pinto/Action/Verify.pm version: 0.097 Pinto::ArchiveUnpacker: file: lib/Pinto/ArchiveUnpacker.pm version: 0.097 Pinto::Chrome: file: lib/Pinto/Chrome.pm version: 0.097 Pinto::Chrome::Net: file: lib/Pinto/Chrome/Net.pm version: 0.097 Pinto::Chrome::Term: file: lib/Pinto/Chrome/Term.pm version: 0.097 Pinto::Config: file: lib/Pinto/Config.pm version: 0.097 Pinto::Constants: file: lib/Pinto/Constants.pm version: 0.097 Pinto::Database: file: lib/Pinto/Database.pm version: 0.097 Pinto::Difference: file: lib/Pinto/Difference.pm version: 0.097 Pinto::DifferenceEntry: file: lib/Pinto/Difference.pm version: 0.097 Pinto::DistributionSpec: file: lib/Pinto/DistributionSpec.pm version: 0.097 Pinto::Exception: file: lib/Pinto/Exception.pm version: 0.097 Pinto::Globals: file: lib/Pinto/Globals.pm version: 0.097 Pinto::IndexCache: file: lib/Pinto/IndexCache.pm version: 0.097 Pinto::IndexWriter: file: lib/Pinto/IndexWriter.pm version: 0.097 Pinto::Initializer: file: lib/Pinto/Initializer.pm version: 0.097 Pinto::Locker: file: lib/Pinto/Locker.pm version: 0.097 Pinto::Migrator: file: lib/Pinto/Migrator.pm version: 0.097 Pinto::ModlistWriter: file: lib/Pinto/ModlistWriter.pm version: 0.097 Pinto::PackageExtractor: file: lib/Pinto/PackageExtractor.pm version: 0.097 Pinto::PackageSpec: file: lib/Pinto/PackageSpec.pm version: 0.097 Pinto::PrerequisiteWalker: file: lib/Pinto/PrerequisiteWalker.pm version: 0.097 Pinto::Remote: file: lib/Pinto/Remote.pm version: 0.097 Pinto::Remote::Action: file: lib/Pinto/Remote/Action.pm version: 0.097 Pinto::Remote::Action::Add: file: lib/Pinto/Remote/Action/Add.pm version: 0.097 Pinto::Remote::Action::Install: file: lib/Pinto/Remote/Action/Install.pm version: 0.097 Pinto::Remote::Result: file: lib/Pinto/Remote/Result.pm version: 0.097 Pinto::Repository: file: lib/Pinto/Repository.pm version: 0.097 Pinto::Result: file: lib/Pinto/Result.pm version: 0.097 Pinto::RevisionWalker: file: lib/Pinto/RevisionWalker.pm version: 0.097 Pinto::Role::Committable: file: lib/Pinto/Role/Committable.pm version: 0.097 Pinto::Role::FileFetcher: file: lib/Pinto/Role/FileFetcher.pm version: 0.097 Pinto::Role::Installer: file: lib/Pinto/Role/Installer.pm version: 0.097 Pinto::Role::PauseConfig: file: lib/Pinto/Role/PauseConfig.pm version: 0.097 Pinto::Role::Plated: file: lib/Pinto/Role/Plated.pm version: 0.097 Pinto::Role::Puller: file: lib/Pinto/Role/Puller.pm version: 0.097 Pinto::Role::Schema::Result: file: lib/Pinto/Role/Schema/Result.pm version: 0.097 Pinto::Role::Transactional: file: lib/Pinto/Role/Transactional.pm version: 0.097 Pinto::Schema: file: lib/Pinto/Schema.pm version: 0.097 Pinto::Schema::Result::Ancestry: file: lib/Pinto/Schema/Result/Ancestry.pm version: 0.097 Pinto::Schema::Result::Distribution: file: lib/Pinto/Schema/Result/Distribution.pm version: 0.097 Pinto::Schema::Result::Package: file: lib/Pinto/Schema/Result/Package.pm version: 0.097 Pinto::Schema::Result::Prerequisite: file: lib/Pinto/Schema/Result/Prerequisite.pm version: 0.097 Pinto::Schema::Result::Registration: file: lib/Pinto/Schema/Result/Registration.pm version: 0.097 Pinto::Schema::Result::RegistrationChange: file: lib/Pinto/Schema/Result/RegistrationChange.pm version: 0.097 Pinto::Schema::Result::Revision: file: lib/Pinto/Schema/Result/Revision.pm version: 0.097 Pinto::Schema::Result::Stack: file: lib/Pinto/Schema/Result/Stack.pm version: 0.097 Pinto::Schema::ResultSet::Distribution: file: lib/Pinto/Schema/ResultSet/Distribution.pm version: 0.097 Pinto::Schema::ResultSet::Package: file: lib/Pinto/Schema/ResultSet/Package.pm version: 0.097 Pinto::Schema::ResultSet::Registration: file: lib/Pinto/Schema/ResultSet/Registration.pm version: 0.097 Pinto::Server: file: lib/Pinto/Server.pm version: 0.097 Pinto::Server::Responder: file: lib/Pinto/Server/Responder.pm version: 0.097 Pinto::Server::Responder::Action: file: lib/Pinto/Server/Responder/Action.pm version: 0.097 Pinto::Server::Responder::File: file: lib/Pinto/Server/Responder/File.pm version: 0.097 Pinto::Server::Router: file: lib/Pinto/Server/Router.pm version: 0.097 Pinto::SpecFactory: file: lib/Pinto/SpecFactory.pm version: 0.097 Pinto::Statistics: file: lib/Pinto/Statistics.pm version: 0.097 Pinto::Store: file: lib/Pinto/Store.pm version: 0.097 Pinto::Types: file: lib/Pinto/Types.pm version: 0.097 Pinto::Util: file: lib/Pinto/Util.pm version: 0.097 requires: 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 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.924 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 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: 3.03 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 Package::Locator: 0.010 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 Term::EditorEdit: 0 Throwable::Error: 0.200005 Try::Tiny: 0 URI: 0 UUID::Tiny: 0 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.097 x_contributors: - 'BenRifkah Bergsten-Buret ' - 'Boris Däppen ' - 'Cory G Watson ' - 'David Steinbrunner ' - 'Glenn Fowler ' - 'Jakob Voss ' - 'Jeffrey Ryan Thalhammer ' - 'Karen Etheridge ' - 'Michael G. Schwern ' - 'Oleg Gashev ' - 'Steffen Schwigon ' - 'Tommy Stanton ' - 'Wolfgang Kinkeldei ' - 'Yanick Champoux ' - 'hesco ' - 'popl ' pinto-0.097+dfsg.orig/dist.ini0000644000076500007650000001156412263155037013151 0ustar name = Pinto main_module = lib/Pinto.pm author = Jeffrey Ryan Thalhammer copyright_holder = Jeffrey Ryan Thalhammer copyright_year = 2013 license = Perl_5 version = 0.097 [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 / ConfigureRequires] Module::Build = 0.4005 ; for test_requires Module::Build::CleanInstall = 0.05 [Prereqs / BuildRequires] Module::Build = 0.4005 ; for test_requires Module::Build::CleanInstall = 0.05 [Prereqs / TestRequires] 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 Archive::Tar = 0 ; in case they don't have tar(1) Archive::Extract = 0.68 ; older versions generated some suprrious warnings Package::Locator = 0.010 ; respects proxy settings for the user agent Dist::Metadata = 0.924 ; mod_info() with checksums JSON::PP = 2.27103 ; wanted by Parse::CPAN::Meta Module::CoreList = 3.03 ; for modules in latest perl 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() ; 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) [ContributorsFromGit] ; build system [ExecDir] ; include 'bin/*' as executables [ShareDir] ; include 'share/' for File::ShareDir [ModuleBuild] ; create Build.PL mb_class = Pinto::Module::Build ; 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.097+dfsg.orig/META.json0000644000076500007650000005123012263155037013120 0ustar { "abstract" : "Curate a repository of Perl modules", "author" : [ "Jeffrey Ryan Thalhammer " ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 5.008, CPAN::Meta::Converter version 2.133380", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Pinto", "no_index" : { "directory" : [ "t", "xt", "etc", "t/lib", "examples", "corpus" ] }, "prereqs" : { "build" : { "requires" : { "Module::Build" : "0.4005", "Module::Build::CleanInstall" : "0.05" } }, "configure" : { "requires" : { "Module::Build" : "0.4005", "Module::Build::CleanInstall" : "0.05" } }, "develop" : { "requires" : { "Test::CPAN::Meta" : "0", "Test::Pod" : "1.41" } }, "runtime" : { "requires" : { "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", "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.924", "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", "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" : "3.03", "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", "Package::Locator" : "0.010", "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", "Term::EditorEdit" : "0", "Throwable::Error" : "0.200005", "Try::Tiny" : "0", "URI" : "0", "UUID::Tiny" : "0", "base" : "0", "overload" : "0", "perl" : "5.008", "strict" : "0", "utf8" : "0", "version" : "0", "warnings" : "0" } }, "test" : { "recommends" : { "CPAN::Meta" : "0", "CPAN::Meta::Requirements" : "0" }, "requires" : { "Apache::Htpasswd" : "0", "Capture::Tiny" : "0", "English" : "0", "ExtUtils::MakeMaker" : "0", "File::Spec" : "0", "File::Spec::Functions" : "0", "File::Temp" : "0", "FindBin" : "0", "HTTP::Body" : "0", "HTTP::Request" : "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", "Test::TCP" : "0", "Test::Warn" : "0", "lib" : "0", "perl" : "5.008" } } }, "provides" : { "App::Pinto" : { "file" : "lib/App/Pinto.pm", "version" : "0.097" }, "App::Pinto::Command" : { "file" : "lib/App/Pinto/Command.pm", "version" : "0.097" }, "App::Pinto::Command::add" : { "file" : "lib/App/Pinto/Command/add.pm", "version" : "0.097" }, "App::Pinto::Command::clean" : { "file" : "lib/App/Pinto/Command/clean.pm", "version" : "0.097" }, "App::Pinto::Command::copy" : { "file" : "lib/App/Pinto/Command/copy.pm", "version" : "0.097" }, "App::Pinto::Command::default" : { "file" : "lib/App/Pinto/Command/default.pm", "version" : "0.097" }, "App::Pinto::Command::delete" : { "file" : "lib/App/Pinto/Command/delete.pm", "version" : "0.097" }, "App::Pinto::Command::diff" : { "file" : "lib/App/Pinto/Command/diff.pm", "version" : "0.097" }, "App::Pinto::Command::help" : { "file" : "lib/App/Pinto/Command/help.pm", "version" : "0.097" }, "App::Pinto::Command::init" : { "file" : "lib/App/Pinto/Command/init.pm", "version" : "0.097" }, "App::Pinto::Command::install" : { "file" : "lib/App/Pinto/Command/install.pm", "version" : "0.097" }, "App::Pinto::Command::kill" : { "file" : "lib/App/Pinto/Command/kill.pm", "version" : "0.097" }, "App::Pinto::Command::list" : { "file" : "lib/App/Pinto/Command/list.pm", "version" : "0.097" }, "App::Pinto::Command::lock" : { "file" : "lib/App/Pinto/Command/lock.pm", "version" : "0.097" }, "App::Pinto::Command::log" : { "file" : "lib/App/Pinto/Command/log.pm", "version" : "0.097" }, "App::Pinto::Command::manual" : { "file" : "lib/App/Pinto/Command/manual.pm", "version" : "0.097" }, "App::Pinto::Command::migrate" : { "file" : "lib/App/Pinto/Command/migrate.pm", "version" : "0.097" }, "App::Pinto::Command::new" : { "file" : "lib/App/Pinto/Command/new.pm", "version" : "0.097" }, "App::Pinto::Command::nop" : { "file" : "lib/App/Pinto/Command/nop.pm", "version" : "0.097" }, "App::Pinto::Command::pin" : { "file" : "lib/App/Pinto/Command/pin.pm", "version" : "0.097" }, "App::Pinto::Command::props" : { "file" : "lib/App/Pinto/Command/props.pm", "version" : "0.097" }, "App::Pinto::Command::pull" : { "file" : "lib/App/Pinto/Command/pull.pm", "version" : "0.097" }, "App::Pinto::Command::register" : { "file" : "lib/App/Pinto/Command/register.pm", "version" : "0.097" }, "App::Pinto::Command::rename" : { "file" : "lib/App/Pinto/Command/rename.pm", "version" : "0.097" }, "App::Pinto::Command::roots" : { "file" : "lib/App/Pinto/Command/roots.pm", "version" : "0.097" }, "App::Pinto::Command::stacks" : { "file" : "lib/App/Pinto/Command/stacks.pm", "version" : "0.097" }, "App::Pinto::Command::statistics" : { "file" : "lib/App/Pinto/Command/statistics.pm", "version" : "0.097" }, "App::Pinto::Command::thanks" : { "file" : "lib/App/Pinto/Command/thanks.pm", "version" : "0.097" }, "App::Pinto::Command::unlock" : { "file" : "lib/App/Pinto/Command/unlock.pm", "version" : "0.097" }, "App::Pinto::Command::unpin" : { "file" : "lib/App/Pinto/Command/unpin.pm", "version" : "0.097" }, "App::Pinto::Command::unregister" : { "file" : "lib/App/Pinto/Command/unregister.pm", "version" : "0.097" }, "App::Pinto::Command::verify" : { "file" : "lib/App/Pinto/Command/verify.pm", "version" : "0.097" }, "Pinto" : { "file" : "lib/Pinto.pm", "version" : "0.097" }, "Pinto::Action" : { "file" : "lib/Pinto/Action.pm", "version" : "0.097" }, "Pinto::Action::Add" : { "file" : "lib/Pinto/Action/Add.pm", "version" : "0.097" }, "Pinto::Action::Clean" : { "file" : "lib/Pinto/Action/Clean.pm", "version" : "0.097" }, "Pinto::Action::Copy" : { "file" : "lib/Pinto/Action/Copy.pm", "version" : "0.097" }, "Pinto::Action::Default" : { "file" : "lib/Pinto/Action/Default.pm", "version" : "0.097" }, "Pinto::Action::Delete" : { "file" : "lib/Pinto/Action/Delete.pm", "version" : "0.097" }, "Pinto::Action::Diff" : { "file" : "lib/Pinto/Action/Diff.pm", "version" : "0.097" }, "Pinto::Action::Install" : { "file" : "lib/Pinto/Action/Install.pm", "version" : "0.097" }, "Pinto::Action::Kill" : { "file" : "lib/Pinto/Action/Kill.pm", "version" : "0.097" }, "Pinto::Action::List" : { "file" : "lib/Pinto/Action/List.pm", "version" : "0.097" }, "Pinto::Action::Lock" : { "file" : "lib/Pinto/Action/Lock.pm", "version" : "0.097" }, "Pinto::Action::Log" : { "file" : "lib/Pinto/Action/Log.pm", "version" : "0.097" }, "Pinto::Action::New" : { "file" : "lib/Pinto/Action/New.pm", "version" : "0.097" }, "Pinto::Action::Nop" : { "file" : "lib/Pinto/Action/Nop.pm", "version" : "0.097" }, "Pinto::Action::Pin" : { "file" : "lib/Pinto/Action/Pin.pm", "version" : "0.097" }, "Pinto::Action::Props" : { "file" : "lib/Pinto/Action/Props.pm", "version" : "0.097" }, "Pinto::Action::Pull" : { "file" : "lib/Pinto/Action/Pull.pm", "version" : "0.097" }, "Pinto::Action::Register" : { "file" : "lib/Pinto/Action/Register.pm", "version" : "0.097" }, "Pinto::Action::Rename" : { "file" : "lib/Pinto/Action/Rename.pm", "version" : "0.097" }, "Pinto::Action::Roots" : { "file" : "lib/Pinto/Action/Roots.pm", "version" : "0.097" }, "Pinto::Action::Stacks" : { "file" : "lib/Pinto/Action/Stacks.pm", "version" : "0.097" }, "Pinto::Action::Statistics" : { "file" : "lib/Pinto/Action/Statistics.pm", "version" : "0.097" }, "Pinto::Action::Unlock" : { "file" : "lib/Pinto/Action/Unlock.pm", "version" : "0.097" }, "Pinto::Action::Unpin" : { "file" : "lib/Pinto/Action/Unpin.pm", "version" : "0.097" }, "Pinto::Action::Unregister" : { "file" : "lib/Pinto/Action/Unregister.pm", "version" : "0.097" }, "Pinto::Action::Verify" : { "file" : "lib/Pinto/Action/Verify.pm", "version" : "0.097" }, "Pinto::ArchiveUnpacker" : { "file" : "lib/Pinto/ArchiveUnpacker.pm", "version" : "0.097" }, "Pinto::Chrome" : { "file" : "lib/Pinto/Chrome.pm", "version" : "0.097" }, "Pinto::Chrome::Net" : { "file" : "lib/Pinto/Chrome/Net.pm", "version" : "0.097" }, "Pinto::Chrome::Term" : { "file" : "lib/Pinto/Chrome/Term.pm", "version" : "0.097" }, "Pinto::Config" : { "file" : "lib/Pinto/Config.pm", "version" : "0.097" }, "Pinto::Constants" : { "file" : "lib/Pinto/Constants.pm", "version" : "0.097" }, "Pinto::Database" : { "file" : "lib/Pinto/Database.pm", "version" : "0.097" }, "Pinto::Difference" : { "file" : "lib/Pinto/Difference.pm", "version" : "0.097" }, "Pinto::DifferenceEntry" : { "file" : "lib/Pinto/Difference.pm", "version" : "0.097" }, "Pinto::DistributionSpec" : { "file" : "lib/Pinto/DistributionSpec.pm", "version" : "0.097" }, "Pinto::Exception" : { "file" : "lib/Pinto/Exception.pm", "version" : "0.097" }, "Pinto::Globals" : { "file" : "lib/Pinto/Globals.pm", "version" : "0.097" }, "Pinto::IndexCache" : { "file" : "lib/Pinto/IndexCache.pm", "version" : "0.097" }, "Pinto::IndexWriter" : { "file" : "lib/Pinto/IndexWriter.pm", "version" : "0.097" }, "Pinto::Initializer" : { "file" : "lib/Pinto/Initializer.pm", "version" : "0.097" }, "Pinto::Locker" : { "file" : "lib/Pinto/Locker.pm", "version" : "0.097" }, "Pinto::Migrator" : { "file" : "lib/Pinto/Migrator.pm", "version" : "0.097" }, "Pinto::ModlistWriter" : { "file" : "lib/Pinto/ModlistWriter.pm", "version" : "0.097" }, "Pinto::PackageExtractor" : { "file" : "lib/Pinto/PackageExtractor.pm", "version" : "0.097" }, "Pinto::PackageSpec" : { "file" : "lib/Pinto/PackageSpec.pm", "version" : "0.097" }, "Pinto::PrerequisiteWalker" : { "file" : "lib/Pinto/PrerequisiteWalker.pm", "version" : "0.097" }, "Pinto::Remote" : { "file" : "lib/Pinto/Remote.pm", "version" : "0.097" }, "Pinto::Remote::Action" : { "file" : "lib/Pinto/Remote/Action.pm", "version" : "0.097" }, "Pinto::Remote::Action::Add" : { "file" : "lib/Pinto/Remote/Action/Add.pm", "version" : "0.097" }, "Pinto::Remote::Action::Install" : { "file" : "lib/Pinto/Remote/Action/Install.pm", "version" : "0.097" }, "Pinto::Remote::Result" : { "file" : "lib/Pinto/Remote/Result.pm", "version" : "0.097" }, "Pinto::Repository" : { "file" : "lib/Pinto/Repository.pm", "version" : "0.097" }, "Pinto::Result" : { "file" : "lib/Pinto/Result.pm", "version" : "0.097" }, "Pinto::RevisionWalker" : { "file" : "lib/Pinto/RevisionWalker.pm", "version" : "0.097" }, "Pinto::Role::Committable" : { "file" : "lib/Pinto/Role/Committable.pm", "version" : "0.097" }, "Pinto::Role::FileFetcher" : { "file" : "lib/Pinto/Role/FileFetcher.pm", "version" : "0.097" }, "Pinto::Role::Installer" : { "file" : "lib/Pinto/Role/Installer.pm", "version" : "0.097" }, "Pinto::Role::PauseConfig" : { "file" : "lib/Pinto/Role/PauseConfig.pm", "version" : "0.097" }, "Pinto::Role::Plated" : { "file" : "lib/Pinto/Role/Plated.pm", "version" : "0.097" }, "Pinto::Role::Puller" : { "file" : "lib/Pinto/Role/Puller.pm", "version" : "0.097" }, "Pinto::Role::Schema::Result" : { "file" : "lib/Pinto/Role/Schema/Result.pm", "version" : "0.097" }, "Pinto::Role::Transactional" : { "file" : "lib/Pinto/Role/Transactional.pm", "version" : "0.097" }, "Pinto::Schema" : { "file" : "lib/Pinto/Schema.pm", "version" : "0.097" }, "Pinto::Schema::Result::Ancestry" : { "file" : "lib/Pinto/Schema/Result/Ancestry.pm", "version" : "0.097" }, "Pinto::Schema::Result::Distribution" : { "file" : "lib/Pinto/Schema/Result/Distribution.pm", "version" : "0.097" }, "Pinto::Schema::Result::Package" : { "file" : "lib/Pinto/Schema/Result/Package.pm", "version" : "0.097" }, "Pinto::Schema::Result::Prerequisite" : { "file" : "lib/Pinto/Schema/Result/Prerequisite.pm", "version" : "0.097" }, "Pinto::Schema::Result::Registration" : { "file" : "lib/Pinto/Schema/Result/Registration.pm", "version" : "0.097" }, "Pinto::Schema::Result::RegistrationChange" : { "file" : "lib/Pinto/Schema/Result/RegistrationChange.pm", "version" : "0.097" }, "Pinto::Schema::Result::Revision" : { "file" : "lib/Pinto/Schema/Result/Revision.pm", "version" : "0.097" }, "Pinto::Schema::Result::Stack" : { "file" : "lib/Pinto/Schema/Result/Stack.pm", "version" : "0.097" }, "Pinto::Schema::ResultSet::Distribution" : { "file" : "lib/Pinto/Schema/ResultSet/Distribution.pm", "version" : "0.097" }, "Pinto::Schema::ResultSet::Package" : { "file" : "lib/Pinto/Schema/ResultSet/Package.pm", "version" : "0.097" }, "Pinto::Schema::ResultSet::Registration" : { "file" : "lib/Pinto/Schema/ResultSet/Registration.pm", "version" : "0.097" }, "Pinto::Server" : { "file" : "lib/Pinto/Server.pm", "version" : "0.097" }, "Pinto::Server::Responder" : { "file" : "lib/Pinto/Server/Responder.pm", "version" : "0.097" }, "Pinto::Server::Responder::Action" : { "file" : "lib/Pinto/Server/Responder/Action.pm", "version" : "0.097" }, "Pinto::Server::Responder::File" : { "file" : "lib/Pinto/Server/Responder/File.pm", "version" : "0.097" }, "Pinto::Server::Router" : { "file" : "lib/Pinto/Server/Router.pm", "version" : "0.097" }, "Pinto::SpecFactory" : { "file" : "lib/Pinto/SpecFactory.pm", "version" : "0.097" }, "Pinto::Statistics" : { "file" : "lib/Pinto/Statistics.pm", "version" : "0.097" }, "Pinto::Store" : { "file" : "lib/Pinto/Store.pm", "version" : "0.097" }, "Pinto::Types" : { "file" : "lib/Pinto/Types.pm", "version" : "0.097" }, "Pinto::Util" : { "file" : "lib/Pinto/Util.pm", "version" : "0.097" } }, "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.097", "x_contributors" : [ "BenRifkah Bergsten-Buret ", "Boris D\u00e4ppen ", "Cory G Watson ", "David Steinbrunner ", "Glenn Fowler ", "Jakob Voss ", "Jeffrey Ryan Thalhammer ", "Karen Etheridge ", "Michael G. Schwern ", "Oleg Gashev ", "Steffen Schwigon ", "Tommy Stanton ", "Wolfgang Kinkeldei ", "Yanick Champoux ", "hesco ", "popl " ] } pinto-0.097+dfsg.orig/MANIFEST0000644000000000000000000001214212264262436014376 0ustar rootroot# This file was automatically generated by Dist::Zilla::Plugin::Manifest v5.008. Build.PL Changes LICENSE MANIFEST MANIFEST.SKIP META.json META.yml README bin/pinto bin/pintod dist.ini inc/Pinto/Module/Build.pm 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/manual.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/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/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/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/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/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/DistributionSpec.pm lib/Pinto/Exception.pm lib/Pinto/Globals.pm lib/Pinto/IndexCache.pm lib/Pinto/IndexWriter.pm lib/Pinto/Initializer.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/PackageSpec.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/FileFetcher.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/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/RegistrationChange.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/SpecFactory.pm lib/Pinto/Statistics.pm lib/Pinto/Store.pm lib/Pinto/Types.pm lib/Pinto/Util.pm t/00-compile.t t/00-report-prereqs.t t/01-common/01-types.t t/01-common/02-package-spec.t t/01-common/03-distribution-spec.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/20-add.t t/02-bowels/21-add-no-index.t t/02-bowels/21-pull.t t/02-bowels/22-add-deep.t t/02-bowels/23-pull-multi.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/53-roots.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.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/04-server/01-functional.t t/04-server/02-authentication.t t/lib/Pinto/Server/Tester.pm t/lib/Pinto/Tester.pm t/lib/Pinto/Tester/Util.pm weaver.ini xt/help/50-manual_cmd.t xt/release/02-workarounds.t xt/release/99-memory-cycle.t xt/release/distmeta.t xt/release/pod-syntax.t xt/release/test-version.t pinto-0.097+dfsg.orig/README0000644000076500007650000002013612263155037012360 0ustar NAME Pinto - Curate a repository of Perl modules VERSION version 0.097 SYNOPSIS See pinto to create and manage a Pinto repository. See pintod to allow remote access to your Pinto repository. See Pinto::Manual for more information about the Pinto tools. Stratopan for hosting your Pinto repository in the cloud. 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. FEATURES Pinto is inspired by Carton, CPAN::Mini::Inject, and MyCPAN::App::DPAN, but adds a few interesting features: * 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. * 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). * 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. * 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. * 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 pintod), so remote developers can use a centrally hosted repository. * Pinto has a robust command line interface. The pinto utility has commands and options to control every aspect of your Pinto repository. They are well documented and behave in the customary UNIX fashion. * Pinto can be extended. You can extend Pinto by creating Pinto::Action subclasses to perform new operations on your repository, such as extracting documentation from a distribution, or grepping the source code of several distributions. Pinto vs PAUSE In some ways, Pinto is similar to PAUSE . Both are capable of accepting distributions and constructing a directory structure and index that Perl installers understand. But there are some important differences: * 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. * 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. * 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 pintod does support HTTP authentication, which gives you some control over access to a remote repository. 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 "SYNOPSIS" are your public user interface. SUPPORT Perldoc You can find documentation for this module with the perldoc command. perldoc Pinto 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. * MetaCPAN A modern, open-source CPAN search engine, useful to view POD in HTML format. * CPAN Ratings The CPAN Ratings is a website that allows community ratings and reviews of Perl modules. * CPANTS The CPANTS is a website that analyzes the Kwalitee ( code metrics ) of a distribution. * CPAN Testers The CPAN Testers is a network of smokers who run automated tests on uploaded CPAN distributions. * 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. * CPAN Testers Dependencies The CPAN Testers Dependencies is a website that shows a chart of the test results of all dependencies for a distribution. 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: . 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: * 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. Bugs / Feature Requests 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 :) git clone git://github.com/thaljef/Pinto.git CONTRIBUTORS * BenRifkah Bergsten-Buret * Boris Däppen * Cory G Watson * David Steinbrunner * Glenn Fowler * Jakob Voss * Jeffrey Ryan Thalhammer * Karen Etheridge * Michael G. Schwern * Oleg Gashev * Steffen Schwigon * Tommy Stanton * Wolfgang Kinkeldei * Yanick Champoux * hesco * popl AUTHOR Jeffrey Ryan Thalhammer COPYRIGHT AND LICENSE This software is copyright (c) 2013 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. pinto-0.097+dfsg.orig/t/0000755000076500007650000000000012264262436011744 5ustar pinto-0.097+dfsg.orig/t/04-server/0000755000076500007650000000000012264262436013473 5ustar pinto-0.097+dfsg.orig/t/04-server/01-functional.t0000644000076500007650000002444112263155037016242 0ustar #!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); 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; #------------------------------------------------------------------------------ # 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'), '>=', 200, 'Reasonable Length header'; # Actual length may vary cmp_ok $res->header('Content-Length'), '<', 400, '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 { 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', 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', 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', 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', 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_SERVER_RESPONSE_LINE_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', 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', 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', Content => { action => encode_json($params) } ); my $res = $cb->($req); action_response_not_ok( $res, qr{Can't locate Pinto/Action/Bogus.pm}i ); }; #------------------------------------------------------------------------------ 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', "Correct Content-Type header for $test_name"; my $status = $response->code; is $status, 200, "Succesful status code for $test_name"; my $content = $response->content; like $content, qr{$PINTO_SERVER_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', "Correct Content-Type header for $test_name"; my $status = $response->code; is $status, 200, "Succesful status code for $test_name"; my $content = $response->content; unlike $content, qr{$PINTO_SERVER_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.097+dfsg.orig/t/04-server/02-authentication.t0000644000076500007650000000606512263155037017122 0ustar #!perl use strict; use warnings; use Test::More; use Plack::Test; use JSON; use HTTP::Request; use Pinto::Server; use Pinto::Constants qw(:server); 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; #------------------------------------------------------------------------------ test_psgi app => $app, client => sub { my $cb = shift; my $post_req = HTTP::Request->new( POST => "/action/list" ); 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 = HTTP::Request->new( 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 = HTTP::Request->new( POST => "/action/list" ); $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_SERVER_STATUS_OK\n$}, 'Got status-ok'; my $get_req = HTTP::Request->new( 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 = HTTP::Request->new( POST => "/action/list" ); $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 = HTTP::Request->new( 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.097+dfsg.orig/t/02-bowels/0000755000076500007650000000000012264262436013456 5ustar pinto-0.097+dfsg.orig/t/02-bowels/71-stack-kill.t0000644000076500007650000000443712263155037016133 0ustar #!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; # 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 => { from_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'); } #------------------------------------------------------------------------------ { 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'); } #------------------------------------------------------------------------------ { 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.097+dfsg.orig/t/02-bowels/72-stack-rename.t0000644000076500007650000000471712263155037016451 0ustar #!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; 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 => { from_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)] ); } #------------------------------------------------------------------------------ { 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 => { from_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') } #------------------------------------------------------------------------------ { my $t = Pinto::Tester->new; $t->run_throws_ok( Rename => { from_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 => { from_stack => 'master', to_stack => 'existing' }, qr/already exists/, 'Cannot rename to stack that already exists' ); $t->run_throws_ok( Rename => { from_stack => 'existing', to_stack => 'existing' }, qr/already exists/, 'Cannot rename to stack to itself' ); } #------------------------------------------------------------------------------ done_testing; pinto-0.097+dfsg.orig/t/02-bowels/73-stack-lock.t0000644000076500007650000000334112263155037016123 0ustar #!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->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.097+dfsg.orig/t/02-bowels/21-pull.t0000644000076500007650000000742312263155037015042 0ustar #!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'); #------------------------------------------------------------------------------ { # 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'); } #------------------------------------------------------------------------------ { # 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); } #------------------------------------------------------------------------------ { # 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); } #------------------------------------------------------------------------------ { # 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/ ); } #------------------------------------------------------------------------------ { # 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} ); } #------------------------------------------------------------------------------ { # 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; } #------------------------------------------------------------------------------ { # 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'); } #------------------------------------------------------------------------------ done_testing; pinto-0.097+dfsg.orig/t/02-bowels/32-pin-rjbs.t0000644000076500007650000000516612263155037015616 0ustar #!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', { from_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.097+dfsg.orig/t/02-bowels/43-install-and-pull.t0000644000076500007650000000262512263155037017251 0ustar #!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); #------------------------------------------------------------------------------ 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.097+dfsg.orig/t/02-bowels/42-install.t0000644000076500007650000000710212263155037015531 0ustar #!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); #------------------------------------------------------------------------------ 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') ); }; #------------------------------------------------------------------------------ done_testing; pinto-0.097+dfsg.orig/t/02-bowels/80-repo-lock.t0000644000076500007650000000552512263155037015767 0ustar #!perl use strict; use warnings; use Test::More; use Test::File; use lib 't/lib'; use Pinto::Tester; #------------------------------------------------------------------------------ # Setup a repository... my $t = Pinto::Tester->new; #------------------------------------------------------------------------------ { 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; } } #------------------------------------------------------------------------------ { 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/, 'Excuisve 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; } } #------------------------------------------------------------------------------ done_testing; pinto-0.097+dfsg.orig/t/02-bowels/21-add-no-index.t0000644000076500007650000000414012263155037016326 0ustar #!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.097+dfsg.orig/t/02-bowels/23-pull-multi.t0000644000076500007650000000402712263155037016171 0ustar #!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; #------------------------------------------------------------------------------ { # 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'); } #------------------------------------------------------------------------------ { # 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'); } #------------------------------------------------------------------------------ { # 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.097+dfsg.orig/t/02-bowels/60-dryrun.t0000644000076500007650000000170512263155037015411 0ustar #!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 { 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.097+dfsg.orig/t/02-bowels/10-init.t0000644000076500007650000000502312263155037015021 0ustar #!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 { 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 { my $t = Pinto::Tester->new( init_args => { no_default => 1 } ); $t->no_default_stack_ok; } #------------------------------------------------------------------------------ # Test repository created with custom stack name { my $t = Pinto::Tester->new( init_args => { stack => 'custom' } ); $t->stack_is_default_ok('custom'); } #------------------------------------------------------------------------------ # Test custom config { 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 { 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.097+dfsg.orig/t/02-bowels/05-compare.t0000644000076500007650000000456112263155037015516 0ustar #!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.097+dfsg.orig/t/02-bowels/35-delete.t0000644000076500007650000000417512263155037015336 0ustar #!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.097+dfsg.orig/t/02-bowels/51-diff-more.t0000644000076500007650000000461712263155037015743 0ustar #!perl use strict; use warnings; use Test::More; use Pinto::Difference; use lib 't/lib'; use Pinto::Tester; 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 => { from_stack => 'master', to_stack => 'foo' } ); $t->run_ok( Add => { archives => $dist2, author => 'AUTHOR', stack => 'foo' } ); #------------------------------------------------------------------------------ { my @expected = ( qr{^ \- .+ PkgB \s+ 1 \s+ AUTHOR/Dist-1}mx, qr{^ \+ .+ PkgB \s+ 2 \s+ AUTHOR/Dist-2}mx, qr{^ \+ .+ PkgC \s+ 2 \s+ AUTHOR/Dist-2}mx, ); # 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 @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 @expected; # With stack name and revision id $t->run_ok( Diff => { left => 'master', right => $rev1 } ); $t->stdout_like($_) for @expected; } #------------------------------------------------------------------------------ { # 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.097+dfsg.orig/t/02-bowels/75-stack-props.t0000644000076500007650000000355012263155037016342 0ustar #!perl use strict; use warnings; use Test::More; use Test::Exception; use lib 't/lib'; use Pinto::Tester; #------------------------------------------------------------------------------ my $t = Pinto::Tester->new; #------------------------------------------------------------------------------ { # 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.097+dfsg.orig/t/02-bowels/64-metadata.t0000644000076500007650000000261512263155037015653 0ustar #!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.097+dfsg.orig/t/02-bowels/50-diff.t0000644000076500007650000000305612263155037014776 0ustar #!perl use strict; use warnings; use Test::More; use Pinto::Difference; use lib 't/lib'; use Pinto::Tester; #------------------------------------------------------------------------------ my $t = Pinto::Tester->new; $t->populate('AUTHOR/Dist-1 = PkgA~1, PkgB~1'); $t->populate('AUTHOR/Dist-2 = PkgB~2, PkgC~2'); #------------------------------------------------------------------------------ { 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 } $diff->additions; my @dels = map { $_->to_string } $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 } $diff->additions; @dels = map { $_->to_string } $diff->deletions; is_deeply \@adds, $expect_adds, 'Got expected additions'; is_deeply \@dels, $expect_dels, 'Got expected deletions'; } #------------------------------------------------------------------------------ done_testing; pinto-0.097+dfsg.orig/t/02-bowels/02-chrome.t0000644000076500007650000000663412263155037015345 0ustar #!perl use strict; use warnings; use Test::More; use Test::Exception; use Pinto::Chrome::Term; #----------------------------------------------------------------------------- { 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'; } #----------------------------------------------------------------------------- { 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'; } #----------------------------------------------------------------------------- { 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'; } #----------------------------------------------------------------------------- { local $ENV{PINTO_COLORS} = 'dark blue, white on_red,green'; my $chrome = Pinto::Chrome::Term->new; is_deeply $chrome->colors, [ 'dark blue', 'white on_red', 'green' ], 'Parsed color list'; } #----------------------------------------------------------------------------- { 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'; } #----------------------------------------------------------------------------- { 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.097+dfsg.orig/t/02-bowels/11-tester.t0000644000076500007650000000341112263155037015364 0ustar #!perl use Test::More; use lib 't/lib'; use Pinto::Tester; use Pinto::Tester::Util qw(make_dist_struct parse_reg_spec); #------------------------------------------------------------------------------- { 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'; } #------------------------------------------------------------------------------- { 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; } #------------------------------------------------------------------------------- { 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.097+dfsg.orig/t/02-bowels/01-config.t0000644000076500007650000000314512263155037015326 0ustar #!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.perl.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.097+dfsg.orig/t/02-bowels/63-prereq-circular.t0000644000076500007650000000211212263155037017162 0ustar #!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'); #------------------------------------------------------------------------------ { my $cb = sub { my ($prereq) = @_; my $dist = $t->pinto->repo->get_distribution( spec => $prereq->as_spec ); 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.097+dfsg.orig/t/02-bowels/74-stack-default.t0000644000076500007650000000156412263155037016625 0ustar #!perl use Test::More; use Test::Exception; use lib 't/lib'; use Pinto::Tester; #------------------------------------------------------------------------------ { 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.097+dfsg.orig/t/02-bowels/04-distribution.t0000644000076500007650000000512512263155037016603 0ustar #!perl use strict; use warnings; use Test::More; use Path::Class; use lib 't/lib'; use Pinto::Tester::Util qw(make_dist_obj); #----------------------------------------------------------------------------- { 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' ); } #----------------------------------------------------------------------------- { 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' ); } #------------------------------------------------------------------------------ { 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.097+dfsg.orig/t/02-bowels/53-roots.t0000644000076500007650000000213112263155037015230 0ustar #!perl use strict; use warnings; use Test::More; use lib 't/lib'; use Pinto::Tester; #------------------------------------------------------------------------------ { # Typical case my $t = Pinto::Tester->new; $t->populate('ME/Dist-1 = PkgA~1 & PkgB~1'); $t->populate('ME/Dist-2 = PkgB~1'); $t->populate('ME/Dist-3 = PkgC~1'); $t->run_ok( Roots => {format => '%D'}); my @lines = split /\n/, ${ $t->outstr }; is_deeply \@lines, [qw(Dist-1 Dist-3)], 'Got expected roots'; } #------------------------------------------------------------------------------ { # What if there is a circular dependency? 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 }; local $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.097+dfsg.orig/t/02-bowels/31-pin.t0000644000076500007650000000346412263155037014656 0ustar #!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.097+dfsg.orig/t/02-bowels/22-add-deep.t0000644000076500007650000000753712263155037015540 0ustar #!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... { 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... { 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 { 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 { 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'); } #------------------------------------------------------------------------------ { 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.097+dfsg.orig/t/02-bowels/40-list.t0000644000076500007650000000520112263155037015032 0ustar #!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' } ); #----------------------------------------------------------------------------- { $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'; } #----------------------------------------------------------------------------- { $t->run_ok( 'List' => { stack => 'qa', packages => 'Bar' } ); my @lines = split /\n/, ${ $t->outstr }; is scalar @lines, 1, 'Got correct number of records in listing'; like $lines[0], qr/Bar \s+ 0.02/x, 'Listing for packages matching %Bar% on qa stack'; } #----------------------------------------------------------------------------- { $t->run_ok( 'List' => { stack => 'qa', distributions => 'Baz' } ); 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 dists matching %Baz% on qa stack'; } #----------------------------------------------------------------------------- { $t->run_ok( 'List' => { stack => 'qa', author => 'BOB' } ); 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 where author == BOB on qa stack'; } #----------------------------------------------------------------------------- { # Testing result status... my $result; $t->run_ok( New => {stack => 'foo'}); $result = $t->pinto->run( List => { stack => 'foo' }); is $result->was_successful, 0, 'Listing an empty stack is successfull'; $result = $t->pinto->run( List => { stack => 'foo', author => 'nomatch' }); is $result->was_successful, 0, 'No matches means unsuccessful'; } #----------------------------------------------------------------------------- done_testing; pinto-0.097+dfsg.orig/t/02-bowels/70-stack-copy.t0000644000076500007650000001216512263155037016146 0ustar #!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; #------------------------------------------------------------------------------ { # 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'; } #------------------------------------------------------------------------------ { # Copy dev -> qa... my $dev_stk_name = 'dev'; my $qa_stk_name = 'qa'; $t->run_ok( Copy => { from_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'; } #------------------------------------------------------------------------------ { # Copy with extra stuff my $dev_stk_name = 'dev'; my $xtra_stk_name = 'xtra'; $t->run_ok( Copy => { from_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'; } #------------------------------------------------------------------------------ { # 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... { $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... { # Copy from a stack that doesn't exist $t->run_throws_ok( Copy => { from_stack => 'nowhere', to_stack => 'somewhere' }, qr/Stack nowhere does not exist/ ); # Copy to a stack that already exists $t->run_throws_ok( Copy => { from_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 => { from_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 => { from_stack => 'master', to_stack => '$bogus@' }, qr/must be alphanumeric/ ); # Copy to stack with no name $t->run_throws_ok( Copy => { from_stack => 'master', to_stack => '' }, qr/must be alphanumeric/ ); # Copy to stack with undef name $t->run_throws_ok( Copy => { from_stack => 'master', to_stack => undef }, qr/must be alphanumeric/ ); } #------------------------------------------------------------------------------ done_testing; pinto-0.097+dfsg.orig/t/02-bowels/41-log.t0000644000076500007650000000365512263155037014654 0ustar #!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 => { from_stack => 'master', to_stack => 'branch' } ); $t->run_ok( Add => { stack => 'branch', archives => make_dist_archive("ME/Bar-0.02 = Bar~0.02") } ); #------------------------------------------------------------------------------ { 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' ); } #------------------------------------------------------------------------------ { 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.097+dfsg.orig/t/02-bowels/03-package.t0000644000076500007650000000356312263155037015462 0ustar #!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.097+dfsg.orig/t/02-bowels/63-prereq.t0000644000076500007650000000356012263155037015370 0ustar #!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( spec => $prereq->as_spec ); }; # 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.097+dfsg.orig/t/02-bowels/61-nofail.t0000644000076500007650000000743012263155037015340 0ustar #!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... { 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'); # The filesystem is not transactional, so the archive for A will still be there... $local->path_exists_ok( [qw(stacks master authors id A AU AUTHOR DistA-1.tar.gz)] ); # And so will the archives for B and D... $local->path_exists_ok( [qw(stacks master authors id A AU AUTHOR DistB-1.tar.gz)] ); $local->path_exists_ok( [qw(stacks master authors id A AU AUTHOR DistD-1.tar.gz)] ); # But C should not be there because we never got to pull it... $local->path_not_exists_ok( [qw(stacks master authors id A AU AUTHOR DistC-1.tar.gz)] ); # If we clean up those files... $local->pinto->repo->clean_files; # The the whole repo should be pure again... $local->repository_clean_ok; } #------------------------------------------------------------------------------ # If the no_fail flag is set, then only the failed ones should be rollback... { 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.097+dfsg.orig/t/02-bowels/62-commit.t0000644000076500007650000000721512263155037015362 0ustar #!perl #------------------------------------------------------------------------------ package Pinto::Action::Fake; use Moose; extends 'Pinto::Action'; with 'Pinto::Role::Committable'; sub execute { my $self = shift; # To bypass assert_has_changed() when committed $self->stack->head->update( { has_changes => 1 } ); return qw(Foo Bar Baz); } no Moose; #------------------------------------------------------------------------------ package main; use strict; use warnings; use Test::More; use Pinto::Globals; use lib 't/lib'; use Pinto::Tester; #------------------------------------------------------------------------------ local $Pinto::Globals::current_username = 'ME'; my $t = Pinto::Tester->new; my $faked_title = 'Fake Bar, Baz, Foo'; #------------------------------------------------------------------------------ { note "Specified nothing"; $t->run_ok( Fake => {} ); my $stack = $t->pinto->repo->get_stack; my $revision = $stack->head; is( $revision->username, 'ME', 'Revision was committed by ME' ); is( $revision->message_title, $faked_title, 'Message has correct title' ); is( $revision->message_body, '', 'Message body is empty' ); is( $revision->message, $faked_title, 'Message is title only' ); } #------------------------------------------------------------------------------ { note "Specified use_default_message"; $t->run_ok( Fake => { use_default_message => 1 } ); my $stack = $t->pinto->repo->get_stack; my $revision = $stack->head; is( $revision->username, 'ME', 'Revision was committed by ME' ); is( $revision->message_title, $faked_title, 'Message has correct title' ); is( $revision->message_body, '', 'Message body is empty' ); is( $revision->message, $faked_title, 'Message is title only' ); } #------------------------------------------------------------------------------ { note "Specified message is empty (or whitespace) string"; $t->run_ok( Fake => { message => ' ' } ); my $stack = $t->pinto->repo->get_stack; my $revision = $stack->head; is( $revision->username, 'ME', 'Revision was committed by ME' ); is( $revision->message_title, $faked_title, 'Message has correct title' ); is( $revision->message_body, '', 'Message body is empty' ); is( $revision->message, $faked_title, 'Message is title only' ); } #------------------------------------------------------------------------------ { note "Specified custom (non-empty) message"; $t->run_ok( Fake => { message => 'my message' } ); my $stack = $t->pinto->repo->get_stack; my $revision = $stack->head; is( $revision->message, 'my message', 'Got custom commit message when specified' ); is( $revision->message_body, '', 'Message body is empty when specified message has title only' ); is( $revision->message_title, 'my message', 'Got message title' ); } #------------------------------------------------------------------------------ { note "Specified custom message containing title and body regions"; $t->run_ok( Fake => { message => " my title \n\nmy body " } ); my $stack = $t->pinto->repo->get_stack; my $revision = $stack->head; is( $revision->message, " my title \n\nmy body ", 'Got custom commit message when specified' ); is( $revision->message_body, 'my body', 'Got message body' ); is( $revision->message_title, 'my title', 'Got message title' ); } #------------------------------------------------------------------------------ done_testing; pinto-0.097+dfsg.orig/t/02-bowels/20-add.t0000644000076500007650000001323312263155037014611 0ustar #!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 $auth = 'ME'; 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... { my $t = Pinto::Tester->new; $t->run_ok( 'Add', { archives => $archive, author => $auth } ); $t->registration_ok("$auth/$dist/$pkg1/master"); $t->registration_ok("$auth/$dist/$pkg2/master"); } #----------------------------------------------------------------------------- # Adding to alternative stack... { my $t = Pinto::Tester->new; $t->run_ok( 'New', { stack => 'dev' } ); $t->run_ok( 'Add', { archives => $archive, author => $auth, stack => 'dev' } ); $t->registration_ok("$auth/$dist/$pkg1/dev"); $t->registration_ok("$auth/$dist/$pkg2/dev"); } #----------------------------------------------------------------------------- # Adding identical dist twice on same stack { my $t = Pinto::Tester->new; $t->run_ok( 'Add', { archives => $archive, author => $auth } ); $t->registration_ok("$auth/$dist/$pkg1/master"); $t->registration_ok("$auth/$dist/$pkg2/master"); $t->run_ok( 'Add', { archives => $archive, author => $auth } ); $t->registration_ok("$auth/$dist/$pkg1/master"); $t->registration_ok("$auth/$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, author => $auth, pin => 1 } ); $t->registration_ok("$auth/$dist/$pkg1/master/*"); $t->registration_ok("$auth/$dist/$pkg2/master/*"); } #----------------------------------------------------------------------------- # Adding identical dist twice on different stacks { my $t = Pinto::Tester->new; $t->run_ok( 'Add', { archives => $archive, author => $auth } ); $t->registration_ok("$auth/$dist/$pkg1/master"); $t->registration_ok("$auth/$dist/$pkg2/master"); $t->run_ok( 'New', { stack => 'dev' } ); $t->run_ok( 'Add', { archives => $archive, author => $auth, stack => 'dev' } ); $t->registration_ok("$auth/$dist/$pkg1/dev"); $t->registration_ok("$auth/$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 { my $t = Pinto::Tester->new; $t->run_ok( 'Add', { archives => $archive, author => $auth } ); $t->registration_ok("$auth/$dist/$pkg1/master"); $t->registration_ok("$auth/$dist/$pkg2/master"); $t->run_ok( 'Add', { archives => $archive, author => $auth, pin => 1 } ); $t->registration_ok("$auth/$dist/$pkg1/master/*"); $t->registration_ok("$auth/$dist/$pkg2/master/*"); $t->stderr_like( qr/\Q$archive\E is the same/, 'Got warning about identical dist' ); } #----------------------------------------------------------------------------- # Adding identical dists with different names { 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, author => $auth } ); $t->run_throws_ok( 'Add', { archives => $archive2, author => $auth }, qr/\Q$archive2\E is the same .* but with different name/ ); } #----------------------------------------------------------------------------- # Adding multiple dists to the same path { 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, author => $auth } ); $t->run_throws_ok( 'Add', { archives => $archive2, author => uc $auth }, qr/already exists/, 'Cannot add dist to same path twice' ); $t->run_throws_ok( 'Add', { archives => $archive2, author => $auth }, qr/already exists/, 'Cannot add dist to same path twice' ); $t->run_throws_ok( 'Add', { archives => 'bogus', author => $auth }, qr/Some archives are missing/, 'Cannot add nonexistant archive' ); } #----------------------------------------------------------------------------- # Adding something that requires a perl (the perl prereq should be ignored) { 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, author => $auth } ); $t->registration_ok("$auth/Foo-1.0/Foo~1.0"); } #----------------------------------------------------------------------------- # Adding something that requires a core-only module (the prereq should be ignored) { 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, author => $auth } ); $t->registration_ok("$auth/Foo-1.0/Foo~1.0"); } #----------------------------------------------------------------------------- done_testing; pinto-0.097+dfsg.orig/t/00-compile.t0000644000076500007650000001266412263155037014004 0ustar use 5.006; use strict; use warnings; # this test was generated with Dist::Zilla::Plugin::Test::Compile 2.039 use Test::More tests => 119 + ($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/manual.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/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/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/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/Roots.pm', 'Pinto/Action/Stacks.pm', 'Pinto/Action/Statistics.pm', 'Pinto/Action/Unlock.pm', 'Pinto/Action/Unpin.pm', 'Pinto/Action/Unregister.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/DistributionSpec.pm', 'Pinto/Exception.pm', 'Pinto/Globals.pm', 'Pinto/IndexCache.pm', 'Pinto/IndexWriter.pm', 'Pinto/Initializer.pm', 'Pinto/Locker.pm', 'Pinto/Migrator.pm', 'Pinto/ModlistWriter.pm', 'Pinto/PackageExtractor.pm', 'Pinto/PackageSpec.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/FileFetcher.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/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/RegistrationChange.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/SpecFactory.pm', 'Pinto/Statistics.pm', 'Pinto/Store.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 $inc_switch = -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; my $pid = open3($stdin, '>&STDERR', $stderr, $^X, $inc_switch, '-e', "require q[$lib]"); binmode $stderr, ':crlf' if $^O eq 'MSWin32'; my @_warnings = <$stderr>; waitpid($pid, 0); is($?, 0, "$lib loaded ok"); 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 =~ /^#!.*?\bperl\b\s*(.*)$/; my @flags = $1 ? split(/\s+/, $1) : (); my $stderr = IO::Handle->new; my $pid = open3($stdin, '>&STDERR', $stderr, $^X, $inc_switch, @flags, '-c', $file); binmode $stderr, ':crlf' if $^O eq 'MSWin32'; my @_warnings = <$stderr>; waitpid($pid, 0); is($?, 0, "$file compiled ok"); # 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') if $ENV{AUTHOR_TESTING}; pinto-0.097+dfsg.orig/t/lib/0000755000000000000000000000000012264262436014256 5ustar rootrootpinto-0.097+dfsg.orig/t/lib/Pinto/0000755000076500007650000000000012264262436013603 5ustar pinto-0.097+dfsg.orig/t/lib/Pinto/Tester.pm0000644000076500007650000003673212263155037015417 0ustar # 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 Path::Class; use File::Temp qw(tempdir); use Test::Exception; use Pinto; use Pinto::Globals; use Pinto::Initializer; use Pinto::Chrome::Term; use Pinto::Tester::Util qw(:all); use Pinto::Types qw(Uri Dir); use Pinto::Util qw(:all); #------------------------------------------------------------------------------ # VERSION #------------------------------------------------------------------------------ extends qw(Test::Builder::Module); #------------------------------------------------------------------------------ BEGIN { # 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 { dir( tempdir( CLEANUP => 1 ) ) }, lazy => 1, ); has pinto => ( is => 'ro', isa => 'Pinto', builder => '_build_pinto', lazy => 1, ); has repo => ( is => 'ro', isa => 'Pinto::Repository', 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, no_color => 1, stdout => $self->outstr, stderr => $self->errstr, ); my %defaults = ( root => $self->root ); my $initializer = Pinto::Initializer->new; $initializer->init( %defaults, $self->init_args ); return Pinto->new( %defaults, chrome => $chrome, $self->pinto_args ); } #------------------------------------------------------------------------------ sub get_stack { my ( $self, @args ) = @_; return $self->repo->get_stack(@args); } #------------------------------------------------------------------------------ sub get_distribution { my ( $self, @args ) = @_; return $self->repo->get_distribution(@args); } #------------------------------------------------------------------------------ sub path_exists_ok { my ( $self, $path, $name ) = @_; $path = ref $path eq 'ARRAY' ? file( $self->root, @{$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' ? file( $self->root, @{$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 is 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 = eval { $self->get_stack($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 = eval { $self->get_stack($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 = eval { $self->get_stack($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 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" ); } #------------------------------------------------------------------------------ 1; __END__ pinto-0.097+dfsg.orig/t/lib/Pinto/Server/0000755000076500007650000000000012263155037015046 5ustar pinto-0.097+dfsg.orig/t/lib/Pinto/Server/Tester.pm0000644000076500007650000001376112263155037016662 0ustar # 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 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! 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 5; # 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" ); } #------------------------------------------------------------------------------- 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.097+dfsg.orig/t/lib/Pinto/Tester/0000755000076500007650000000000012263155037015046 5ustar pinto-0.097+dfsg.orig/t/lib/Pinto/Tester/Util.pm0000644000076500007650000001242612263155037016326 0ustar # 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"; return { name => $1, version => $2 || 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._]+)}; return $cpanm_ver >= $min_version; } #------------------------------------------------------------------------------ 1; __END__ pinto-0.097+dfsg.orig/t/01-common/0000755000076500007650000000000012264262436013452 5ustar pinto-0.097+dfsg.orig/t/01-common/05-pauseconfig.t0000644000076500007650000000141112263155037016356 0ustar #!perl use strict; use warnings; use Test::More; use Test::Warn; use File::Temp; sub write_temp_file { my ($content) = @_; my $temp = File::Temp->new; $temp->autoflush(1); print $temp $content; return $temp; } note "Creating Local::PauseConfig class for testing"; { package Local::PauseConfig; use Moose; with qw(Pinto::Role::PauseConfig); } note "Test a pauserc file with the non_interactive flag set"; { my $pauserc = write_temp_file(<<'TEXT'); user SOMEUSER mailto somebody@example.com non_interactive TEXT my $obj = Local::PauseConfig->new( pauserc => $pauserc->filename ); warnings_are { is_deeply $obj->pausecfg, { user => "SOMEUSER", mailto => 'somebody@example.com' }; } []; } done_testing; pinto-0.097+dfsg.orig/t/01-common/04-util.t0000644000076500007650000000674412263155037015045 0ustar #!perl use strict; use warnings; use Test::More; use Path::Class; use Pinto::Util qw(:all); #----------------------------------------------------------------------------- { 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' ); } #----------------------------------------------------------------------------- { my $author = 'joseph'; my $expect = dir(qw(J JO JOSEPH)); is( Pinto::Util::author_dir($author), $expect, 'Author dir path for joseph' ); } #----------------------------------------------------------------------------- { my $author = 'JO'; my $expect = dir(qw(J JO JO)); is( Pinto::Util::author_dir($author), $expect, 'Author dir path for JO' ); } #----------------------------------------------------------------------------- { 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' ); } #----------------------------------------------------------------------------- { 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" ); } } #----------------------------------------------------------------------------- { is( title_text("foo"), 'foo' ); is( title_text("foo\nbar"), 'foo' ); is( title_text("\nbar"), '' ); is( body_text("foo"), '' ); is( body_text("foo\n"), '' ); is( body_text("foo\nbar\n"), "bar\n" ); } #----------------------------------------------------------------------------- { 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" ); } #----------------------------------------------------------------------------- { is( truncate_text( "foobar", 3 ), "foo..." ); is( truncate_text( "foobar", 6 ), "foobar" ); is( truncate_text( "foobar", 0 ), "foobar" ); is( truncate_text( "foobar", 3, '-' ), "foo-" ); } #----------------------------------------------------------------------------- { is( is_blank(), 1 ); is( is_blank(""), 1 ); is( is_blank(" \n\t\r\f "), 1 ); is( is_blank("foo"), 0 ); } #----------------------------------------------------------------------------- done_testing; pinto-0.097+dfsg.orig/t/01-common/lib/0000755000076500007650000000000012263155037014215 5ustar pinto-0.097+dfsg.orig/t/01-common/lib/TestClass.pm0000644000076500007650000000335412263155037016465 0ustar package TestClass; use Moose; use Pinto::Types qw( File Dir Uri Io AuthorID Version PropertyName StackName StackAll StackDefault PkgSpec PkgSpecList DistSpec DistSpecList SpecList RevisionID ANSIColor ANSIColorSet ); #----------------------------------------------------------------------------- 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 => PkgSpec, coerce => 1, ); has pkgs => ( is => 'rw', isa => PkgSpecList, coerce => 1, ); has dist => ( is => 'rw', isa => DistSpec, coerce => 1, ); has dists => ( is => 'rw', isa => DistSpecList, coerce => 1, ); has targets => ( is => 'rw', isa => SpecList, coerce => 1, ); has revision => ( is => 'rw', isa => RevisionID, coerce => 1, ); has color => ( is => 'rw', isa => ANSIColor, ); has colorset => ( is => 'rw', isa => ANSIColorSet, ); #----------------------------------------------------------------------------- 1; pinto-0.097+dfsg.orig/t/01-common/03-distribution-spec.t0000644000076500007650000000345212263155037017527 0ustar #!perl use strict; use warnings; use Test::More; use Test::Exception; use Pinto::DistributionSpec; #------------------------------------------------------------------------------ subtest string_constructor => sub { my $spec = Pinto::DistributionSpec->new('Author/subdir/Foo-1.2.tar.gz'); is $spec->author, 'AUTHOR', 'author attribute'; is $spec->archive, 'Foo-1.2.tar.gz', 'archive attribute'; is $spec->path, 'A/AU/AUTHOR/subdir/Foo-1.2.tar.gz', 'Constructed path'; is "$spec", 'AUTHOR/subdir/Foo-1.2.tar.gz', 'Stringified object'; }; #------------------------------------------------------------------------------ subtest hash_constructor => sub { my $spec = Pinto::DistributionSpec->new( author => 'Author', subdirs => [qw(foo bar)], archive => 'Foo-1.2.tar.gz' ); is $spec->author, 'AUTHOR', 'author attribute'; is $spec->archive, 'Foo-1.2.tar.gz', 'archive attribute'; is $spec->path, 'A/AU/AUTHOR/foo/bar/Foo-1.2.tar.gz', 'Constructed path'; is "$spec", 'AUTHOR/foo/bar/Foo-1.2.tar.gz', 'Stringified object'; }; #------------------------------------------------------------------------------ { throws_ok { Pinto::DistributionSpec->new('AUTHOR/') } qr{Invalid distribution spec}, 'Invalid dist spec'; throws_ok { Pinto::DistributionSpec->new('/Foo-1.2.tar.gz') } qr{Invalid distribution spec}, 'Invalid dist spec'; throws_ok { Pinto::DistributionSpec->new('Foo-1.2.tar.gz') } qr{Invalid distribution spec}, 'Invalid dist spec'; throws_ok { Pinto::DistributionSpec->new('') } qr{Invalid distribution spec}, 'Empty dist spec'; } #------------------------------------------------------------------------------ done_testing; pinto-0.097+dfsg.orig/t/01-common/01-types.t0000644000076500007650000001066612263155037015227 0ustar #!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->dir('foo/bar/baz'); is( ref $t->dir(), 'Path::Class::Dir', 'Coerced dir from string' ); $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::PackageSpec', '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::DistributionSpec', '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::DistributionSpec', 'Coereced DistributionSpec from string' ); $t->targets( [ 'Foo~1.2', 'author/subdir/Dist-1.0.tar.gz' ] ); is( ref $t->targets->[0], 'Pinto::PackageSpec', 'Coerced PackageSpec in array' ); is( ref $t->targets->[1], 'Pinto::DistributionSpec', 'Coereced DistributionSpec in array' ); $t->targets( ['Foo'] ); is( ref $t->targets->[0], 'Pinto::PackageSpec', '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->colorset( [qw(red blue green)] ) }; dies_ok { $t->colorset( [qw(red blue)] ) } 'Colorset needs 3 colors'; dies_ok { $t->colorset( [qw(a b c)] ) } 'Colorset must be valid colors'; dies_ok { $t->colorset(undef) }; dies_ok { $t->colorset( [] ) }; #----------------------------------------------------------------------------- done_testing; pinto-0.097+dfsg.orig/t/01-common/02-package-spec.t0000644000076500007650000000352612263155037016404 0ustar #!perl use strict; use warnings; use version; use Test::More; use English qw(-no_match_vars); use Pinto::PackageSpec; #------------------------------------------------------------------------------ { my $spec = Pinto::PackageSpec->new('Foo~1.2'); is $spec->name, 'Foo', 'Parsed package name from string'; is $spec->version, '1.2', 'Parsed package version from string'; is "$spec", 'Foo~1.2', 'Stringified PackageSpec object'; } #------------------------------------------------------------------------------ { my $spec = Pinto::PackageSpec->new('Foo'); is $spec->name, 'Foo', 'Parsed package name from string'; is $spec->version, '0', 'Parsed package version from string without version'; is "$spec", 'Foo~0', 'Stringified PackageSpec object'; } #------------------------------------------------------------------------------ { my $spec = Pinto::PackageSpec->new( name => 'Foo', version => 1.2 ); is $spec->name, 'Foo', 'Constructor with normal name attribute'; is $spec->version, '1.2', 'Constructor with normal version version'; is "$spec", 'Foo~1.2', 'Stringified PackageSpec object'; } #------------------------------------------------------------------------------ { # Module::Build first introduced into core in perl 5.9.4 # Module::Build was first upgraded to 0.038 in perl 5.13.11 my $spec = Pinto::PackageSpec->new( name => 'Module::Build', version => 0.38 ); is $spec->is_core( in => 'v5.6.1' ), 0, "$spec is not in perl 5.6.1"; is $spec->is_core( in => 'v5.10.1' ), 0, "$spec is not in perl 5.10.1"; is $spec->is_core( in => 'v5.14.2' ), 1, "$spec is in perl 5.14.2"; local $] = 5.013011; is $spec->is_core, 1, "$spec is in *this* perl, pretending we are $]" } #------------------------------------------------------------------------------ done_testing; pinto-0.097+dfsg.orig/t/03-remote/0000755000076500007650000000000012264262436013457 5ustar pinto-0.097+dfsg.orig/t/03-remote/04-install-with-auth.t0000644000076500007650000000613412263155037017444 0ustar #!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); #------------------------------------------------------------------------------ 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; $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 $stderr = capture_stderr { lives_ok { $remote->run( Install => ( targets => ['PkgA'], %cpanm_opts ) ) } 'install command was successfull'; }; 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 $stderr = capture_stderr { throws_ok { $remote->run( Install => ( targets => ['PkgA'], %cpanm_opts ) ) } qr/Installation failed/; } }; #------------------------------------------------------------------------------ subtest 'Remote install fails with no credentials' => sub { 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 $stderr = capture_stderr { throws_ok { $remote->run( Install => ( targets => ['PkgA'], %cpanm_opts ) ) } qr/Installation failed/; }; }; #------------------------------------------------------------------------------ done_testing; pinto-0.097+dfsg.orig/t/03-remote/03-install.t0000644000076500007650000000744412263155037015540 0ustar #!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 Pinto::Remote; use lib 't/lib'; use Pinto::Server::Tester; use Pinto::Constants qw($PINTO_MINIMUM_CPANM_VERSION); use Pinto::Tester::Util qw(make_dist_archive has_cpanm); #------------------------------------------------------------------------------ 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; $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 $stderr = capture_stderr { $remote->run( 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') ); }; #------------------------------------------------------------------------------ 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 $stderr = capture_stderr { $remote->run( 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') ); }; #------------------------------------------------------------------------------ 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 $remote = Pinto::Remote->new( root => $t->server_url ); my $stderr = capture_stderr { throws_ok { $remote->run( Install => { targets => ['PkgZ'], %cpanm_opts } ) } 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 ); my $stderr = 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.097+dfsg.orig/t/03-remote/01-requests.t0000644000076500007650000000417212263155037015736 0ustar #!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::Constants qw($PINTO_DEFAULT_COLORS); #----------------------------------------------------------------------------- { local $ENV{PINTO_COLORS} = undef; my $res = HTTP::Response->new(200); my $ua = Test::LWP::UserAgent->new; $ua->map_response( qr{.*} => $res ); my $action = 'Add'; my $temp = File::Temp->new; my %pinto_args = ( username => 'myname' ); my %chrome_args = ( verbose => 2, no_color => 1, quiet => 0, colors => $PINTO_DEFAULT_COLORS ); my %action_args = ( archives => [ $temp->filename ], author => 'ME', stack => 'mystack' ); my $chrome = Pinto::Chrome::Term->new(%chrome_args); my $pinto = Pinto::Remote->new( root => 'myhost', ua => $ua, 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"; 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} ); 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->headers->header('Content-Type'); my $length = $req->headers->header('Content-Length'); my $hb = HTTP::Body->new( $type, $length ); $hb->add( $req->content ); return $hb->param; } #----------------------------------------------------------------------------- done_testing; pinto-0.097+dfsg.orig/t/03-remote/02-responses.t0000644000076500007650000000230412263155037016100 0ustar #!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::Chrome::Term; use Pinto::Constants qw(:server); #----------------------------------------------------------------------------- { my $res = HTTP::Response->new(200); $res->content("DATA-GOES-HERE\n## DIAG-MSG-HERE\n$PINTO_SERVER_STATUS_OK\n"); my $ua = Test::LWP::UserAgent->new; $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( ua => $ua, chrome => $chrome, root => 'localhost' ); 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.097+dfsg.orig/t/00-report-prereqs.t0000644000076500007650000001210012263155037015327 0ustar #!perl use strict; use warnings; # This test was generated by Dist::Zilla::Plugin::Test::ReportPrereqs 0.011 use Test::More tests => 1; use ExtUtils::MakeMaker; use File::Spec::Functions; use List::Util qw/max/; my @modules = qw( Apache::Htpasswd App::Cmd::Command::help App::Cmd::Setup Archive::Extract Archive::Tar Authen::Simple::Passwd CPAN::Checksums CPAN::DistnameInfo CPAN::Meta CPAN::Meta::Requirements Capture::Tiny Carp Class::Load Cwd Cwd::Guard DBD::SQLite DBIx::Class DBIx::Class::Core DBIx::Class::ResultSet DBIx::Class::Schema DateTime DateTime::TimeZone DateTime::TimeZone::Local::Unix DateTime::TimeZone::OffsetOnly Devel::StackTrace Digest::MD5 Digest::SHA Dist::Metadata Encode English Exporter ExtUtils::MakeMaker File::Copy File::Find File::HomeDir File::NFSLock File::Spec File::Spec::Functions File::Temp File::Which FindBin Getopt::Long HTTP::Body HTTP::Date HTTP::Request HTTP::Request::Common HTTP::Response HTTP::Server::PSGI IO::File IO::Handle IO::Interactive IO::Pipe IO::Prompt IO::Select IO::String IO::Zlib IPC::Open3 JSON JSON::PP LWP::UserAgent List::MoreUtils List::Util Module::Build Module::Build::CleanInstall Module::CoreList Module::Faker::Dist Moose Moose::Role MooseX::Aliases MooseX::ClassAttribute MooseX::Configuration MooseX::MarkAsMethods MooseX::NonMoose MooseX::SetOnce MooseX::StrictConstructor MooseX::Types MooseX::Types::Moose Package::Locator Path::Class Path::Class::Dir Path::Class::File Plack Plack::MIME Plack::Middleware::Auth::Basic Plack::Request Plack::Response Plack::Runner Plack::Test Pod::Usage Proc::Fork Proc::Terminator Readonly Router::Simple Scalar::Util Starman String::Format Term::ANSIColor Term::EditorEdit Test::Builder::Module Test::Exception Test::File Test::LWP::UserAgent Test::More Test::TCP Test::Warn Throwable::Error Try::Tiny URI UUID::Tiny base lib overload perl strict utf8 version warnings ); my %exclude = map {; $_ => 1 } qw( ); my ($source) = grep { -f $_ } qw/MYMETA.json MYMETA.yml META.json/; $source = "META.yml" unless defined $source; # replace modules with dynamic results from MYMETA.json if we can # (hide CPAN::Meta from prereq scanner) my $cpan_meta = "CPAN::Meta"; my $cpan_meta_req = "CPAN::Meta::Requirements"; my $all_requires; if ( -f $source && eval "require $cpan_meta" ) { ## no critic if ( my $meta = eval { CPAN::Meta->load_file($source) } ) { # Get ALL modules mentioned in META (any phase/type) my $prereqs = $meta->prereqs; delete $prereqs->{develop} if not $ENV{AUTHOR_TESTING}; my %uniq = map {$_ => 1} map { keys %$_ } map { values %$_ } values %$prereqs; $uniq{$_} = 1 for @modules; # don't lose any static ones @modules = sort grep { ! $exclude{$_} } keys %uniq; # If verifying, merge 'requires' only for major phases if ( 1 ) { $prereqs = $meta->effective_prereqs; # get the object, not the hash if (eval "require $cpan_meta_req; 1") { ## no critic $all_requires = $cpan_meta_req->new; for my $phase ( qw/configure build test runtime develop/ ) { $all_requires->add_requirements( $prereqs->requirements_for($phase, 'requires') ); } } } } } my @reports = [qw/Version Module/]; my @dep_errors; my $req_hash = defined($all_requires) ? $all_requires->as_string_hash : {}; for my $mod ( @modules ) { next if $mod eq 'perl'; my $file = $mod; $file =~ s{::}{/}g; $file .= ".pm"; my ($prefix) = grep { -e catfile($_, $file) } @INC; if ( $prefix ) { my $ver = MM->parse_version( catfile($prefix, $file) ); $ver = "undef" unless defined $ver; # Newer MM should do this anyway push @reports, [$ver, $mod]; if ( 1 && $all_requires ) { my $req = $req_hash->{$mod}; if ( defined $req && length $req ) { if ( ! defined eval { version->parse($ver) } ) { push @dep_errors, "$mod version '$ver' cannot be parsed (version '$req' required)"; } elsif ( ! $all_requires->accepts_module( $mod => $ver ) ) { push @dep_errors, "$mod version '$ver' is not in required range '$req'"; } } } } else { push @reports, ["missing", $mod]; if ( 1 && $all_requires ) { my $req = $req_hash->{$mod}; if ( defined $req && length $req ) { push @dep_errors, "$mod is not installed (version '$req' required)"; } } } } if ( @reports ) { my $vl = max map { length $_->[0] } @reports; my $ml = max map { length $_->[1] } @reports; splice @reports, 1, 0, ["-" x $vl, "-" x $ml]; diag "\nVersions for all modules listed in $source (including optional ones):\n", map {sprintf(" %*s %*s\n",$vl,$_->[0],-$ml,$_->[1])} @reports; } if ( @dep_errors ) { diag join("\n", "\n*** WARNING WARNING WARNING WARNING WARNING WARNING WARNING WARNING ***\n", "The following REQUIRED prerequisites were not satisfied:\n", @dep_errors, "\n" ); } pass; # vim: ts=2 sts=2 sw=2 et: