├── .gitignore ├── .mailmap ├── .tidyallrc ├── .travis.yml ├── Changes ├── MANIFEST.SKIP ├── README.md ├── bin ├── pinto └── pintod ├── dist.ini ├── etc ├── TODO.pod ├── benchmark ├── cpanm ├── install.sh ├── mkdbic └── smoke ├── lib ├── App │ ├── Pinto.pm │ └── Pinto │ │ ├── Command.pm │ │ └── Command │ │ ├── add.pm │ │ ├── clean.pm │ │ ├── copy.pm │ │ ├── default.pm │ │ ├── delete.pm │ │ ├── diff.pm │ │ ├── help.pm │ │ ├── init.pm │ │ ├── install.pm │ │ ├── kill.pm │ │ ├── list.pm │ │ ├── lock.pm │ │ ├── log.pm │ │ ├── look.pm │ │ ├── manual.pm │ │ ├── merge.pm │ │ ├── migrate.pm │ │ ├── new.pm │ │ ├── nop.pm │ │ ├── pin.pm │ │ ├── props.pm │ │ ├── pull.pm │ │ ├── register.pm │ │ ├── rename.pm │ │ ├── reset.pm │ │ ├── revert.pm │ │ ├── roots.pm │ │ ├── stacks.pm │ │ ├── statistics.pm │ │ ├── thanks.pm │ │ ├── unlock.pm │ │ ├── unpin.pm │ │ ├── unregister.pm │ │ ├── update.pm │ │ └── verify.pm ├── Pinto.pm └── Pinto │ ├── Action.pm │ ├── Action │ ├── Add.pm │ ├── Clean.pm │ ├── Copy.pm │ ├── Default.pm │ ├── Delete.pm │ ├── Diff.pm │ ├── Install.pm │ ├── Kill.pm │ ├── List.pm │ ├── Lock.pm │ ├── Log.pm │ ├── Look.pm │ ├── Merge.pm │ ├── New.pm │ ├── Nop.pm │ ├── Pin.pm │ ├── Props.pm │ ├── Pull.pm │ ├── Register.pm │ ├── Rename.pm │ ├── Reset.pm │ ├── Revert.pm │ ├── Roots.pm │ ├── Stacks.pm │ ├── Statistics.pm │ ├── Unlock.pm │ ├── Unpin.pm │ ├── Unregister.pm │ ├── Update.pm │ └── Verify.pm │ ├── ArchiveUnpacker.pm │ ├── Chrome.pm │ ├── Chrome │ ├── Net.pm │ └── Term.pm │ ├── Config.pm │ ├── Constants.pm │ ├── Database.pm │ ├── Difference.pm │ ├── DifferenceEntry.pm │ ├── Editor.pm │ ├── Editor │ ├── Clip.pm │ └── Edit.pm │ ├── Exception.pm │ ├── Globals.pm │ ├── IndexReader.pm │ ├── IndexWriter.pm │ ├── Initializer.pm │ ├── Locator.pm │ ├── Locator │ ├── Mirror.pm │ ├── Multiplex.pm │ └── Stratopan.pm │ ├── Locker.pm │ ├── Manual.pod │ ├── Manual │ ├── Installing.pod │ ├── Introduction.pod │ ├── QuickStart.pod │ ├── Thanks.pod │ └── Tutorial.pod │ ├── Migrator.pm │ ├── ModlistWriter.pm │ ├── PackageExtractor.pm │ ├── PrerequisiteWalker.pm │ ├── Remote.pm │ ├── Remote │ ├── Action.pm │ ├── Action │ │ ├── Add.pm │ │ └── Install.pm │ └── Result.pm │ ├── Repository.pm │ ├── Result.pm │ ├── RevisionWalker.pm │ ├── Role │ ├── Committable.pm │ ├── Installer.pm │ ├── PauseConfig.pm │ ├── Plated.pm │ ├── Puller.pm │ ├── Schema │ │ └── Result.pm │ ├── Transactional.pm │ └── UserAgent.pm │ ├── Schema.pm │ ├── Schema │ ├── Result │ │ ├── Ancestry.pm │ │ ├── Distribution.pm │ │ ├── Package.pm │ │ ├── Prerequisite.pm │ │ ├── Registration.pm │ │ ├── Revision.pm │ │ └── Stack.pm │ └── ResultSet │ │ ├── Distribution.pm │ │ ├── Package.pm │ │ └── Registration.pm │ ├── Server.pm │ ├── Server │ ├── Responder.pm │ ├── Responder │ │ ├── Action.pm │ │ └── File.pm │ └── Router.pm │ ├── Shell.pm │ ├── Statistics.pm │ ├── Store.pm │ ├── Target.pm │ ├── Target │ ├── Distribution.pm │ └── Package.pm │ ├── Types.pm │ └── Util.pm ├── t ├── 01-common │ ├── 01-types.t │ ├── 02-target-package.t │ ├── 03-target-distribution.t │ ├── 04-util.t │ ├── 05-pauseconfig.t │ └── lib │ │ └── TestClass.pm ├── 02-bowels │ ├── 01-config.t │ ├── 02-chrome.t │ ├── 03-package.t │ ├── 04-distribution.t │ ├── 05-compare.t │ ├── 10-init.t │ ├── 11-tester.t │ ├── 12-locator.t │ ├── 19-basic.t │ ├── 20-add.t │ ├── 21-add-no-index.t │ ├── 21-pull-vreq.t │ ├── 21-pull.t │ ├── 22-add-deep.t │ ├── 23-pull-multi.t │ ├── 24-skip-prereqs.t │ ├── 31-pin.t │ ├── 32-pin-rjbs.t │ ├── 35-delete.t │ ├── 40-list.t │ ├── 41-log.t │ ├── 42-install.t │ ├── 43-install-and-pull.t │ ├── 50-diff.t │ ├── 51-diff-more.t │ ├── 52-intermingle.t │ ├── 53-roots.t │ ├── 54-revert.t │ ├── 60-dryrun.t │ ├── 61-nofail.t │ ├── 62-commit.t │ ├── 63-prereq-circular.t │ ├── 63-prereq-core.t │ ├── 64-metadata.t │ ├── 70-stack-copy.t │ ├── 71-stack-kill.t │ ├── 72-stack-rename.t │ ├── 73-stack-lock.t │ ├── 74-stack-default.t │ ├── 75-stack-props.t │ └── 80-repo-lock.t ├── 03-remote │ ├── 01-requests.t │ ├── 02-responses.t │ ├── 03-install.t │ ├── 04-install-with-auth.t │ └── 05-timezone.t ├── 04-server │ ├── 01-functional.t │ ├── 02-authentication.t │ └── 03-security.t └── lib │ └── Pinto │ ├── Server │ └── Tester.pm │ ├── Tester.pm │ └── Tester │ └── Util.pm ├── weaver.ini └── xt ├── help └── 50-manual_cmd.t └── release ├── 02-workarounds.t ├── 03-stratopan-live.t └── 99-memory-cycle.t /.gitignore: -------------------------------------------------------------------------------- 1 | /META.yml 2 | /MYMETA.* 3 | /Makefile 4 | /Makefile.old 5 | /MANIFEST 6 | /MANIFEST.bak 7 | /blib/ 8 | /pm_to_blib 9 | /.build 10 | !.gitignore 11 | *.bs 12 | /xs/*.c 13 | *.o 14 | cover_db 15 | *.gc?? 16 | test-mydeps-* 17 | nytprof* 18 | !.gitignore 19 | *.sw* 20 | Pinto-* 21 | .build 22 | profiles 23 | nytprof 24 | nytprof.out 25 | *.sublime* 26 | .tags* 27 | tmp 28 | perltidy.LOG 29 | .tiidyall.d 30 | -------------------------------------------------------------------------------- /.mailmap: -------------------------------------------------------------------------------- 1 | Boris Däppen 2 | Kahlil (Kal) Hodgson 3 | Jeffrey Ryan Thalhammer 4 | Jeffrey Ryan Thalhammer 5 | Jeffrey Ryan Thalhammer 6 | -------------------------------------------------------------------------------- /.tidyallrc: -------------------------------------------------------------------------------- 1 | no_backups = 1 2 | no_cache = 1 3 | 4 | [PerlTidy] 5 | select = **/*.{pl,pm,t} 6 | argv = -q -se -l=120 -i=4 -ci=4 -vt=2 -cti=0 -pt=1 -sbt=1 -bbt=1 -nsfs -nolq -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: perl 2 | 3 | sudo: false 4 | 5 | perl: 6 | - "5.26" 7 | - "5.24" 8 | - "5.22" 9 | - "5.20" 10 | - "5.18" 11 | - "5.16" 12 | - "5.14" 13 | 14 | install: 15 | - unset PERL_CPANM_OPT 16 | - cpanm --quiet --notest Dist::Zilla 17 | - dzil authordeps | cpanm --quiet --notest 18 | - dzil listdeps | cpanm --quiet --notest 19 | 20 | script: 21 | - export HARNESS_OPTIONS='j:c' 22 | - dzil smoke --release --author 23 | -------------------------------------------------------------------------------- /MANIFEST.SKIP: -------------------------------------------------------------------------------- 1 | ^profiles 2 | ^nytprof 3 | ^tmp$ 4 | ^[.]tags 5 | ^perltidy.LOG 6 | ^[.].tidyall.d 7 | ^[.]build 8 | ^TEST 9 | 10 | 11 | -------------------------------------------------------------------------------- /etc/TODO.pod: -------------------------------------------------------------------------------- 1 | =head1 HIGH PRIORITY 2 | 3 | =over 4 4 | 5 | 6 | =item Fallback if upstream repo does not respond 7 | 8 | =item Add --with-recommended-dependencies 9 | 10 | =item Apply --no-index to prereqs too? 11 | 12 | =item Fix line buffering in Pinto::Remote::Action. 13 | 14 | =item Create command to list outdated packages. 15 | 16 | =item Move repository configuration into the DB 17 | 18 | =item Heirarchy of exception classes 19 | 20 | =item Create a hook mechanism to do stuff before or after an Action 21 | 22 | =back 23 | 24 | =head1 MEDIUM PRORITY 25 | 26 | =over 4 27 | 28 | =item Enable locks on all stacks (repo lock) 29 | 30 | =item Lookup dists without the extension (e.g. .zip or .tar.gz or .tgz) 31 | 32 | =item Consider pinning at dist level, not pkg 33 | 34 | =item Create command to list dependors and dependants 35 | 36 | =item Create command to verify prereqs on a stack 37 | 38 | =item Create command to list outdated packages 39 | 40 | =item Create command to package whole repo in tar.gz 41 | 42 | =item Stack property: allow devel releases 43 | 44 | =item Repo property: default devel option 45 | 46 | =item Profile and look for performance optimizations. 47 | 48 | =item Verify archive checksums during 'verify' 49 | 50 | =item Standardize API, using named parameters except where it makes sense not to. 51 | 52 | =item Tests, tests, tests. 53 | 54 | =back 55 | 56 | =head1 LOW PRIORITY 57 | 58 | =over 4 59 | 60 | =item Optimize generation of CHECKSUMS files. 61 | 62 | =item Improve Perl::Critic compliance. 63 | 64 | =item Document, document, document. 65 | 66 | =item Look for better ways to use Moose roles. 67 | 68 | =item Issue warning if META indicates that configuration is dynamic. 69 | 70 | =back 71 | 72 | =head1 QUESTIONABLE 73 | 74 | =over 4 75 | 76 | =item Give revisions properties 77 | 78 | =item Try to ensure integrity of commits (what does this mean?) 79 | 80 | =item Stack property: strict (no overlapping dists) 81 | 82 | =item Add versioning to the stack props 83 | 84 | =item Consider using natural keys for package/dists. 85 | 86 | =item Make the Store transactional 87 | 88 | =item Extract versioning stuff to a separate dist. 89 | 90 | =item Rewrite tests with Test::Class 91 | 92 | =item Mark stacks as merged after merge 93 | 94 | =item Warn if an unmerged stack is being deleted 95 | 96 | =back 97 | 98 | =head1 SCRAPPED 99 | 100 | =over 4 101 | 102 | =item Generate a RECENT file. 103 | 104 | =item Command options to specify provided/required packages (maybe not) 105 | 106 | =item Enable plugins for visiting and filtering. 107 | 108 | =item news: list recent additions. maybe something from Changes file 109 | 110 | =item ack: Do an ack command across all distributions 111 | 112 | =item look: Unpack archive in temp dir and launch shell there 113 | 114 | =item Mark stacks as deleted after delete 115 | 116 | =back 117 | 118 | =cut 119 | -------------------------------------------------------------------------------- /etc/benchmark: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Pinto; 7 | use Pinto::Initializer; 8 | use Pinto::DistributionSpec; 9 | 10 | use File::Temp; 11 | use List::Util qw(sum); 12 | use Getopt::Long::Descriptive; 13 | 14 | #----------------------------------------------------------------------------- 15 | 16 | # Copyright 2013 Jeffrey Ryan Thalhammer 17 | 18 | #----------------------------------------------------------------------------- 19 | 20 | my @ops = qw(pin unpin unregister register); 21 | 22 | my ($opt, $usage) = describe_options( 23 | "$0 %o TARGETS", 24 | [ 'root|r=s', "Root of repository", ], 25 | [ 'ops|o=s@', "Operations to perform", ], 26 | [ 'iterations|i=i', "Number of iterations", { default => 100 } ], 27 | ); 28 | 29 | my @targets = @ARGV ? @ARGV : qw(THALJEF/Pinto-0.065.tar.gz); 30 | my %ops = map { lc $_ => 1 } $opt->ops ? @{$opt->ops} : @ops; 31 | my $root = $opt->root || File::Temp->newdir; 32 | my $iters = $opt->iterations; 33 | 34 | #----------------------------------------------------------------------------- 35 | 36 | { 37 | Pinto::Initializer->new->init(root => $root) unless -e $root; 38 | my $pinto = Pinto->new(root => "$root"); 39 | 40 | for my $target (@targets) { 41 | my $spec = Pinto::DistributionSpec->new($target); 42 | next if $pinto->repo->get_distribution(spec => $spec); 43 | $pinto->run(Pull => (targets => $target, message => "pulled $target")); 44 | } 45 | } 46 | 47 | #----------------------------------------------------------------------------- 48 | 49 | my @runs; 50 | for my $i (1..$iters) { 51 | print "Iteration $i: "; 52 | DB::enable_profile() if $i == $iters && defined $Devel::NYTProf::VERSION; 53 | 54 | my $start = time; 55 | my $pinto = Pinto->new(root => "$root"); 56 | $pinto->run(Pin => (targets => \@targets, message => 'pin')) if $ops{pin}; 57 | $pinto->run(Unpin => (targets => \@targets, message => 'unpin')) if $ops{unpin}; 58 | $pinto->run(Unregister => (targets => \@targets, message => 'unreg')) if $ops{unregister}; 59 | $pinto->run(Register => (targets => \@targets, message => 'reg')) if $ops{register}; 60 | my $elapsed = time - $start; 61 | 62 | print "$elapsed seconds\n"; 63 | push @runs, $elapsed; 64 | } 65 | 66 | my $average = sum( @runs ) / scalar @runs; 67 | print "Average: $average seconds\n"; -------------------------------------------------------------------------------- /etc/mkdbic: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | # To generate the schema classes, run this command from the root directory 4 | # of the distribution. You must install DBIx::Class::Schema::Loader first. 5 | 6 | use FindBin qw($Bin); 7 | use Path::Class qw(file); 8 | use File::Path qw(mkpath); 9 | 10 | my $distdir = file($Bin)->parent; 11 | my $libdir = $distdir->subdir('lib'); 12 | push @INC, $libdir->stringify; 13 | 14 | #----------------------------------------------------------------------------- 15 | 16 | # Copyright 2013 Jeffrey Ryan Thalhammer 17 | 18 | #----------------------------------------------------------------------------- 19 | # Read DDL from inside the Database class 20 | 21 | require Pinto::Database; 22 | my $ddl = Pinto::Database->ddl; 23 | 24 | #----------------------------------------------------------------------------- 25 | # Create a temp directory to stash the database 26 | 27 | my $tmpdir = $distdir->subdir('tmp'); 28 | mkpath $tmpdir->stringify if not -e $tmpdir; 29 | 30 | #----------------------------------------------------------------------------- 31 | # Create database, feeding in the DDL 32 | 33 | my $dbfile = $tmpdir->file('pinto.db'); 34 | unlink $dbfile or die $!; 35 | 36 | open my $fh, '|-', "sqlite3 $dbfile" or die $!; 37 | print $fh $ddl; 38 | 39 | #----------------------------------------------------------------------------- 40 | # Run the schema generator 41 | 42 | system <<"END_COMMAND"; 43 | dbicdump -Ilib \\ 44 | -o skip_load_external=1 \\ 45 | -o dump_directory=lib \\ 46 | -o 'use_moose=1' \\ 47 | -o 'result_roles=[ qw(Pinto::Role::Schema::Result) ]' \\ 48 | Pinto::Schema \\ 49 | dbi:SQLite:$dbfile 50 | END_COMMAND 51 | 52 | #----------------------------------------------------------------------------- 53 | 54 | exit; 55 | -------------------------------------------------------------------------------- /etc/smoke: -------------------------------------------------------------------------------- 1 | #!/bin/bash -ue 2 | 3 | ###################################################################### 4 | # 5 | # THIS IS THE Pinto SMOKER 6 | # 7 | # I use this little script to build & test Pinto against several 8 | # common versions of Perl that I have on my machine. The key thing 9 | # is that all the dependencies come from a curated repository on 10 | # Stratopan. So these are not the latest versions, but versions 11 | # that I have blessed. In comparison, the builds on Travis are 12 | # done with the latest versions from CPAN, which don't always work. 13 | # 14 | # Copyright 2013 Jeffrey Ryan Thalhammer 15 | # 16 | ###################################################################### 17 | 18 | unset PINTO_HOME; 19 | MODULES_TO_SMOKE=${1:-Pinto}; 20 | SMOKE_BASE_DIR=$HOME/tmp/smoke 21 | CPAN_MIRROR_URL=https://stratopan.com/thaljef/OpenSource/pinto-release 22 | PERLS_TO_SMOKE=${2:-'5.8.9 5.10.1 5.12.5 5.14.4 5.16.3 5.18.4 5.20.3 5.22.2 5.24.0'} 23 | 24 | for pv in $PERLS_TO_SMOKE; do 25 | 26 | SMOKE_WORK_DIR="$SMOKE_BASE_DIR/$pv"; 27 | 28 | # TODO: add a command-line option to control whether 29 | # or not to blow away an existing local-lib directory 30 | 31 | # rm -rf "$SMOKE_WORK_DIR"; 32 | mkdir -p "$SMOKE_WORK_DIR"; 33 | 34 | for mod in $MODULES_TO_SMOKE; do 35 | 36 | echo "=============================================================="; 37 | echo "Smoking $mod with perl-$pv in $SMOKE_WORK_DIR"; 38 | 39 | perlbrew exec --with $pv \ 40 | cpanm --mirror "$CPAN_MIRROR_URL" \ 41 | --local-lib-contained "$SMOKE_WORK_DIR" \ 42 | --mirror-only \ 43 | --quiet \ 44 | $mod \ 45 | 2>&1 | tee "$SMOKE_WORK_DIR/smoke.log" 46 | 47 | done; 48 | 49 | done; 50 | 51 | -------------------------------------------------------------------------------- /lib/App/Pinto/Command/clean.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: remove orphaned distribution archives 2 | 3 | package App::Pinto::Command::clean; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | #------------------------------------------------------------------------------ 9 | 10 | use base 'App::Pinto::Command'; 11 | 12 | #------------------------------------------------------------------------------ 13 | 14 | # VERSION 15 | 16 | #----------------------------------------------------------------------------- 17 | 18 | 1; 19 | 20 | __END__ 21 | 22 | =head1 SYNOPSIS 23 | 24 | pinto --root=REPOSITORY_ROOT clean 25 | 26 | =head1 DESCRIPTION 27 | 28 | The database for L is transactional, so failures and aborted 29 | commands do not change the indexes. However, the filesystem where 30 | distribution archives are physically stored is not transactional and 31 | may become cluttered with archives that are not in the database. 32 | 33 | Normally, L tries to clean up those orphaned archives. But in 34 | some cases it might not. Running this command will force their 35 | removal. 36 | 37 | This command also runs some optimizations on the database. So if 38 | your repository seems to be running slowly, try running this command 39 | to see if performance improves. 40 | 41 | =head1 COMMAND ARGUMENTS 42 | 43 | None. 44 | 45 | =head1 COMMAND OPTIONS 46 | 47 | None. 48 | 49 | =cut 50 | -------------------------------------------------------------------------------- /lib/App/Pinto/Command/delete.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: permanently remove an archive 2 | 3 | package App::Pinto::Command::delete; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | #------------------------------------------------------------------------------ 9 | 10 | use base 'App::Pinto::Command'; 11 | 12 | #------------------------------------------------------------------------------ 13 | 14 | # VERSION 15 | 16 | #----------------------------------------------------------------------------- 17 | 18 | sub command_names { return qw(delete remove del rm) } 19 | 20 | #----------------------------------------------------------------------------- 21 | 22 | sub opt_spec { 23 | my ( $self, $app ) = @_; 24 | 25 | return ( [ 'force' => 'Delete even if packages are pinned' ], ); 26 | } 27 | 28 | #------------------------------------------------------------------------------ 29 | 30 | sub args_attribute { return 'targets'; } 31 | 32 | #------------------------------------------------------------------------------ 33 | 34 | sub args_from_stdin { return 1; } 35 | 36 | #------------------------------------------------------------------------------ 37 | 1; 38 | 39 | __END__ 40 | 41 | =head1 SYNOPSIS 42 | 43 | pinto --root=REPOSITORY_ROOT delete [OPTIONS] TARGET ... 44 | 45 | =head1 DESCRIPTION 46 | 47 | !! THIS COMMAND IS EXPERIMENTAL !! 48 | 49 | B This command is dangerous. If you just want to remove 50 | packages or distributions from a stack, then you should probably be looking 51 | at the L command instead. 52 | 53 | This command permanently removes an archive from the repository, thereby 54 | unregistering it from all stacks and wiping it from all history (as if 55 | it had never been put in the repository). Beware that once an archive 56 | is deleted it cannot be recovered. There will be no record that the 57 | archive was ever added or deleted, and this change cannot be undone. 58 | 59 | To merely remove packages from a stack (while preserving the archive), 60 | use the L command. 61 | 62 | =head1 COMMAND ARGUMENTS 63 | 64 | Arguments are the targets that you want to delete. Targets are 65 | specified as C. For example: 66 | 67 | SHAKESPEARE/King-Lear-1.2.tar.gz 68 | 69 | You can also pipe arguments to this command over STDIN. In that case, 70 | blank lines and lines that look like comments (i.e. starting with "#" 71 | or ';') will be ignored. 72 | 73 | =head1 COMMAND OPTIONS 74 | 75 | =over 4 76 | 77 | =item --force 78 | 79 | Deletes the archive even if its packages are pinned to a stack. Take 80 | care when deleting pinned packages, as it usually means that 81 | particular package is important to someone. 82 | 83 | =back 84 | 85 | =cut 86 | -------------------------------------------------------------------------------- /lib/App/Pinto/Command/help.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: display a command's help screen 2 | 3 | package App::Pinto::Command::help; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use base qw(App::Cmd::Command::help); 9 | 10 | #------------------------------------------------------------------------------- 11 | 12 | # VERSION 13 | 14 | #------------------------------------------------------------------------------- 15 | # This is just a thin subclass of App::Cmd::Command::help. All we have done is 16 | # extend the exeucte() method to mention the "pinto manual" command at the end 17 | 18 | sub execute { 19 | my ( $self, $opts, $args ) = @_; 20 | 21 | my ( $cmd, undef, undef ) = $self->app->prepare_command(@$args); 22 | my ($cmd_name) = $cmd->command_names; 23 | 24 | my $rv = $self->SUPER::execute( $opts, $args ); 25 | 26 | # Only display this if showing help for a specific command. 27 | print qq{For more information, run "pinto manual $cmd_name"\n} if @{$args}; 28 | 29 | return $rv; 30 | } 31 | 32 | #------------------------------------------------------------------------------- 33 | 1; 34 | 35 | =head1 SYNOPSIS 36 | 37 | pinto help COMMAND 38 | 39 | =head1 DESCRIPTION 40 | 41 | This command shows a brief help screen for a pinto COMMAND. 42 | 43 | =head1 COMMAND ARGUMENTS 44 | 45 | The argument to this command is the name of the command you would like help 46 | on. You can also use the L command to get 47 | extended documentation for any command. 48 | 49 | =cut 50 | -------------------------------------------------------------------------------- /lib/App/Pinto/Command/kill.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: permanently delete a stack 2 | 3 | package App::Pinto::Command::kill; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | #----------------------------------------------------------------------------- 9 | 10 | use base 'App::Pinto::Command'; 11 | 12 | #------------------------------------------------------------------------------ 13 | 14 | # VERSION 15 | 16 | #------------------------------------------------------------------------------ 17 | 18 | sub command_names { return qw(kill) } 19 | 20 | #------------------------------------------------------------------------------ 21 | 22 | sub opt_spec { 23 | my ( $self, $app ) = @_; 24 | 25 | return ( [ 'force' => 'Kill even if stack is locked' ], ); 26 | } 27 | 28 | #------------------------------------------------------------------------------ 29 | 30 | sub validate_args { 31 | my ( $self, $opts, $args ) = @_; 32 | 33 | $self->usage_error('Must specify exactly one stack') 34 | if @{$args} != 1; 35 | 36 | return 1; 37 | } 38 | 39 | #------------------------------------------------------------------------------ 40 | 41 | sub execute { 42 | my ( $self, $opts, $args ) = @_; 43 | 44 | my $result = $self->pinto->run( $self->action_name, %{$opts}, stack => $args->[0] ); 45 | 46 | return $result->exit_status; 47 | } 48 | 49 | #------------------------------------------------------------------------------ 50 | 1; 51 | 52 | __END__ 53 | 54 | =pod 55 | 56 | =head1 SYNOPSIS 57 | 58 | pinto --root=REPOSITORY_ROOT kill [OPTIONS] STACK 59 | 60 | =head1 DESCRIPTION 61 | 62 | This command permanently deletes a stack. Once a stack is killed, there 63 | is no direct way to get it back. However, any distributions that were 64 | registered on the stack will still remain in the repository. 65 | 66 | =head1 COMMAND ARGUMENTS 67 | 68 | The required argument is the name of the stack you wish to kill. 69 | Stack names must be alphanumeric plus hyphens and underscores, and 70 | are not case-sensitive. 71 | 72 | =head1 COMMAND OPTIONS 73 | 74 | =over 4 75 | 76 | =item --force 77 | 78 | Kill the stack even if it is currently locked. Normally, locked 79 | stacks cannot be deleted. Take care when deleting a locked stack 80 | as it usually means the stack is important to someone. 81 | 82 | =back 83 | 84 | =cut 85 | 86 | -------------------------------------------------------------------------------- /lib/App/Pinto/Command/lock.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: mark a stack as read-only 2 | 3 | package App::Pinto::Command::lock; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | #----------------------------------------------------------------------------- 9 | 10 | use base 'App::Pinto::Command'; 11 | 12 | #------------------------------------------------------------------------------ 13 | 14 | # VERSION 15 | 16 | #------------------------------------------------------------------------------ 17 | 18 | sub opt_spec { 19 | my ( $self, $app ) = @_; 20 | 21 | return ( [ 'stack|s=s' => 'Lock this stack' ], ); 22 | } 23 | 24 | #------------------------------------------------------------------------------ 25 | 26 | sub validate_args { 27 | my ( $self, $opts, $args ) = @_; 28 | 29 | $self->usage_error('Multiple arguments are not allowed') 30 | if @{$args} > 1; 31 | 32 | $opts->{stack} = $args->[0] 33 | if $args->[0]; 34 | 35 | return 1; 36 | } 37 | 38 | #------------------------------------------------------------------------------ 39 | 40 | 1; 41 | 42 | __END__ 43 | 44 | =head1 SYNOPSIS 45 | 46 | pinto --root=REPOSITORY_ROOT lock [OPTIONS] 47 | 48 | =head1 DESCRIPTION 49 | 50 | This command locks a stack so that its packages cannot be changed. It 51 | is typically used with the L command 52 | to effectively create a read-only "tag" of a stack. 53 | 54 | To unlock a stack, use the L 55 | command. 56 | 57 | =head1 COMMAND ARGUMENTS 58 | 59 | As an alternative to the C<--stack> option, you can also specify the 60 | stack as an argument. So the following examples are equivalent: 61 | 62 | pinto --root REPOSITORY_ROOT lock --stack dev 63 | pinto --root REPOSITORY_ROOT lock dev 64 | 65 | A stack specified as an argument in this fashion will override any 66 | stack specified with the C<--stack> option. If a stack is not 67 | specified by neither argument nor option, then it defaults to the 68 | stack that is currently marked as the default stack. 69 | 70 | =head1 COMMAND OPTIONS 71 | 72 | =over 4 73 | 74 | =item --stack NAME 75 | 76 | =item -s NAME 77 | 78 | Lock the stack with the given NAME. Defaults to the name of whichever 79 | stack is currently marked as the default stack. Use the 80 | L command to see the stacks in the 81 | repository. 82 | 83 | =back 84 | 85 | =cut 86 | -------------------------------------------------------------------------------- /lib/App/Pinto/Command/log.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: show the revision logs of a stack 2 | 3 | package App::Pinto::Command::log; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | #----------------------------------------------------------------------------- 9 | 10 | use base 'App::Pinto::Command'; 11 | 12 | #------------------------------------------------------------------------------ 13 | 14 | # VERSION 15 | 16 | #------------------------------------------------------------------------------ 17 | 18 | sub command_names { return qw(log history) } 19 | 20 | #------------------------------------------------------------------------------ 21 | 22 | sub opt_spec { 23 | my ( $self, $app ) = @_; 24 | 25 | return ( 26 | [ 'stack|s=s' => 'Show history for this stack' ], 27 | [ 'with-diffs|d' => 'Show a diff for each revision'], 28 | [ 'diff-style=s' => 'Diff style (concise|detailed)' ], 29 | ); 30 | } 31 | 32 | #------------------------------------------------------------------------------ 33 | 34 | sub validate_args { 35 | my ( $self, $opts, $args ) = @_; 36 | 37 | $self->usage_error('Multiple arguments are not allowed') if @{$args} > 1; 38 | 39 | $opts->{stack} = $args->[0] if $args->[0]; 40 | 41 | return 1; 42 | } 43 | 44 | #------------------------------------------------------------------------------ 45 | 46 | 1; 47 | 48 | __END__ 49 | 50 | =head1 SYNOPSIS 51 | 52 | pinto --root=REPOSITORY_ROOT log [STACK] [OPTIONS] 53 | 54 | =head1 DESCRIPTION 55 | 56 | !! THIS COMMAND IS EXPERIMENTAL !! 57 | 58 | This command shows the revision logs for the stack. 59 | 60 | =head1 COMMAND ARGUMENTS 61 | 62 | As an alternative to the C<--stack> option, you can specify it as 63 | an argument. So the following examples are equivalent: 64 | 65 | pinto --root REPOSITORY_ROOT log --stack=dev 66 | pinto --root REPOSITORY_ROOT log dev 67 | 68 | A C argument will override anything specified with the 69 | C<--stack> option. If the stack is not specified using neither 70 | argument nor option, then the logs of the default stack will 71 | be shown. 72 | 73 | =head1 COMMAND OPTIONS 74 | 75 | =over 4 76 | 77 | =item --with-diffs 78 | 79 | =item -d 80 | 81 | For each revision, also show the diff from the previous revision. 82 | If the C environment varaible is set to a 83 | true value, a detailed diff will be shown. 84 | 85 | =item --stack NAME 86 | 87 | =item -s NAME 88 | 89 | Show the logs of the stack with the given NAME. Defaults to the name 90 | of whichever stack is currently marked as the default stack. Use the 91 | L command to see the stacks in the 92 | repository. 93 | 94 | =back 95 | 96 | =cut 97 | -------------------------------------------------------------------------------- /lib/App/Pinto/Command/manual.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: show the full manual for a command 2 | 3 | package App::Pinto::Command::manual; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use Pod::Usage qw(pod2usage); 9 | 10 | use base qw(App::Pinto::Command); 11 | 12 | #------------------------------------------------------------------------------- 13 | 14 | # VERSION 15 | 16 | #------------------------------------------------------------------------------- 17 | 18 | sub command_names { return qw( manual man --man ) } 19 | 20 | #----------------------------------------------------------------------------- 21 | 22 | sub validate_args { 23 | my ( $self, $opts, $args ) = @_; 24 | 25 | $self->usage_error("Must specify a command") if @{$args} != 1; 26 | 27 | return 1; 28 | } 29 | 30 | #------------------------------------------------------------------------------- 31 | # This was stolen from App::Cmd::Command::help 32 | 33 | sub execute { 34 | my ( $self, $opts, $args ) = @_; 35 | 36 | my ( $cmd, undef, undef ) = $self->app->prepare_command(@$args); 37 | 38 | my $class = ref $cmd; 39 | 40 | # An invalid command name was specified, so the fallback command class 41 | # was returned. Rather than showing the (unhelpful) manual for 42 | # App::Cmd::Command::commands, we will just bail out and let App::Cmd 43 | # show the usual 'unrecognized command' message. 44 | return 1 if $class eq 'App::Cmd::Command::commands'; 45 | 46 | ( my $relative_path = $class ) =~ s< :: >xmsg; 47 | $relative_path .= '.pm'; 48 | 49 | my $absolute_path = $INC{$relative_path} 50 | or die "No manual available for $class\n"; 51 | 52 | pod2usage( -verbose => 2, -input => $absolute_path, -exitval => 0 ); 53 | 54 | return 1; 55 | } 56 | 57 | #------------------------------------------------------------------------------- 58 | 1; 59 | 60 | =head1 SYNOPSIS 61 | 62 | pinto manual COMMAND 63 | 64 | =head1 DESCRIPTION 65 | 66 | This command shows the complete user manual for a pinto COMMAND. 67 | 68 | =head1 COMMAND ARGUMENTS 69 | 70 | The argument to this command is the name of the command for which you would 71 | like to see the manual. You can also use the L 72 | command to get a brief summary of the command. 73 | 74 | =cut 75 | -------------------------------------------------------------------------------- /lib/App/Pinto/Command/migrate.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: migrate repository to a new version 2 | 3 | package App::Pinto::Command::migrate; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use Class::Load; 9 | use Pinto::Util qw(is_remote_repo); 10 | 11 | #----------------------------------------------------------------------------- 12 | 13 | use base 'App::Pinto::Command'; 14 | 15 | #------------------------------------------------------------------------------ 16 | 17 | # VERSION 18 | 19 | #------------------------------------------------------------------------------ 20 | 21 | sub validate_args { 22 | my ( $self, $opts, $args ) = @_; 23 | 24 | $self->usage_error('Arguments are not allowed') 25 | if @{$args}; 26 | 27 | return 1; 28 | } 29 | 30 | #------------------------------------------------------------------------------ 31 | 32 | sub execute { 33 | my ( $self, $opts, $args ) = @_; 34 | 35 | my $global_opts = $self->app->global_options; 36 | 37 | die "Must specify a repository root directory\n" 38 | unless $global_opts->{root} ||= $ENV{PINTO_REPOSITORY_ROOT}; 39 | 40 | die "Cannot migrate remote repositories\n" 41 | if is_remote_repo( $global_opts->{root} ); 42 | 43 | my $class = $self->load_migrator; 44 | my $migrator = $class->new( %{$global_opts} ); 45 | $migrator->migrate; 46 | 47 | return 0; 48 | } 49 | 50 | #------------------------------------------------------------------------------ 51 | 52 | sub load_migrator { 53 | 54 | my $class = 'Pinto::Migrator'; 55 | 56 | my ( $ok, $error ) = Class::Load::try_load_class($class); 57 | return $class if $ok; 58 | 59 | my $msg = $error =~ m/Can't locate .* in \@INC/ ## no critic (ExtendedFormat) 60 | ? "Must install Pinto to migrate repositories\n" 61 | : $error; 62 | die $msg; 63 | } 64 | 65 | #------------------------------------------------------------------------------ 66 | 1; 67 | 68 | __END__ 69 | 70 | =pod 71 | 72 | =head1 SYNOPSIS 73 | 74 | pinto --root=REPOSITORY_ROOT migrate 75 | 76 | =head1 DESCRIPTION 77 | 78 | This command migrates an existing repository to a format that is compatible 79 | with the current version of L that you have. At present, it only 80 | works for repositories created with version 0.070 or later. If you need 81 | to migrate a repository that was created with an earlier version, please 82 | contact C and I'll help you come up with a migration 83 | plan that fits your situation. 84 | 85 | =head1 COMMAND ARGUMENTS 86 | 87 | None. 88 | 89 | =head1 COMMAND OPTIONS 90 | 91 | None. 92 | 93 | =cut 94 | -------------------------------------------------------------------------------- /lib/App/Pinto/Command/new.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: create a new empty stack 2 | 3 | package App::Pinto::Command::new; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | #----------------------------------------------------------------------------- 9 | 10 | use base 'App::Pinto::Command'; 11 | 12 | #------------------------------------------------------------------------------ 13 | 14 | # VERSION 15 | 16 | #------------------------------------------------------------------------------ 17 | 18 | sub opt_spec { 19 | my ( $self, $app ) = @_; 20 | 21 | return ( 22 | [ 'default' => 'Make the new stack the default stack' ], 23 | [ 'description|d=s' => 'Brief description of the stack' ], 24 | [ 'target-perl-version|tpv=s' => 'Target Perl version for this stack' ], 25 | ); 26 | } 27 | 28 | #------------------------------------------------------------------------------ 29 | 30 | sub validate_args { 31 | my ( $self, $opts, $args ) = @_; 32 | 33 | $self->usage_error('Must specify exactly one stack') 34 | if @{$args} != 1; 35 | 36 | $opts->{stack} = $args->[0]; 37 | 38 | return 1; 39 | } 40 | 41 | #------------------------------------------------------------------------------ 42 | 1; 43 | 44 | __END__ 45 | 46 | =pod 47 | 48 | =head1 SYNOPSIS 49 | 50 | pinto --root=REPOSITORY_ROOT new [OPTIONS] STACK 51 | 52 | =head1 DESCRIPTION 53 | 54 | This command creates a new empty stack. 55 | 56 | See the L command to create a new 57 | stack from another one, or the L 58 | command to change a stack's properties after it has been created. 59 | 60 | =head1 COMMAND ARGUMENTS 61 | 62 | The required argument is the name of the stack you wish to create. 63 | Stack names must be alphanumeric plus hyphens and underscores, and 64 | are not case sensitive. 65 | 66 | =head1 COMMAND OPTIONS 67 | 68 | =over 4 69 | 70 | =item --default 71 | 72 | Also mark the new stack as the default stack. 73 | 74 | =item --description=TEXT 75 | 76 | =item -d TEXT 77 | 78 | Use TEXT for the description of the stack. 79 | 80 | =item --target-perl-version=VERSION 81 | 82 | =item --tpv=VERSION 83 | 84 | Sets the target perl version for the stack. Pinto never pulls distributions 85 | for prerequisites that are satisfied by the core of the target perl version. 86 | VERSION must be a valid version number for an existing release of perl 5. 87 | Defaults to the global target Perl version of this repository. 88 | 89 | =back 90 | 91 | =cut 92 | 93 | -------------------------------------------------------------------------------- /lib/App/Pinto/Command/nop.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: do nothing 2 | 3 | package App::Pinto::Command::nop; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | #----------------------------------------------------------------------------- 9 | 10 | use base 'App::Pinto::Command'; 11 | 12 | #------------------------------------------------------------------------------ 13 | 14 | # VERSION 15 | 16 | #------------------------------------------------------------------------------ 17 | 18 | sub opt_spec { 19 | my ( $self, $app ) = @_; 20 | 21 | return ( [ 'sleep=i' => 'seconds to sleep before exiting' ], ); 22 | } 23 | 24 | #------------------------------------------------------------------------------ 25 | 26 | sub validate_args { 27 | my ( $self, $opts, $args ) = @_; 28 | 29 | $self->SUPER::validate_args( $opts, $args ); 30 | 31 | $self->usage_error('Sleep time must be positive integer') 32 | if defined $opts->{sleep} && $opts->{sleep} < 1; 33 | 34 | return 1; 35 | } 36 | 37 | #------------------------------------------------------------------------------ 38 | 1; 39 | 40 | __END__ 41 | 42 | =head1 SYNOPSIS 43 | 44 | pinto --root=REPOSITORY_ROOT nop [OPTIONS] 45 | 46 | =head1 DESCRIPTION 47 | 48 | This command is a no-operation. It puts a shared lock on the 49 | repository, but does not perform any operations. This is really only 50 | used for diagnostic purposes. So don't worry about it too much. 51 | 52 | =head1 COMMAND ARGUMENTS 53 | 54 | None. 55 | 56 | =head1 COMMAND OPTIONS 57 | 58 | =over 4 59 | 60 | =item --sleep N 61 | 62 | Sleep for N seconds before releasing the lock and exiting. Default is 0. 63 | 64 | =back 65 | 66 | =cut 67 | -------------------------------------------------------------------------------- /lib/App/Pinto/Command/rename.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: change the name of a stack 2 | 3 | package App::Pinto::Command::rename; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | #----------------------------------------------------------------------------- 9 | 10 | use base 'App::Pinto::Command'; 11 | 12 | #------------------------------------------------------------------------------ 13 | 14 | # VERSION 15 | 16 | #------------------------------------------------------------------------------ 17 | 18 | sub command_names { return qw(rename mv) } 19 | 20 | #------------------------------------------------------------------------------ 21 | 22 | sub validate_args { 23 | my ( $self, $opts, $args ) = @_; 24 | 25 | $self->usage_error('Must specify STACK and TO_STACK') 26 | if @{$args} != 2; 27 | 28 | $opts->{stack} = $args->[0]; 29 | $opts->{to_stack} = $args->[1]; 30 | 31 | return 1; 32 | } 33 | 34 | #------------------------------------------------------------------------------ 35 | 1; 36 | 37 | __END__ 38 | 39 | =pod 40 | 41 | =head1 SYNOPSIS 42 | 43 | pinto --root=REPOSITORY_ROOT rename [OPTIONS] STACK TO_STACK 44 | 45 | =head1 DESCRIPTION 46 | 47 | This command changes the name of an existing stack. Once the name is 48 | changed, you will not be able to perform commands or access archives 49 | via the old stack name. 50 | 51 | See the L command to create a new empty 52 | stack, or the L command to duplicate 53 | an existing stack, or the L command 54 | to change a stack's properties after it has been created. 55 | 56 | =head1 COMMAND ARGUMENTS 57 | 58 | The two required arguments are the current name and new name of the 59 | stack. Stack names must be alphanumeric plus hyphens and underscores, 60 | and are not case-sensitive. 61 | 62 | =head1 COMMAND OPTIONS 63 | 64 | NONE. 65 | 66 | =cut 67 | -------------------------------------------------------------------------------- /lib/App/Pinto/Command/stacks.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: show available stacks 2 | 3 | package App::Pinto::Command::stacks; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use Pinto::Util qw(interpolate); 9 | 10 | #----------------------------------------------------------------------------- 11 | 12 | use base 'App::Pinto::Command'; 13 | 14 | #------------------------------------------------------------------------------ 15 | 16 | # VERSION 17 | 18 | #------------------------------------------------------------------------------ 19 | 20 | sub opt_spec { 21 | my ( $self, $app ) = @_; 22 | 23 | return ( [ 'format=s' => 'Format of the listing (See POD for details)' ], ); 24 | } 25 | 26 | #------------------------------------------------------------------------------ 27 | 28 | sub validate_args { 29 | my ( $self, $opts, $args ) = @_; 30 | 31 | $self->usage_error('No arguments are allowed') 32 | if @{$args}; 33 | 34 | $opts->{format} = interpolate( $opts->{format} ) 35 | if exists $opts->{format}; 36 | 37 | return 1; 38 | } 39 | 40 | #------------------------------------------------------------------------------ 41 | 1; 42 | 43 | __END__ 44 | 45 | =pod 46 | 47 | =head1 SYNOPSIS 48 | 49 | pinto --root=REPOSITORY_ROOT stacks [OPTIONS] 50 | 51 | =head1 DESCRIPTION 52 | 53 | This command lists the names (and some other details) of all the 54 | stacks currently available in the repository. 55 | 56 | =head1 COMMAND ARGUMENTS 57 | 58 | None. 59 | 60 | =head1 COMMAND OPTIONS 61 | 62 | =over 4 63 | 64 | =item --format=FORMAT_SPECIFICATION 65 | 66 | Format each record in the listing with C-style placeholders. 67 | Valid placeholders are: 68 | 69 | Placeholder Meaning 70 | ----------------------------------------------------------------------------- 71 | %k Stack name 72 | %e Stack description 73 | %M Stack default status (*) = default 74 | %L Stack lock status (!) = locked 75 | %i Stack head revision id prefix 76 | $I Stack head revision id 77 | %g Stack head revision message (full) 78 | %t Stack head revision message title 79 | %b Stack head revision message body 80 | %u Stack head revision committed-on 81 | %j Stack head revision committed-by 82 | %% A literal '%' 83 | 84 | =back 85 | 86 | =cut 87 | -------------------------------------------------------------------------------- /lib/App/Pinto/Command/statistics.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: report statistics about the repository 2 | 3 | package App::Pinto::Command::statistics; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | #----------------------------------------------------------------------------- 9 | 10 | use base 'App::Pinto::Command'; 11 | 12 | #------------------------------------------------------------------------------ 13 | 14 | # VERSION 15 | 16 | #------------------------------------------------------------------------------ 17 | 18 | # TODO: Add a --stack option, just like the "list" command. 19 | 20 | #------------------------------------------------------------------------------ 21 | 22 | sub command_names { return qw( statistics stats ) } 23 | 24 | #------------------------------------------------------------------------------ 25 | 26 | sub validate_args { 27 | my ( $self, $opts, $args ) = @_; 28 | 29 | $self->usage_error('Multiple arguments are not allowed') 30 | if @{$args} > 1; 31 | 32 | $opts->{stack} = $args->[0] 33 | if $args->[0]; 34 | 35 | return 1; 36 | } 37 | 38 | #------------------------------------------------------------------------------ 39 | 1; 40 | 41 | __END__ 42 | 43 | =head1 SYNOPSIS 44 | 45 | pinto --root=REPOSITORY_ROOT statistics [STACK] 46 | 47 | =head1 DESCRIPTION 48 | 49 | !! THIS COMMAND IS EXPERIMENTAL !! 50 | 51 | This command reports some statistics about the repository. 52 | 53 | =head1 COMMAND ARGUMENTS 54 | 55 | The argument is the name of the stack you wish to see the statistics for. If 56 | you do not specify a stack, then the default stack will be used. 57 | 58 | =head1 COMMAND OPTIONS 59 | 60 | None. 61 | 62 | =cut 63 | -------------------------------------------------------------------------------- /lib/App/Pinto/Command/thanks.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: show some gratitude 2 | 3 | package App::Pinto::Command::thanks; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use Path::Class qw(dir); 9 | use Pod::Usage qw(pod2usage); 10 | 11 | use base qw(App::Pinto::Command); 12 | 13 | #------------------------------------------------------------------------------- 14 | 15 | # VERSION 16 | 17 | #------------------------------------------------------------------------------- 18 | 19 | sub execute { 20 | my ( $self, $opts, $args ) = @_; 21 | 22 | my $path; 23 | for my $dir (@INC) { 24 | my $maybe = dir($dir)->file(qw(Pinto Manual Thanks.pod)); 25 | do { $path = $maybe->stringify; last } if -f $maybe; 26 | } 27 | 28 | die "Could not find the Thanks pod.\n" if not $path; 29 | 30 | pod2usage( 31 | -verbose => 99, 32 | -sections => 'THANK YOU', 33 | -input => $path, 34 | -exitval => 0, 35 | ); 36 | 37 | return 1; 38 | } 39 | 40 | #------------------------------------------------------------------------------- 41 | 1; 42 | 43 | __END__ 44 | 45 | 46 | =head1 SYNOPSIS 47 | 48 | pinto thanks 49 | 50 | =head1 DESCRIPTION 51 | 52 | This command shows our appreciation to those who contributed to the Pinto 53 | crowdfunding campaign. 54 | 55 | =cut 56 | -------------------------------------------------------------------------------- /lib/App/Pinto/Command/unlock.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: mark a stack as writable 2 | 3 | package App::Pinto::Command::unlock; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | #----------------------------------------------------------------------------- 9 | 10 | use base 'App::Pinto::Command'; 11 | 12 | #------------------------------------------------------------------------------ 13 | 14 | # VERSION 15 | 16 | #------------------------------------------------------------------------------ 17 | 18 | sub opt_spec { 19 | my ( $self, $app ) = @_; 20 | 21 | return ( [ 'stack|s=s' => 'Unlock this stack' ], ); 22 | } 23 | 24 | #------------------------------------------------------------------------------ 25 | 26 | sub validate_args { 27 | my ( $self, $opts, $args ) = @_; 28 | 29 | $self->usage_error('Multiple arguments are not allowed') 30 | if @{$args} > 1; 31 | 32 | $opts->{stack} = $args->[0] 33 | if $args->[0]; 34 | 35 | return 1; 36 | } 37 | 38 | #------------------------------------------------------------------------------ 39 | 40 | 1; 41 | 42 | __END__ 43 | 44 | =head1 SYNOPSIS 45 | 46 | pinto --root=REPOSITORY_ROOT unlock [OPTIONS] 47 | 48 | =head1 DESCRIPTION 49 | 50 | This command unlocks a stack so that its packages can be changed. 51 | 52 | Unlocking a stack does not cause an event in the revision history, 53 | so reverting the stack will not restore the lock. To lock a stack, 54 | use the L command. 55 | 56 | =head1 COMMAND ARGUMENTS 57 | 58 | As an alternative to the C<--stack> option, you can also specify the 59 | stack as an argument. So the following examples are equivalent: 60 | 61 | pinto --root REPOSITORY_ROOT unlock --stack dev 62 | pinto --root REPOSITORY_ROOT unlock dev 63 | 64 | A stack specified as an argument in this fashion will override any 65 | stack specified with the C<--stack> option. 66 | 67 | =head1 COMMAND OPTIONS 68 | 69 | =over 4 70 | 71 | =item --stack NAME 72 | 73 | =item -s NAME 74 | 75 | Unlock the stack with the given NAME. Defaults to the name of whichever 76 | stack is currently marked as the default stack. Use the 77 | L command to see the stacks in the 78 | repository. 79 | 80 | =back 81 | 82 | =cut 83 | -------------------------------------------------------------------------------- /lib/App/Pinto/Command/verify.pm: -------------------------------------------------------------------------------- 1 | package App::Pinto::Command::verify; 2 | 3 | # ABSTRACT: report archives that are missing 4 | 5 | use strict; 6 | use warnings; 7 | 8 | #----------------------------------------------------------------------------- 9 | 10 | use base 'App::Pinto::Command'; 11 | 12 | #------------------------------------------------------------------------------ 13 | 14 | # VERSION 15 | 16 | #----------------------------------------------------------------------------- 17 | 18 | 1; 19 | 20 | __END__ 21 | 22 | =head1 SYNOPSIS 23 | 24 | pinto --root=REPOSITORY_ROOT verify 25 | 26 | =head1 DESCRIPTION 27 | 28 | This command reports distributions that are defined in the repository 29 | database, but the archives are not actually present. This could occur 30 | when L aborts unexpectedly due to an exception or you terminate 31 | a command prematurely. 32 | 33 | At the moment, it isn't clear how to fix this situation. In a future 34 | release you might be able to replace the archive for the distribution. 35 | But for now, this command simply lets you know if something has gone 36 | wrong in your repository. 37 | 38 | =head1 COMMAND ARGUMENTS 39 | 40 | None 41 | 42 | =head1 COMMAND OPTIONS 43 | 44 | None 45 | 46 | =cut 47 | -------------------------------------------------------------------------------- /lib/Pinto/Action.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Base class for all Actions 2 | 3 | package Pinto::Action; 4 | 5 | use Moose; 6 | use MooseX::StrictConstructor; 7 | use MooseX::Types::Moose qw(Str); 8 | use MooseX::MarkAsMethods ( autoclean => 1 ); 9 | 10 | use Pinto::Result; 11 | use Pinto::Util qw(throw); 12 | use Pinto::Constants qw($PINTO_LOCK_TYPE_SHARED); 13 | 14 | #------------------------------------------------------------------------------ 15 | 16 | # VERSION 17 | 18 | #------------------------------------------------------------------------------ 19 | 20 | with qw( Pinto::Role::Plated ); 21 | 22 | #------------------------------------------------------------------------------ 23 | 24 | has repo => ( 25 | is => 'ro', 26 | isa => 'Pinto::Repository', 27 | required => 1, 28 | ); 29 | 30 | has result => ( 31 | is => 'ro', 32 | isa => 'Pinto::Result', 33 | default => sub { Pinto::Result->new }, 34 | init_arg => undef, 35 | lazy => 1, 36 | ); 37 | 38 | has lock_type => ( 39 | is => 'ro', 40 | isa => Str, 41 | default => $PINTO_LOCK_TYPE_SHARED, 42 | init_arg => undef, 43 | ); 44 | 45 | #------------------------------------------------------------------------------ 46 | 47 | sub BUILD { } 48 | 49 | #------------------------------------------------------------------------------ 50 | 51 | sub execute { throw 'Abstract method' } 52 | 53 | #------------------------------------------------------------------------------ 54 | 55 | __PACKAGE__->meta->make_immutable; 56 | 57 | #------------------------------------------------------------------------------ 58 | 1; 59 | 60 | __END__ 61 | -------------------------------------------------------------------------------- /lib/Pinto/Action/Clean.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Remove orphaned archives 2 | 3 | package Pinto::Action::Clean; 4 | 5 | use Moose; 6 | use MooseX::StrictConstructor; 7 | use MooseX::MarkAsMethods ( autoclean => 1 ); 8 | 9 | #------------------------------------------------------------------------------ 10 | 11 | # VERSION 12 | 13 | #------------------------------------------------------------------------------ 14 | 15 | extends qw( Pinto::Action ); 16 | 17 | #------------------------------------------------------------------------------ 18 | 19 | sub execute { 20 | my ($self) = @_; 21 | 22 | $self->repo->optimize_database; 23 | 24 | my $did_delete = $self->repo->clean_files; 25 | 26 | $self->result->changed if $did_delete; 27 | 28 | return $self->result; 29 | } 30 | 31 | #------------------------------------------------------------------------------ 32 | 33 | __PACKAGE__->meta->make_immutable; 34 | 35 | #----------------------------------------------------------------------------- 36 | 1; 37 | 38 | __END__ 39 | -------------------------------------------------------------------------------- /lib/Pinto/Action/Copy.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Create a new stack by copying another 2 | 3 | package Pinto::Action::Copy; 4 | 5 | use Moose; 6 | use MooseX::StrictConstructor; 7 | use MooseX::Types::Moose qw(Bool Str); 8 | use MooseX::MarkAsMethods ( autoclean => 1 ); 9 | 10 | use Pinto::Types qw(StackName StackObject); 11 | 12 | #------------------------------------------------------------------------------ 13 | 14 | # VERSION 15 | 16 | #------------------------------------------------------------------------------ 17 | 18 | extends qw( Pinto::Action ); 19 | 20 | #------------------------------------------------------------------------------ 21 | 22 | with qw( Pinto::Role::Transactional ); 23 | 24 | #------------------------------------------------------------------------------ 25 | 26 | has stack => ( 27 | is => 'ro', 28 | isa => StackName | StackObject, 29 | required => 1, 30 | ); 31 | 32 | has to_stack => ( 33 | is => 'ro', 34 | isa => StackName, 35 | required => 1, 36 | ); 37 | 38 | has default => ( 39 | is => 'ro', 40 | isa => Bool, 41 | default => 0, 42 | ); 43 | 44 | has lock => ( 45 | is => 'ro', 46 | isa => Bool, 47 | default => 0, 48 | ); 49 | 50 | has description => ( 51 | is => 'ro', 52 | isa => Str, 53 | predicate => 'has_description', 54 | ); 55 | 56 | #------------------------------------------------------------------------------ 57 | 58 | sub execute { 59 | my ($self) = @_; 60 | 61 | my %changes = ( name => $self->to_stack ); 62 | my $orig = $self->repo->get_stack( $self->stack ); 63 | my $copy = $self->repo->copy_stack( stack => $orig, %changes ); 64 | 65 | my $description = 66 | $self->has_description 67 | ? $self->description 68 | : "Copy of stack $orig"; 69 | 70 | $copy->set_description($description); 71 | $copy->mark_as_default if $self->default; 72 | $copy->lock if $self->lock; 73 | 74 | return $self->result->changed; 75 | } 76 | 77 | #------------------------------------------------------------------------------ 78 | 79 | __PACKAGE__->meta->make_immutable; 80 | 81 | #------------------------------------------------------------------------------ 82 | 83 | 1; 84 | 85 | __END__ 86 | -------------------------------------------------------------------------------- /lib/Pinto/Action/Default.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Set the default stack 2 | 3 | package Pinto::Action::Default; 4 | 5 | use Moose; 6 | use MooseX::StrictConstructor; 7 | use MooseX::Types::Moose qw(Bool); 8 | use MooseX::MarkAsMethods ( autoclean => 1 ); 9 | 10 | use Pinto::Types qw(StackName StackObject); 11 | 12 | #------------------------------------------------------------------------------ 13 | 14 | # VERSION 15 | 16 | #------------------------------------------------------------------------------ 17 | 18 | extends qw( Pinto::Action ); 19 | 20 | #------------------------------------------------------------------------------ 21 | 22 | with qw( Pinto::Role::Transactional ); 23 | 24 | #------------------------------------------------------------------------------ 25 | 26 | has stack => ( 27 | is => 'ro', 28 | isa => StackName | StackObject, 29 | ); 30 | 31 | has none => ( 32 | is => 'ro', 33 | isa => Bool, 34 | default => 0, 35 | ); 36 | 37 | #------------------------------------------------------------------------------ 38 | 39 | sub execute { 40 | my ($self) = @_; 41 | 42 | if ( $self->none ) { 43 | my $default_stack = $self->repo->get_stack; 44 | return $self->result if not defined $default_stack; 45 | $default_stack->unmark_as_default; 46 | 47 | } 48 | else { 49 | my $stack = $self->repo->get_stack( $self->stack ); 50 | return $self->result if $stack->is_default; 51 | $stack->mark_as_default; 52 | } 53 | 54 | return $self->result->changed; 55 | } 56 | 57 | #------------------------------------------------------------------------------ 58 | 59 | __PACKAGE__->meta->make_immutable; 60 | 61 | #------------------------------------------------------------------------------ 62 | 63 | 1; 64 | 65 | __END__ 66 | -------------------------------------------------------------------------------- /lib/Pinto/Action/Delete.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Delete archives from the repository 2 | 3 | package Pinto::Action::Delete; 4 | 5 | use Moose; 6 | use MooseX::StrictConstructor; 7 | use MooseX::Types::Moose qw(Bool); 8 | use MooseX::MarkAsMethods ( autoclean => 1 ); 9 | 10 | use Pinto::Util qw(throw); 11 | use Pinto::Types qw(DistributionTargetList); 12 | 13 | #------------------------------------------------------------------------------ 14 | 15 | # VERSION 16 | 17 | #------------------------------------------------------------------------------ 18 | 19 | extends qw( Pinto::Action ); 20 | 21 | #------------------------------------------------------------------------------ 22 | 23 | with qw( Pinto::Role::Transactional ); 24 | 25 | #------------------------------------------------------------------------------ 26 | 27 | has targets => ( 28 | isa => DistributionTargetList, 29 | traits => [qw(Array)], 30 | handles => { targets => 'elements' }, 31 | required => 1, 32 | coerce => 1, 33 | ); 34 | 35 | has force => ( 36 | is => 'ro', 37 | isa => Bool, 38 | default => 0, 39 | ); 40 | 41 | #------------------------------------------------------------------------------ 42 | 43 | sub execute { 44 | my ($self) = @_; 45 | 46 | for my $target ( $self->targets ) { 47 | 48 | my $dist = $self->repo->get_distribution( target => $target ); 49 | 50 | throw "Distribution $target is not in the repository" if not defined $dist; 51 | 52 | $self->notice("Deleting $dist from the repository"); 53 | 54 | $self->repo->delete_distribution( dist => $dist, force => $self->force ); 55 | } 56 | 57 | return $self->result->changed; 58 | } 59 | 60 | #------------------------------------------------------------------------------ 61 | 62 | __PACKAGE__->meta->make_immutable; 63 | 64 | #------------------------------------------------------------------------------ 65 | 66 | 1; 67 | 68 | __END__ 69 | -------------------------------------------------------------------------------- /lib/Pinto/Action/Install.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Install packages from the repository 2 | 3 | package Pinto::Action::Install; 4 | 5 | use Moose; 6 | use MooseX::StrictConstructor; 7 | use MooseX::Types::Moose qw(Bool ArrayRef Str); 8 | use MooseX::MarkAsMethods ( autoclean => 1 ); 9 | 10 | use Pinto::Target; 11 | 12 | #------------------------------------------------------------------------------ 13 | 14 | # VERSION 15 | 16 | #------------------------------------------------------------------------------ 17 | 18 | extends qw( Pinto::Action ); 19 | 20 | #------------------------------------------------------------------------------ 21 | 22 | has targets => ( 23 | isa => ArrayRef [Str], 24 | traits => ['Array'], 25 | handles => { targets => 'elements' }, 26 | required => 1, 27 | ); 28 | 29 | has do_pull => ( 30 | is => 'ro', 31 | isa => Bool, 32 | default => 0, 33 | ); 34 | 35 | has mirror_uri => ( 36 | is => 'ro', 37 | isa => Str, 38 | builder => '_build_mirror_uri', 39 | lazy => 1, 40 | ); 41 | 42 | #------------------------------------------------------------------------------ 43 | 44 | with qw( Pinto::Role::Committable Pinto::Role::Puller Pinto::Role::Installer); 45 | 46 | #------------------------------------------------------------------------------ 47 | 48 | sub _build_mirror_uri { 49 | my ($self) = @_; 50 | 51 | my $stack = $self->stack; 52 | my $stack_dir = defined $stack ? "/stacks/$stack" : ''; 53 | my $mirror_uri = 'file://' . $self->repo->root->absolute . $stack_dir; 54 | 55 | return $mirror_uri; 56 | } 57 | 58 | #------------------------------------------------------------------------------ 59 | 60 | sub execute { 61 | my ($self) = @_; 62 | 63 | my @dists; 64 | if ( $self->do_pull ) { 65 | 66 | for my $target ( $self->targets ) { 67 | next if -d $target or -f $target; 68 | 69 | require Pinto::Target; 70 | $target = Pinto::Target->new($target); 71 | 72 | my $dist = $self->pull( target => $target ); 73 | push @dists, $dist ? $dist : (); 74 | } 75 | } 76 | 77 | return @dists; 78 | } 79 | 80 | #------------------------------------------------------------------------------ 81 | 82 | __PACKAGE__->meta->make_immutable; 83 | 84 | #----------------------------------------------------------------------------- 85 | 1; 86 | 87 | __END__ 88 | -------------------------------------------------------------------------------- /lib/Pinto/Action/Kill.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Permanently delete a stack 2 | 3 | package Pinto::Action::Kill; 4 | 5 | use Moose; 6 | use MooseX::StrictConstructor; 7 | use MooseX::Types::Moose qw(Bool); 8 | use MooseX::MarkAsMethods ( autoclean => 1 ); 9 | 10 | use Pinto::Types qw(StackName StackObject); 11 | 12 | #------------------------------------------------------------------------------ 13 | 14 | # VERSION 15 | 16 | #------------------------------------------------------------------------------ 17 | 18 | extends qw( Pinto::Action ); 19 | 20 | #------------------------------------------------------------------------------ 21 | 22 | with qw( Pinto::Role::Transactional ); 23 | 24 | #------------------------------------------------------------------------------ 25 | 26 | has stack => ( 27 | is => 'ro', 28 | isa => StackName | StackObject, 29 | required => 1, 30 | ); 31 | 32 | has force => ( 33 | is => 'ro', 34 | isa => Bool, 35 | default => 0, 36 | ); 37 | 38 | #------------------------------------------------------------------------------ 39 | 40 | sub execute { 41 | my ($self) = @_; 42 | 43 | my $stack = $self->repo->get_stack( $self->stack ); 44 | 45 | $stack->unlock if $stack->is_locked && $self->force; 46 | 47 | $self->repo->kill_stack( stack => $stack ); 48 | 49 | return $self->result->changed; 50 | } 51 | 52 | #------------------------------------------------------------------------------ 53 | 54 | __PACKAGE__->meta->make_immutable; 55 | 56 | #------------------------------------------------------------------------------ 57 | 58 | 1; 59 | 60 | __END__ 61 | -------------------------------------------------------------------------------- /lib/Pinto/Action/Lock.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Lock a stack to prevent future changes 2 | 3 | package Pinto::Action::Lock; 4 | 5 | use Moose; 6 | use MooseX::StrictConstructor; 7 | use MooseX::MarkAsMethods ( autoclean => 1 ); 8 | 9 | use Pinto::Types qw(StackName StackDefault StackObject); 10 | 11 | #------------------------------------------------------------------------------ 12 | 13 | # VERSION 14 | 15 | #------------------------------------------------------------------------------ 16 | 17 | extends qw( Pinto::Action ); 18 | 19 | #------------------------------------------------------------------------------ 20 | 21 | with qw( Pinto::Role::Transactional ); 22 | 23 | #------------------------------------------------------------------------------ 24 | 25 | has stack => ( 26 | is => 'ro', 27 | isa => StackName | StackDefault | StackObject, 28 | default => undef, 29 | ); 30 | 31 | #------------------------------------------------------------------------------ 32 | 33 | sub execute { 34 | my ($self) = @_; 35 | 36 | my $stack = $self->repo->get_stack( $self->stack ); 37 | 38 | if ( $stack->is_locked ) { 39 | $self->warning("Stack $stack is already locked"); 40 | return $self->result; 41 | } 42 | 43 | $stack->lock; 44 | return $self->result->changed; 45 | } 46 | 47 | #------------------------------------------------------------------------------ 48 | 49 | __PACKAGE__->meta->make_immutable; 50 | 51 | #------------------------------------------------------------------------------ 52 | 53 | 1; 54 | 55 | __END__ 56 | -------------------------------------------------------------------------------- /lib/Pinto/Action/Log.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Show revision log for a stack 2 | 3 | package Pinto::Action::Log; 4 | 5 | use Moose; 6 | use MooseX::StrictConstructor; 7 | use MooseX::Types::Moose qw(Str Bool); 8 | use MooseX::MarkAsMethods ( autoclean => 1 ); 9 | 10 | use Pinto::Difference; 11 | use Pinto::RevisionWalker; 12 | use Pinto::Constants qw(:color); 13 | use Pinto::Types qw(StackName StackDefault DiffStyle); 14 | 15 | #------------------------------------------------------------------------------ 16 | 17 | # VERSION 18 | 19 | #------------------------------------------------------------------------------ 20 | 21 | extends qw( Pinto::Action ); 22 | 23 | #------------------------------------------------------------------------------ 24 | 25 | has stack => ( 26 | is => 'ro', 27 | isa => StackName | StackDefault, 28 | default => undef, 29 | ); 30 | 31 | has with_diffs => ( 32 | is => 'ro', 33 | isa => Bool, 34 | default => 0, 35 | ); 36 | 37 | has diff_style => ( 38 | is => 'ro', 39 | isa => DiffStyle, 40 | predicate => 'has_diff_style', 41 | ); 42 | 43 | 44 | #------------------------------------------------------------------------------ 45 | 46 | sub execute { 47 | my ($self) = @_; 48 | 49 | my $stack = $self->repo->get_stack( $self->stack ); 50 | my $walker = Pinto::RevisionWalker->new( start => $stack->head ); 51 | 52 | while ( my $revision = $walker->next ) { 53 | 54 | my $revid = $revision->to_string("revision %I"); 55 | $self->show( $revid, { color => $PINTO_PALETTE_COLOR_1 } ); 56 | 57 | my $rest = $revision->to_string("Date: %u\nUser: %j\n\n%{4}G\n"); 58 | $self->show($rest); 59 | 60 | if ($self->with_diffs) { 61 | my $parent = ($revision->parents)[0]; 62 | local $ENV{PINTO_DIFF_STYLE} = $self->diff_style if $self->has_diff_style; 63 | my $diff = Pinto::Difference->new(left => $parent, right => $revision); 64 | $self->show($diff); 65 | } 66 | } 67 | 68 | return $self->result; 69 | } 70 | 71 | #------------------------------------------------------------------------------ 72 | 73 | __PACKAGE__->meta->make_immutable; 74 | 75 | #------------------------------------------------------------------------------ 76 | 77 | 1; 78 | 79 | __END__ 80 | -------------------------------------------------------------------------------- /lib/Pinto/Action/Look.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Unpack and open a distribution with your shell 2 | 3 | package Pinto::Action::Look; 4 | 5 | use Moose; 6 | use MooseX::StrictConstructor; 7 | use MooseX::MarkAsMethods ( autoclean => 1 ); 8 | 9 | use Pinto::Shell; 10 | use Pinto::Util qw(throw); 11 | use Pinto::Types qw(StackName StackDefault TargetList); 12 | 13 | use Path::Class qw(file); 14 | 15 | #------------------------------------------------------------------------------ 16 | 17 | # VERSION 18 | 19 | #------------------------------------------------------------------------------ 20 | 21 | extends qw( Pinto::Action ); 22 | 23 | #------------------------------------------------------------------------------ 24 | 25 | has stack => ( 26 | is => 'ro', 27 | isa => StackName | StackDefault, 28 | default => undef, 29 | ); 30 | 31 | has targets => ( 32 | isa => TargetList, 33 | traits => [qw(Array)], 34 | handles => { targets => 'elements' }, 35 | required => 1, 36 | coerce => 1, 37 | ); 38 | 39 | #------------------------------------------------------------------------------ 40 | 41 | sub execute { 42 | my ($self) = @_; 43 | 44 | my $stack = $self->repo->get_stack($self->stack); 45 | 46 | for my $target ( $self->targets ) { 47 | 48 | my $dist; 49 | if ($target->isa('Pinto::Target::Package')) { 50 | $dist = $stack->get_distribution( target => $target ) 51 | or throw "Target $target is not in stack $stack"; 52 | } 53 | else { 54 | $dist = $self->repo->get_distribution( target => $target ) 55 | or throw "Target $target is not in the repository"; 56 | } 57 | 58 | my $shell = Pinto::Shell->new( archive => $dist->native_path ); 59 | $self->diag("Entering $dist with $shell\n"); 60 | $shell->spawn; 61 | } 62 | 63 | return $self->result; 64 | } 65 | 66 | #------------------------------------------------------------------------------ 67 | 68 | __PACKAGE__->meta->make_immutable; 69 | 70 | #------------------------------------------------------------------------------ 71 | 72 | 1; 73 | 74 | __END__ 75 | -------------------------------------------------------------------------------- /lib/Pinto/Action/Merge.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Join two stack histories together 2 | 3 | package Pinto::Action::Merge; 4 | 5 | use Moose; 6 | use MooseX::StrictConstructor; 7 | use MooseX::Types::Moose qw(Bool); 8 | use MooseX::MarkAsMethods ( autoclean => 1 ); 9 | 10 | use Pinto::Util qw(throw); 11 | use Pinto::Types qw(StackName StackObject StackDefault); 12 | 13 | #------------------------------------------------------------------------------ 14 | 15 | # VERSION 16 | 17 | #------------------------------------------------------------------------------ 18 | 19 | extends qw( Pinto::Action ); 20 | 21 | #------------------------------------------------------------------------------ 22 | 23 | with qw( Pinto::Role::Transactional ); 24 | 25 | #------------------------------------------------------------------------------ 26 | 27 | has stack => ( 28 | is => 'ro', 29 | isa => StackName | StackObject, 30 | required => 1, 31 | ); 32 | 33 | 34 | has into_stack => ( 35 | is => 'ro', 36 | isa => StackName | StackObject | StackDefault, 37 | default => undef, 38 | ); 39 | 40 | #------------------------------------------------------------------------------ 41 | 42 | sub execute { 43 | my ($self) = @_; 44 | 45 | my $stack = $self->repo->get_stack($self->stack); 46 | my $from_head = $stack->head; 47 | 48 | my $into_stack = $self->repo->get_stack($self->into_stack); 49 | my $into_head = $into_stack->head; 50 | 51 | return 1 && $self->warning("Both stacks are the same ($into_head)") 52 | if $into_head->id == $from_head->id; 53 | 54 | throw "Recursive merge is not supported yet" 55 | unless $from_head->is_descendant_of($into_head); 56 | 57 | $into_stack->update({head => $from_head->id}); 58 | $into_stack->write_index; 59 | 60 | my $format = '%i: %{40}T'; 61 | $self->diag("Fast-forward..."); 62 | $self->diag("Stack $into_stack was " . $into_head->to_string($format)); 63 | $self->diag("Stack $into_stack now " . $from_head->to_string($format)); 64 | 65 | return 1; 66 | } 67 | 68 | #------------------------------------------------------------------------------ 69 | 70 | __PACKAGE__->meta->make_immutable; 71 | 72 | #------------------------------------------------------------------------------ 73 | 74 | 1; 75 | 76 | __END__ 77 | -------------------------------------------------------------------------------- /lib/Pinto/Action/New.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Create a new empty stack 2 | 3 | package Pinto::Action::New; 4 | 5 | use Moose; 6 | use MooseX::StrictConstructor; 7 | use MooseX::Types::Moose qw(Bool Str); 8 | use MooseX::MarkAsMethods ( autoclean => 1 ); 9 | 10 | use Pinto::Types qw(StackName PerlVersion); 11 | 12 | #------------------------------------------------------------------------------ 13 | 14 | # VERSION 15 | 16 | #------------------------------------------------------------------------------ 17 | 18 | extends qw( Pinto::Action ); 19 | 20 | #------------------------------------------------------------------------------ 21 | 22 | with qw( Pinto::Role::Transactional ); 23 | 24 | #------------------------------------------------------------------------------ 25 | 26 | has stack => ( 27 | is => 'ro', 28 | isa => StackName, 29 | required => 1, 30 | ); 31 | 32 | has default => ( 33 | is => 'ro', 34 | isa => Bool, 35 | default => 0, 36 | ); 37 | 38 | has description => ( 39 | is => 'ro', 40 | isa => Str, 41 | predicate => 'has_description', 42 | ); 43 | 44 | has target_perl_version => ( 45 | is => 'ro', 46 | isa => PerlVersion, 47 | predicate => 'has_target_perl_version', 48 | coerce => 1, 49 | ); 50 | 51 | #------------------------------------------------------------------------------ 52 | 53 | sub execute { 54 | my ($self) = @_; 55 | 56 | my %attrs = ( name => $self->stack ); 57 | my $stack = $self->repo->create_stack(%attrs); 58 | 59 | $stack->set_properties( $stack->default_properties ); 60 | 61 | $stack->set_property( description => $self->description ) 62 | if $self->has_description; 63 | 64 | $stack->set_property( target_perl_version => $self->target_perl_version ) 65 | if $self->has_target_perl_version; 66 | 67 | $stack->mark_as_default 68 | if $self->default; 69 | 70 | return $self->result->changed; 71 | } 72 | 73 | #------------------------------------------------------------------------------ 74 | 75 | __PACKAGE__->meta->make_immutable; 76 | 77 | #------------------------------------------------------------------------------ 78 | 79 | 1; 80 | 81 | __END__ 82 | -------------------------------------------------------------------------------- /lib/Pinto/Action/Nop.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: A no-op action 2 | 3 | package Pinto::Action::Nop; 4 | 5 | use Moose; 6 | use MooseX::StrictConstructor; 7 | use MooseX::Types::Moose qw(Int); 8 | use MooseX::MarkAsMethods ( autoclean => 1 ); 9 | 10 | #------------------------------------------------------------------------------ 11 | 12 | # VERSION 13 | 14 | #------------------------------------------------------------------------------ 15 | 16 | extends qw( Pinto::Action ); 17 | 18 | #------------------------------------------------------------------------------ 19 | 20 | has sleep => ( 21 | is => 'ro', 22 | isa => Int, 23 | default => 0, 24 | ); 25 | 26 | #------------------------------------------------------------------------------ 27 | 28 | sub execute { 29 | my ($self) = @_; 30 | 31 | if ( my $sleep = $self->sleep ) { 32 | $self->notice("Process $$ sleeping for $sleep seconds"); 33 | sleep $self->sleep; 34 | } 35 | 36 | return $self->result; 37 | } 38 | 39 | #------------------------------------------------------------------------------ 40 | 41 | __PACKAGE__->meta->make_immutable(); 42 | 43 | #------------------------------------------------------------------------------ 44 | 45 | =pod 46 | 47 | =head1 DESCRIPTION 48 | 49 | This action does nothing. It can be used to get Pinto to initialize 50 | the store and load the indexes without performing any real operations 51 | on them. 52 | 53 | =cut 54 | 55 | 1; 56 | 57 | __END__ 58 | -------------------------------------------------------------------------------- /lib/Pinto/Action/Pin.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Force a package to stay in a stack 2 | 3 | package Pinto::Action::Pin; 4 | 5 | use Moose; 6 | use MooseX::StrictConstructor; 7 | use MooseX::MarkAsMethods ( autoclean => 1 ); 8 | 9 | use Pinto::Util qw(throw); 10 | use Pinto::Types qw(TargetList); 11 | 12 | #------------------------------------------------------------------------------ 13 | 14 | # VERSION 15 | 16 | #------------------------------------------------------------------------------ 17 | 18 | extends qw( Pinto::Action ); 19 | 20 | #------------------------------------------------------------------------------ 21 | 22 | has targets => ( 23 | isa => TargetList, 24 | traits => [qw(Array)], 25 | handles => { targets => 'elements' }, 26 | required => 1, 27 | coerce => 1, 28 | ); 29 | 30 | #------------------------------------------------------------------------------ 31 | 32 | with qw( Pinto::Role::Committable ); 33 | 34 | #------------------------------------------------------------------------------ 35 | 36 | sub execute { 37 | my ($self) = @_; 38 | 39 | my $stack = $self->stack; 40 | 41 | for my $target ( $self->targets ) { 42 | 43 | throw "$target is not registered on stack $stack" 44 | unless my $dist = $stack->get_distribution( target => $target ); 45 | 46 | $self->notice("Pinning distribution $dist to stack $stack"); 47 | 48 | my $did_pin = $dist->pin( stack => $stack ); 49 | push @{$self->affected}, $dist if $did_pin; 50 | 51 | $self->warning("Distribution $dist is already pinned to stack $stack") 52 | unless $did_pin; 53 | } 54 | 55 | return $self; 56 | } 57 | 58 | #------------------------------------------------------------------------------ 59 | 60 | __PACKAGE__->meta->make_immutable; 61 | 62 | #------------------------------------------------------------------------------ 63 | 64 | 1; 65 | 66 | __END__ 67 | -------------------------------------------------------------------------------- /lib/Pinto/Action/Props.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Show or change stack properties 2 | 3 | package Pinto::Action::Props; 4 | 5 | use Moose; 6 | use MooseX::StrictConstructor; 7 | use MooseX::MarkAsMethods ( autoclean => 1 ); 8 | use MooseX::Types::Moose qw(Str HashRef); 9 | 10 | use String::Format qw(stringf); 11 | 12 | use Pinto::Constants qw(:color); 13 | use Pinto::Util qw(is_system_prop); 14 | use Pinto::Types qw(StackName StackDefault StackObject); 15 | 16 | #------------------------------------------------------------------------------ 17 | 18 | # VERSION 19 | 20 | #------------------------------------------------------------------------------ 21 | 22 | extends qw( Pinto::Action ); 23 | 24 | #------------------------------------------------------------------------------ 25 | 26 | with qw( Pinto::Role::Transactional ); 27 | 28 | #------------------------------------------------------------------------------ 29 | 30 | has stack => ( 31 | is => 'ro', 32 | isa => StackName | StackDefault | StackObject, 33 | ); 34 | 35 | has properties => ( 36 | is => 'ro', 37 | isa => HashRef, 38 | predicate => 'has_properties', 39 | ); 40 | 41 | has format => ( 42 | is => 'ro', 43 | isa => Str, 44 | default => "%p = %v", 45 | ); 46 | 47 | #------------------------------------------------------------------------------ 48 | 49 | sub execute { 50 | my ($self) = @_; 51 | 52 | my $stack = $self->repo->get_stack( $self->stack ); 53 | 54 | $self->has_properties 55 | ? $self->_set_properties($stack) 56 | : $self->_show_properties($stack); 57 | 58 | return $self->result; 59 | } 60 | 61 | #------------------------------------------------------------------------------ 62 | 63 | sub _set_properties { 64 | my ( $self, $target ) = @_; 65 | 66 | $target->set_properties( $self->properties ); 67 | 68 | $self->result->changed; 69 | 70 | return; 71 | } 72 | 73 | #------------------------------------------------------------------------------ 74 | 75 | sub _show_properties { 76 | my ( $self, $target ) = @_; 77 | 78 | my $props = $target->get_properties; 79 | while ( my ( $prop, $value ) = each %{$props} ) { 80 | 81 | my $string = stringf( $self->format, { p => $prop, v => $value } ); 82 | my $color = is_system_prop($prop) ? $PINTO_PALETTE_COLOR_2 : undef; 83 | 84 | $self->show( $string, { color => $color } ); 85 | } 86 | 87 | return; 88 | } 89 | 90 | #------------------------------------------------------------------------------ 91 | 92 | __PACKAGE__->meta->make_immutable; 93 | 94 | #------------------------------------------------------------------------------ 95 | 96 | 1; 97 | 98 | __END__ 99 | -------------------------------------------------------------------------------- /lib/Pinto/Action/Pull.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Pull upstream distributions into the repository 2 | 3 | package Pinto::Action::Pull; 4 | 5 | use Moose; 6 | use MooseX::StrictConstructor; 7 | use MooseX::Types::Moose qw(Bool); 8 | use MooseX::MarkAsMethods ( autoclean => 1 ); 9 | 10 | use Try::Tiny; 11 | 12 | use Pinto::Util qw(throw); 13 | use Pinto::Types qw(TargetList); 14 | 15 | #------------------------------------------------------------------------------ 16 | 17 | # VERSION 18 | 19 | #------------------------------------------------------------------------------ 20 | 21 | extends qw( Pinto::Action ); 22 | 23 | #------------------------------------------------------------------------------ 24 | 25 | has targets => ( 26 | isa => TargetList, 27 | traits => [qw(Array)], 28 | handles => { targets => 'elements' }, 29 | required => 1, 30 | coerce => 1, 31 | ); 32 | 33 | has no_fail => ( 34 | is => 'ro', 35 | isa => Bool, 36 | default => 0, 37 | ); 38 | 39 | #------------------------------------------------------------------------------ 40 | 41 | with qw( Pinto::Role::Committable Pinto::Role::Puller ); 42 | 43 | #------------------------------------------------------------------------------ 44 | 45 | sub execute { 46 | my ($self) = @_; 47 | 48 | my $stack = $self->stack; 49 | 50 | for my $target ( $self->targets ) { 51 | 52 | try { 53 | $self->repo->svp_begin; 54 | $self->notice( "Pulling target $target to stack $stack"); 55 | my ($dist, $did_pull, $did_pull_prereqs) = $self->pull( target => $target ); 56 | $self->notice("Target $target is already on stack $stack") unless $did_pull; 57 | push @{$self->affected}, $dist if $did_pull || $did_pull_prereqs; 58 | } 59 | catch { 60 | throw $_ unless $self->no_fail; 61 | $self->result->failed( because => $_ ); 62 | 63 | $self->repo->svp_rollback; 64 | 65 | $self->error($_); 66 | $self->error("Target $target failed...continuing anyway"); 67 | } 68 | finally { 69 | my ($error) = @_; 70 | $self->repo->svp_release unless $error; 71 | }; 72 | } 73 | 74 | $self->chrome->progress_done; 75 | 76 | return $self; 77 | } 78 | 79 | #------------------------------------------------------------------------------ 80 | 81 | __PACKAGE__->meta->make_immutable; 82 | 83 | #------------------------------------------------------------------------------ 84 | 85 | 1; 86 | 87 | __END__ 88 | -------------------------------------------------------------------------------- /lib/Pinto/Action/Register.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Register packages from existing archives on a stack 2 | 3 | package Pinto::Action::Register; 4 | 5 | use Moose; 6 | use MooseX::StrictConstructor; 7 | use MooseX::Types::Moose qw(Bool); 8 | use MooseX::MarkAsMethods ( autoclean => 1 ); 9 | 10 | use Pinto::Util qw(throw); 11 | use Pinto::Types qw(DistributionTargetList); 12 | 13 | #------------------------------------------------------------------------------ 14 | 15 | # VERSION 16 | 17 | #------------------------------------------------------------------------------ 18 | 19 | extends qw( Pinto::Action ); 20 | 21 | #------------------------------------------------------------------------------ 22 | 23 | has targets => ( 24 | isa => DistributionTargetList, 25 | traits => [qw(Array)], 26 | handles => { targets => 'elements' }, 27 | required => 1, 28 | coerce => 1, 29 | ); 30 | 31 | has pin => ( 32 | is => 'ro', 33 | isa => Bool, 34 | default => 0, 35 | ); 36 | 37 | #------------------------------------------------------------------------------ 38 | 39 | with qw( Pinto::Role::Committable ); 40 | 41 | #------------------------------------------------------------------------------ 42 | 43 | sub execute { 44 | my ($self) = @_; 45 | 46 | my $stack = $self->stack; 47 | 48 | for my $target ( $self->targets ) { 49 | 50 | throw "Distribution $target is not in the repository" 51 | unless my $dist = $self->repo->get_distribution( target => $target ); 52 | 53 | $self->notice("Registering distribution $dist on stack $stack"); 54 | 55 | my $did_register = $dist->register( stack => $stack, pin => $self->pin ); 56 | push @{$self->affected}, $dist if $did_register; 57 | 58 | $self->warning("Distribution $dist is already registered on stack $stack") 59 | unless $did_register; 60 | } 61 | 62 | return $self; 63 | } 64 | 65 | #------------------------------------------------------------------------------ 66 | 67 | __PACKAGE__->meta->make_immutable; 68 | 69 | #------------------------------------------------------------------------------ 70 | 71 | 1; 72 | 73 | __END__ 74 | -------------------------------------------------------------------------------- /lib/Pinto/Action/Rename.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Change the name of a stack 2 | 3 | package Pinto::Action::Rename; 4 | 5 | use Moose; 6 | use MooseX::StrictConstructor; 7 | use MooseX::MarkAsMethods ( autoclean => 1 ); 8 | 9 | use Pinto::Types qw(StackName StackObject); 10 | 11 | #------------------------------------------------------------------------------ 12 | 13 | # VERSION 14 | 15 | #------------------------------------------------------------------------------ 16 | 17 | extends qw( Pinto::Action ); 18 | 19 | #------------------------------------------------------------------------------ 20 | 21 | with qw( Pinto::Role::Transactional ); 22 | 23 | #------------------------------------------------------------------------------ 24 | 25 | has stack => ( 26 | is => 'ro', 27 | isa => StackName | StackObject, 28 | required => 1, 29 | ); 30 | 31 | has to_stack => ( 32 | is => 'ro', 33 | isa => StackName, 34 | required => 1, 35 | ); 36 | 37 | #------------------------------------------------------------------------------ 38 | 39 | sub execute { 40 | my ($self) = @_; 41 | 42 | my $stack = $self->repo->get_stack( $self->stack ); 43 | 44 | $self->repo->rename_stack( stack => $stack, to => $self->to_stack ); 45 | 46 | return $self->result->changed; 47 | } 48 | 49 | #------------------------------------------------------------------------------ 50 | 51 | __PACKAGE__->meta->make_immutable; 52 | 53 | #------------------------------------------------------------------------------ 54 | 55 | 1; 56 | 57 | __END__ 58 | -------------------------------------------------------------------------------- /lib/Pinto/Action/Reset.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Reset stack to a prior revision 2 | 3 | package Pinto::Action::Reset; 4 | 5 | use Moose; 6 | use MooseX::StrictConstructor; 7 | use MooseX::Types::Moose qw(Bool); 8 | use MooseX::MarkAsMethods ( autoclean => 1 ); 9 | 10 | use Pinto::Util qw(throw); 11 | use Pinto::Types qw(StackName StackDefault RevisionID); 12 | 13 | #------------------------------------------------------------------------------ 14 | 15 | # VERSION 16 | 17 | #------------------------------------------------------------------------------ 18 | 19 | extends qw( Pinto::Action ); 20 | 21 | #------------------------------------------------------------------------------ 22 | 23 | with qw( Pinto::Role::Transactional ); 24 | 25 | #------------------------------------------------------------------------------ 26 | 27 | has stack => ( 28 | is => 'ro', 29 | isa => StackName | StackDefault, 30 | default => undef, 31 | ); 32 | 33 | has revision => ( 34 | is => 'ro', 35 | isa => RevisionID, 36 | required => 1, 37 | coerce => 1, 38 | ); 39 | 40 | has force => ( 41 | is => 'ro', 42 | isa => Bool, 43 | default => 0, 44 | ); 45 | 46 | #------------------------------------------------------------------------------ 47 | 48 | sub execute { 49 | my ($self) = @_; 50 | 51 | my $rev = $self->repo->get_revision($self->revision); 52 | my $stack = $self->repo->get_stack($self->stack); 53 | my $head = $stack->head; 54 | 55 | throw "Revision $rev is the head of stack $stack" 56 | if $rev->id == $head->id; 57 | 58 | throw "Revision $rev is not an ancestor of stack $stack" 59 | if !$rev->is_ancestor_of($head) && !$self->force; 60 | 61 | $stack->set_head($rev); 62 | $stack->write_index; 63 | 64 | my $format = '%i: %{40}T'; 65 | $self->diag("Stack $stack was " . $head->to_string($format)); 66 | $self->diag("Stack $stack now " . $rev->to_string($format)); 67 | 68 | return 1; 69 | } 70 | 71 | #------------------------------------------------------------------------------ 72 | 73 | __PACKAGE__->meta->make_immutable; 74 | 75 | #------------------------------------------------------------------------------ 76 | 77 | 1; 78 | 79 | __END__ 80 | -------------------------------------------------------------------------------- /lib/Pinto/Action/Roots.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Show the roots of a stack 2 | 3 | package Pinto::Action::Roots; 4 | 5 | use Moose; 6 | use MooseX::StrictConstructor; 7 | use MooseX::Types::Moose qw(Str); 8 | use MooseX::MarkAsMethods ( autoclean => 1 ); 9 | 10 | use Pinto::Util qw(whine); 11 | use Pinto::Types qw(StackName StackDefault StackObject); 12 | 13 | #------------------------------------------------------------------------------ 14 | 15 | # VERSION 16 | 17 | #------------------------------------------------------------------------------ 18 | 19 | extends qw( Pinto::Action ); 20 | 21 | #------------------------------------------------------------------------------ 22 | 23 | has stack => ( 24 | is => 'ro', 25 | isa => StackName | StackDefault | StackObject, 26 | default => undef, 27 | ); 28 | 29 | has format => ( 30 | is => 'ro', 31 | isa => Str, 32 | default => '%a/%f', 33 | lazy => 1, 34 | ); 35 | 36 | #------------------------------------------------------------------------------ 37 | 38 | sub execute { 39 | my ($self) = @_; 40 | 41 | my $stack = $self->repo->get_stack($self->stack); 42 | my @roots = sort map { $_->to_string($self->format) } $stack->roots; 43 | $self->show($_) for @roots; 44 | 45 | return $self->result; 46 | } 47 | 48 | #------------------------------------------------------------------------------ 49 | 50 | __PACKAGE__->meta->make_immutable; 51 | 52 | #------------------------------------------------------------------------------ 53 | 54 | 1; 55 | 56 | __END__ 57 | -------------------------------------------------------------------------------- /lib/Pinto/Action/Stacks.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: List known stacks in the repository 2 | 3 | package Pinto::Action::Stacks; 4 | 5 | use Moose; 6 | use MooseX::StrictConstructor; 7 | use MooseX::Types::Moose qw(Str); 8 | use MooseX::MarkAsMethods ( autoclean => 1 ); 9 | 10 | use List::Util qw(max); 11 | 12 | use Pinto::Constants qw(:color); 13 | 14 | #------------------------------------------------------------------------------ 15 | 16 | # VERSION 17 | 18 | #------------------------------------------------------------------------------ 19 | 20 | extends 'Pinto::Action'; 21 | 22 | #------------------------------------------------------------------------------ 23 | 24 | has format => ( 25 | is => 'ro', 26 | isa => Str, 27 | ); 28 | 29 | #------------------------------------------------------------------------------ 30 | 31 | sub execute { 32 | my ($self) = @_; 33 | 34 | my @stacks = sort { $a cmp $b } $self->repo->get_all_stacks; 35 | 36 | my $max_name = max( map { length( $_->name ) } @stacks ) || 0; 37 | my $max_user = max( map { length( $_->head->username ) } @stacks ) || 0; 38 | 39 | my $format = $self->format || "%M%L %-${max_name}k %u %-{$max_user}j %i: %{40}T"; 40 | 41 | for my $stack (@stacks) { 42 | my $string = $stack->to_string($format); 43 | 44 | my $color = 45 | $stack->is_default ? $PINTO_PALETTE_COLOR_0 46 | : $stack->is_locked ? $PINTO_PALETTE_COLOR_2 47 | : undef; 48 | 49 | $self->show( $string, { color => $color } ); 50 | } 51 | 52 | return $self->result; 53 | } 54 | 55 | #------------------------------------------------------------------------------ 56 | 57 | __PACKAGE__->meta->make_immutable; 58 | 59 | #------------------------------------------------------------------------------ 60 | 61 | 1; 62 | 63 | __END__ 64 | -------------------------------------------------------------------------------- /lib/Pinto/Action/Statistics.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Report statistics about the repository 2 | 3 | package Pinto::Action::Statistics; 4 | 5 | use Moose; 6 | use MooseX::StrictConstructor; 7 | use MooseX::MarkAsMethods ( autoclean => 1 ); 8 | 9 | use Pinto::Types qw(StackName StackDefault StackObject); 10 | use Pinto::Statistics; 11 | 12 | #------------------------------------------------------------------------------ 13 | 14 | # VERSION 15 | 16 | #------------------------------------------------------------------------------ 17 | 18 | extends qw( Pinto::Action ); 19 | 20 | #------------------------------------------------------------------------------ 21 | 22 | has stack => ( 23 | is => 'ro', 24 | isa => StackName | StackDefault | StackObject, 25 | default => undef, 26 | ); 27 | 28 | #------------------------------------------------------------------------------ 29 | 30 | sub execute { 31 | my ($self) = @_; 32 | 33 | my $stack = $self->repo->get_stack( $self->stack ); 34 | 35 | my $stats = Pinto::Statistics->new( stack => $stack ); 36 | 37 | $self->show( $stats->to_string ); 38 | 39 | return $self->result; 40 | } 41 | 42 | #------------------------------------------------------------------------------ 43 | 44 | __PACKAGE__->meta->make_immutable(); 45 | 46 | #------------------------------------------------------------------------------ 47 | 48 | 1; 49 | 50 | __END__ 51 | -------------------------------------------------------------------------------- /lib/Pinto/Action/Unlock.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Unlock a stack to allow future changes 2 | 3 | package Pinto::Action::Unlock; 4 | 5 | use Moose; 6 | use MooseX::StrictConstructor; 7 | use MooseX::MarkAsMethods ( autoclean => 1 ); 8 | 9 | use Pinto::Types qw(StackName StackDefault StackObject); 10 | 11 | #------------------------------------------------------------------------------ 12 | 13 | # VERSION 14 | 15 | #------------------------------------------------------------------------------ 16 | 17 | extends qw( Pinto::Action ); 18 | 19 | #------------------------------------------------------------------------------ 20 | 21 | with qw( Pinto::Role::Transactional ); 22 | 23 | #------------------------------------------------------------------------------ 24 | 25 | has stack => ( 26 | is => 'ro', 27 | isa => StackName | StackDefault | StackObject, 28 | default => undef, 29 | ); 30 | 31 | #------------------------------------------------------------------------------ 32 | 33 | sub execute { 34 | my ($self) = @_; 35 | 36 | my $stack = $self->repo->get_stack( $self->stack ); 37 | 38 | if ( !$stack->is_locked ) { 39 | $self->warning("Stack $stack is not locked"); 40 | return $self->result; 41 | } 42 | 43 | $stack->unlock; 44 | return $self->result->changed; 45 | } 46 | 47 | #------------------------------------------------------------------------------ 48 | 49 | __PACKAGE__->meta->make_immutable; 50 | 51 | #------------------------------------------------------------------------------ 52 | 53 | 1; 54 | 55 | __END__ 56 | -------------------------------------------------------------------------------- /lib/Pinto/Action/Unpin.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Loosen a package that has been pinned 2 | 3 | package Pinto::Action::Unpin; 4 | 5 | use Moose; 6 | use MooseX::StrictConstructor; 7 | use MooseX::MarkAsMethods ( autoclean => 1 ); 8 | 9 | use Pinto::Util qw(throw); 10 | use Pinto::Types qw(TargetList); 11 | 12 | #------------------------------------------------------------------------------ 13 | 14 | # VERSION 15 | 16 | #------------------------------------------------------------------------------ 17 | 18 | extends qw( Pinto::Action ); 19 | 20 | #------------------------------------------------------------------------------ 21 | 22 | has targets => ( 23 | isa => TargetList, 24 | traits => [qw(Array)], 25 | handles => { targets => 'elements' }, 26 | required => 1, 27 | coerce => 1, 28 | ); 29 | 30 | #------------------------------------------------------------------------------ 31 | 32 | with qw( Pinto::Role::Committable ); 33 | 34 | #------------------------------------------------------------------------------ 35 | 36 | sub execute { 37 | my ($self) = @_; 38 | 39 | my $stack = $self->stack; 40 | 41 | for my $target ( $self->targets ) { 42 | 43 | throw "$target is not registered on stack $stack" 44 | unless my $dist = $stack->get_distribution( target => $target ); 45 | 46 | $self->notice("Unpinning distribution $dist from stack $stack"); 47 | 48 | my $did_unpin = $dist->unpin( stack => $stack ); 49 | push @{$self->affected}, $dist if $did_unpin; 50 | 51 | $self->warning("Distribution $dist is not pinned to stack $stack") 52 | unless $did_unpin; 53 | } 54 | 55 | return $self; 56 | } 57 | 58 | #------------------------------------------------------------------------------ 59 | 60 | __PACKAGE__->meta->make_immutable; 61 | 62 | #------------------------------------------------------------------------------ 63 | 64 | 1; 65 | 66 | __END__ 67 | -------------------------------------------------------------------------------- /lib/Pinto/Action/Unregister.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Unregister packages from a stack 2 | 3 | package Pinto::Action::Unregister; 4 | 5 | use Moose; 6 | use MooseX::StrictConstructor; 7 | use MooseX::Types::Moose qw(Bool); 8 | use MooseX::MarkAsMethods ( autoclean => 1 ); 9 | 10 | use Pinto::Util qw(throw); 11 | use Pinto::Types qw(TargetList); 12 | 13 | #------------------------------------------------------------------------------ 14 | 15 | # VERSION 16 | 17 | #------------------------------------------------------------------------------ 18 | 19 | extends qw( Pinto::Action ); 20 | 21 | #------------------------------------------------------------------------------ 22 | 23 | has targets => ( 24 | isa => TargetList, 25 | traits => [qw(Array)], 26 | handles => { targets => 'elements' }, 27 | required => 1, 28 | coerce => 1, 29 | ); 30 | 31 | has force => ( 32 | is => 'ro', 33 | isa => Bool, 34 | default => 0, 35 | ); 36 | 37 | #------------------------------------------------------------------------------ 38 | 39 | with qw( Pinto::Role::Committable ); 40 | 41 | #------------------------------------------------------------------------------ 42 | 43 | sub execute { 44 | my ($self) = @_; 45 | 46 | my $stack = $self->stack; 47 | 48 | for my $target ( $self->targets ) { 49 | 50 | throw "Target $target is not registered on stack $stack" 51 | unless my $dist = $stack->get_distribution( target => $target ); 52 | 53 | $self->notice("Unregistering distribution $dist from stack $stack"); 54 | 55 | $dist->unregister( stack => $stack, force => $self->force ); 56 | push @{$self->affected}, $dist; 57 | } 58 | 59 | return $self; 60 | } 61 | 62 | #------------------------------------------------------------------------------ 63 | 64 | __PACKAGE__->meta->make_immutable; 65 | 66 | #------------------------------------------------------------------------------ 67 | 68 | 1; 69 | 70 | __END__ 71 | -------------------------------------------------------------------------------- /lib/Pinto/Action/Verify.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Report distributions that are missing 2 | 3 | package Pinto::Action::Verify; 4 | 5 | use Moose; 6 | use MooseX::StrictConstructor; 7 | use MooseX::MarkAsMethods ( autoclean => 1 ); 8 | 9 | use Pinto::Util qw(throw); 10 | 11 | #------------------------------------------------------------------------------ 12 | 13 | # VERSION 14 | 15 | #------------------------------------------------------------------------------ 16 | 17 | extends qw( Pinto::Action ); 18 | 19 | #------------------------------------------------------------------------------ 20 | 21 | sub execute { 22 | my ($self) = @_; 23 | 24 | my $dist_rs = $self->repo->db->schema->distribution_rs; 25 | 26 | my $missing = 0; 27 | while ( my $dist = $dist_rs->next ) { 28 | 29 | if ( not -e $dist->native_path ) { 30 | $self->error("Missing distribution $dist"); 31 | $missing++; 32 | } 33 | } 34 | 35 | throw("$missing archives are missing") if $missing; 36 | 37 | return $self->result; 38 | } 39 | 40 | #------------------------------------------------------------------------------ 41 | 42 | __PACKAGE__->meta->make_immutable; 43 | 44 | #------------------------------------------------------------------------------ 45 | 46 | 1; 47 | 48 | __END__ 49 | -------------------------------------------------------------------------------- /lib/Pinto/ArchiveUnpacker.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Unpack an archive into a temporary directory 2 | 3 | package Pinto::ArchiveUnpacker; 4 | 5 | use Moose; 6 | use MooseX::StrictConstructor; 7 | use MooseX::Types::Moose qw(Bool); 8 | use MooseX::MarkAsMethods ( autoclean => 1 ); 9 | 10 | use Cwd qw(getcwd); 11 | use Cwd::Guard qw(cwd_guard); 12 | use Path::Class qw(dir); 13 | use Archive::Extract; 14 | use File::Temp; 15 | 16 | use Pinto::Types qw(File); 17 | use Pinto::Util qw(debug throw); 18 | 19 | #----------------------------------------------------------------------------- 20 | 21 | # VERSION 22 | 23 | #----------------------------------------------------------------------------- 24 | 25 | has archive => ( 26 | is => 'ro', 27 | isa => File, 28 | required => 1, 29 | coerce => 1, 30 | ); 31 | 32 | has temp_dir => ( 33 | is => 'ro', 34 | isa => 'File::Temp::Dir', 35 | default => sub { File::Temp->newdir( CLEANUP => $_[0]->cleanup ) }, 36 | lazy => 1, 37 | ); 38 | 39 | has cleanup => ( 40 | is => 'ro', 41 | isa => Bool, 42 | default => 1, 43 | ); 44 | 45 | #----------------------------------------------------------------------------- 46 | 47 | sub unpack { 48 | my ($self) = @_; 49 | 50 | my $archive = $self->archive; 51 | my $temp_dir = $self->temp_dir->dirname; 52 | my $cwd_guard = cwd_guard(getcwd); # Archive::Extract will chdir 53 | 54 | local $Archive::Extract::PREFER_BIN = 1; 55 | local $Archive::Extract::DEBUG = 1 if ( $ENV{PINTO_DEBUG} || 0 ) > 1; 56 | 57 | my $ae = Archive::Extract->new( archive => $archive ); 58 | 59 | debug "Unpacking $archive into $temp_dir"; 60 | 61 | my $ok = $ae->extract( to => $temp_dir ); 62 | throw "Failed to unpack $archive: " . $ae->error if not $ok; 63 | 64 | my @children = dir($temp_dir)->children; 65 | return @children == 1 && -d $children[0] ? $children[0] : dir($temp_dir); 66 | } 67 | 68 | #----------------------------------------------------------------------------- 69 | 70 | __PACKAGE__->meta->make_immutable; 71 | 72 | #----------------------------------------------------------------------------- 73 | 74 | 1; 75 | 76 | __END__ 77 | -------------------------------------------------------------------------------- /lib/Pinto/Chrome.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Base class for interactive interfaces 2 | 3 | package Pinto::Chrome; 4 | 5 | use Moose; 6 | use MooseX::StrictConstructor; 7 | use MooseX::Types::Moose qw(Int Bool); 8 | use MooseX::MarkAsMethods ( autoclean => 1 ); 9 | 10 | #----------------------------------------------------------------------------- 11 | 12 | # VERSION 13 | 14 | #----------------------------------------------------------------------------- 15 | 16 | has verbose => ( 17 | is => 'ro', 18 | isa => Int, 19 | default => 0, 20 | ); 21 | 22 | has quiet => ( 23 | is => 'ro', 24 | isa => Bool, 25 | default => 0, 26 | ); 27 | 28 | #----------------------------------------------------------------------------- 29 | 30 | sub show { return 1 } 31 | 32 | #----------------------------------------------------------------------------- 33 | 34 | sub diag { return 1 } 35 | 36 | #----------------------------------------------------------------------------- 37 | 38 | sub edit { return $_[1] } 39 | 40 | #----------------------------------------------------------------------------- 41 | 42 | sub show_progress { return 1 } 43 | 44 | #----------------------------------------------------------------------------- 45 | 46 | sub progress_done { return 1 } 47 | 48 | #----------------------------------------------------------------------------- 49 | 50 | sub should_render_diag { 51 | my ( $self, $level ) = @_; 52 | 53 | return 1 if $level == 0; # Always, always display errors 54 | return 0 if $self->quiet; # Don't display anything else if quiet 55 | return 1 if $self->verbose + 1 >= $level; 56 | return 0; 57 | } 58 | 59 | #----------------------------------------------------------------------------- 60 | 61 | sub diag_levels { return qw(error warning notice info) } 62 | 63 | #----------------------------------------------------------------------------- 64 | 65 | my @levels = __PACKAGE__->diag_levels; 66 | __generate_diag_method( $levels[$_], $_ ) for ( 0 .. $#levels ); 67 | 68 | #----------------------------------------------------------------------------- 69 | 70 | sub __generate_diag_method { 71 | my ( $method_name, $diag_level ) = @_; 72 | 73 | my $template = <<'END_METHOD'; 74 | sub %s { 75 | my ($self, $msg, $opts) = @_; 76 | return unless $self->should_render_diag(%s); 77 | $self->diag($msg, $opts); 78 | } 79 | END_METHOD 80 | 81 | eval sprintf $template, $method_name, $diag_level; 82 | croak $@ if $@; 83 | } 84 | 85 | #----------------------------------------------------------------------------- 86 | 87 | __PACKAGE__->meta->make_immutable; 88 | 89 | #----------------------------------------------------------------------------- 90 | 1; 91 | 92 | __END__ 93 | 94 | 95 | -------------------------------------------------------------------------------- /lib/Pinto/Chrome/Net.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Interface for network-based interaction 2 | 3 | package Pinto::Chrome::Net; 4 | 5 | use Moose; 6 | use MooseX::StrictConstructor; 7 | use MooseX::MarkAsMethods ( autoclean => 1 ); 8 | 9 | use Pinto::Types qw(Io); 10 | use Pinto::Util qw(itis); 11 | use Pinto::Constants qw(:protocol); 12 | 13 | #----------------------------------------------------------------------------- 14 | 15 | # VERSION 16 | 17 | #----------------------------------------------------------------------------- 18 | 19 | extends qw( Pinto::Chrome::Term ); 20 | 21 | #----------------------------------------------------------------------------- 22 | 23 | has stdout => ( 24 | is => 'ro', 25 | isa => Io, 26 | required => 1, 27 | coerce => 1, 28 | ); 29 | 30 | has stderr => ( 31 | is => 'ro', 32 | isa => Io, 33 | required => 1, 34 | coerce => 1, 35 | ); 36 | 37 | #----------------------------------------------------------------------------- 38 | 39 | sub diag { 40 | my ( $self, $msg, $opts ) = @_; 41 | 42 | $opts ||= {}; 43 | 44 | $msg = $msg->() if ref $msg eq 'CODE'; 45 | 46 | if ( itis( $msg, 'Pinto::Exception' ) ) { 47 | 48 | # Show full stack trace if we are debugging 49 | $msg = $ENV{PINTO_DEBUG} ? $msg->as_string : $msg->message; 50 | } 51 | 52 | chomp $msg; 53 | $msg = $self->colorize( $msg, $opts->{color} ); 54 | $msg .= "\n" unless $opts->{no_newline}; 55 | 56 | # Prepend prefix to each line (not just at the start of the message) 57 | # The prefix is used by Pinto::Remote to distinguish between 58 | # messages that go to stderr and those that should go to stdout 59 | $msg =~ s/^/$PINTO_PROTOCOL_DIAG_PREFIX/gmx; 60 | 61 | print { $self->stderr } $msg or croak $!; 62 | } 63 | 64 | #----------------------------------------------------------------------------- 65 | 66 | sub show_progress { 67 | my ($self) = @_; 68 | 69 | return if not $self->should_render_progress; 70 | 71 | $self->stderr->autoflush; # Make sure pipes are hot 72 | 73 | print { $self->stderr } $PINTO_PROTOCOL_PROGRESS_MESSAGE . "\n" or croak $!; 74 | } 75 | 76 | #----------------------------------------------------------------------------- 77 | 78 | sub should_render_progress { 79 | my ($self) = @_; 80 | 81 | return 0 if $self->verbose; 82 | return 0 if $self->quiet; 83 | return 1; 84 | } 85 | 86 | #----------------------------------------------------------------------------- 87 | 88 | sub edit { 89 | my ( $self, $document ) = @_; 90 | 91 | return $document; # TODO! 92 | } 93 | 94 | #----------------------------------------------------------------------------- 95 | 96 | __PACKAGE__->meta->make_immutable; 97 | 98 | #----------------------------------------------------------------------------- 99 | 1; 100 | 101 | __END__ 102 | 103 | 104 | -------------------------------------------------------------------------------- /lib/Pinto/DifferenceEntry.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Represents one addition or deletion in a diff 2 | 3 | package Pinto::DifferenceEntry; 4 | 5 | use Moose; 6 | use MooseX::StrictConstructor; 7 | use MooseX::MarkAsMethods ( autoclean => 1 ); 8 | use MooseX::Types::Moose qw(Str); 9 | 10 | use String::Format; 11 | 12 | #------------------------------------------------------------------------------ 13 | 14 | use overload ( 15 | q{""} => 'to_string', 16 | 'cmp' => 'string_compare', 17 | ); 18 | 19 | #------------------------------------------------------------------------------ 20 | 21 | # VERSION 22 | 23 | #------------------------------------------------------------------------------ 24 | 25 | # TODO: Consider breaking this into separate Addition and Deletion subclasses, 26 | # rather than using an "op" attribute to indicate which kind it is. That sort 27 | # of "type" flag is always a code smell to me. 28 | 29 | #------------------------------------------------------------------------------ 30 | 31 | has op => ( 32 | is => 'ro', 33 | isa => Str, 34 | required => 1 35 | ); 36 | 37 | has registration => ( 38 | is => 'ro', 39 | isa => 'Pinto::Schema::Result::Registration', 40 | required => 1, 41 | ); 42 | 43 | #------------------------------------------------------------------------------ 44 | 45 | sub is_addition { shift->op eq '+' } 46 | 47 | sub is_deletion { shift->op eq '-' } 48 | 49 | #------------------------------------------------------------------------------ 50 | 51 | sub to_string { 52 | my ( $self, $format ) = @_; 53 | 54 | my %fspec = ( o => $self->op ); 55 | 56 | $format ||= $self->default_format; 57 | return $self->registration->to_string( String::Format::stringf($format, %fspec) ); 58 | } 59 | 60 | #------------------------------------------------------------------------------ 61 | 62 | sub default_format { 63 | my ($self) = @_; 64 | 65 | return '%o[%F] %-40p %12v %a/%f', 66 | } 67 | 68 | #------------------------------------------------------------------------------ 69 | 70 | sub string_compare { 71 | my ( $self, $other ) = @_; 72 | 73 | return $self->registration->distribution->name 74 | cmp $other->registration->distribution->name; 75 | } 76 | 77 | #------------------------------------------------------------------------------ 78 | 79 | __PACKAGE__->meta->make_immutable; 80 | 81 | #------------------------------------------------------------------------------ 82 | 1; 83 | -------------------------------------------------------------------------------- /lib/Pinto/Editor.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Utility class for authoring commit messages 2 | 3 | package Pinto::Editor; 4 | 5 | use Moose; 6 | use File::Temp; 7 | use Pinto::Editor::Edit; 8 | 9 | #----------------------------------------------------------------------------- 10 | 11 | # VERSION 12 | 13 | #----------------------------------------------------------------------------- 14 | 15 | sub EDITOR { 16 | return $ENV{VISUAL} || $ENV{EDITOR}; 17 | } 18 | 19 | #----------------------------------------------------------------------------- 20 | 21 | our $__singleton__; 22 | sub __singleton__ { 23 | return $__singleton__ ||=__PACKAGE__->new; 24 | } 25 | 26 | #----------------------------------------------------------------------------- 27 | 28 | sub edit_file { 29 | my $self = shift; 30 | my $file = shift; 31 | die "*** Missing editor (No \$VISUAL or \$EDITOR)\n" unless my $editor = $self->EDITOR; 32 | my $rc = system $editor, $file; 33 | unless ( $rc == 0 ) { 34 | my ($exit_value, $signal, $core_dump); 35 | $exit_value = $? >> 8; 36 | $signal = $? & 127; 37 | $core_dump = $? & 128; 38 | die "Error during edit ($editor): exit value($exit_value), signal($signal), core_dump($core_dump): $!"; 39 | } 40 | } 41 | 42 | #----------------------------------------------------------------------------- 43 | 44 | sub edit { 45 | my $self = shift; 46 | $self = $self->__singleton__ unless blessed $self; 47 | my %given = @_; 48 | 49 | my $document = delete $given{document}; 50 | $document = '' unless defined $document; 51 | 52 | my $file = delete $given{file}; 53 | $file = $self->tmp unless defined $file; 54 | 55 | my $edit = Pinto::Editor::Edit->new( 56 | editor => $self, 57 | file => $file, 58 | document => $document, 59 | %given, # process, split, ... 60 | ); 61 | 62 | return $edit->edit; 63 | } 64 | 65 | #----------------------------------------------------------------------------- 66 | 67 | sub tmp { return File::Temp->new( unlink => 1 ) } 68 | 69 | #----------------------------------------------------------------------------- 70 | 1; 71 | 72 | __END__ 73 | 74 | #----------------------------------------------------------------------------- 75 | 76 | =pod 77 | 78 | =head1 DESCRIPTION 79 | 80 | This is a forked version of L which does not use the deprecated 81 | module L. My thanks to Robert Krimen for authoring the original. 82 | No user-servicable parts in here. 83 | 84 | =cut 85 | -------------------------------------------------------------------------------- /lib/Pinto/Exception.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Base class for Pinto exceptions 2 | 3 | package Pinto::Exception; 4 | 5 | use Moose; 6 | use MooseX::MarkAsMethods ( autoclean => 1 ); 7 | 8 | #------------------------------------------------------------------------------ 9 | 10 | # VERSION 11 | 12 | #------------------------------------------------------------------------------ 13 | 14 | extends qw(Throwable::Error); 15 | 16 | #------------------------------------------------------------------------------ 17 | 18 | __PACKAGE__->meta->make_immutable; 19 | 20 | #------------------------------------------------------------------------------ 21 | 1; 22 | 23 | __END__ 24 | -------------------------------------------------------------------------------- /lib/Pinto/Globals.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Global variables used across the Pinto utilities 2 | 3 | package Pinto::Globals; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use LWP::UserAgent; 9 | 10 | #------------------------------------------------------------------------------ 11 | 12 | # VERSION 13 | 14 | #------------------------------------------------------------------------------ 15 | 16 | ## no critic qw(PackageVars); 17 | our $current_utc_time = undef; 18 | our $current_time_offset = undef; 19 | our $current_username = undef; 20 | our $current_author_id = undef; 21 | our $is_interactive = undef; 22 | 23 | #------------------------------------------------------------------------------ 24 | # TODO: Decide how to expose this 25 | 26 | our $UA = LWP::UserAgent->new( 27 | agent => 'Pinto/' . (__PACKAGE__->VERSION || '???'), 28 | env_proxy => 1, 29 | keep_alive => 5, 30 | ); 31 | 32 | #------------------------------------------------------------------------------ 33 | 1; 34 | 35 | __END__ 36 | -------------------------------------------------------------------------------- /lib/Pinto/IndexReader.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: The package index of a repository 2 | 3 | package Pinto::IndexReader; 4 | 5 | use Moose; 6 | use MooseX::Types::Moose qw(HashRef); 7 | use MooseX::MarkAsMethods (autoclean => 1); 8 | 9 | use IO::Zlib; 10 | 11 | use Pinto::Types qw(File); 12 | use Pinto::Util qw(throw); 13 | 14 | #------------------------------------------------------------------------ 15 | 16 | # VERSION 17 | 18 | #------------------------------------------------------------------------ 19 | 20 | has index_file => ( 21 | is => 'ro', 22 | isa => File, 23 | required => 1, 24 | ); 25 | 26 | has packages => ( 27 | is => 'ro', 28 | isa => HashRef, 29 | builder => '_build_packages', 30 | lazy => 1, 31 | ); 32 | 33 | #------------------------------------------------------------------------------ 34 | 35 | sub _build_packages { 36 | my ($self) = @_; 37 | 38 | my $file = $self->index_file->stringify; 39 | my $fh = IO::Zlib->new($file, 'rb') or throw "Failed to open index file $file: $!"; 40 | my $index_data = $self->__read_index($fh); 41 | close $fh; 42 | 43 | return $index_data; 44 | } 45 | 46 | #------------------------------------------------------------------------------ 47 | 48 | sub __read_index { 49 | my ($self, $fh) = @_; 50 | 51 | my $inheader = 1; 52 | my $packages = {}; 53 | 54 | while (<$fh>) { 55 | 56 | if ($inheader) { 57 | $inheader = 0 if not m/ \S /x; 58 | next; 59 | } 60 | 61 | chomp; 62 | my ($package, $version, $path) = split; 63 | $packages->{$package} = {name => $package, version => $version, path => $path}; 64 | } 65 | 66 | return $packages 67 | } 68 | 69 | #------------------------------------------------------------------------ 70 | 71 | __PACKAGE__->meta->make_immutable; 72 | 73 | #------------------------------------------------------------------------ 74 | 1; 75 | 76 | __END__ 77 | -------------------------------------------------------------------------------- /lib/Pinto/Locator.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Base class for Locators 2 | 3 | package Pinto::Locator; 4 | 5 | use Moose; 6 | use MooseX::StrictConstructor; 7 | use MooseX::MarkAsMethods (autoclean => 1); 8 | 9 | use Pinto::Types qw(Dir Uri); 10 | use Pinto::Util qw(throw tempdir); 11 | 12 | #------------------------------------------------------------------------ 13 | 14 | # VERSION 15 | 16 | #------------------------------------------------------------------------ 17 | 18 | with qw(Pinto::Role::UserAgent); 19 | 20 | #------------------------------------------------------------------------ 21 | 22 | has uri => ( 23 | is => 'ro', 24 | isa => Uri, 25 | default => 'http://backpan.perl.org', 26 | coerce => 1, 27 | ); 28 | 29 | has cache_dir => ( 30 | is => 'ro', 31 | isa => Dir, 32 | default => \&tempdir, 33 | ); 34 | 35 | #------------------------------------------------------------------------ 36 | 37 | sub locate { 38 | my ($self, %args) = @_; 39 | 40 | $args{target} || throw 'Invalid arguments'; 41 | 42 | $args{target} = Pinto::Target->new($args{target}) 43 | if not ref $args{target}; 44 | 45 | return $self->locate_package(%args) 46 | if $args{target}->isa('Pinto::Target::Package'); 47 | 48 | return $self->locate_distribution(%args) 49 | if $args{target}->isa('Pinto::Target::Distribution'); 50 | 51 | throw 'Invalid arguments'; 52 | } 53 | 54 | #------------------------------------------------------------------------ 55 | 56 | sub locate_package { die 'Abstract method'} 57 | 58 | #------------------------------------------------------------------------ 59 | 60 | sub locate_distribution { die 'Abstract method'} 61 | 62 | #------------------------------------------------------------------------ 63 | 64 | sub refresh {} 65 | 66 | #------------------------------------------------------------------------ 67 | 68 | __PACKAGE__->meta->make_immutable; 69 | 70 | #------------------------------------------------------------------------ 71 | 1; 72 | 73 | __END__ 74 | -------------------------------------------------------------------------------- /lib/Pinto/Locator/Stratopan.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Locate targets using Stratopan services 2 | 3 | package Pinto::Locator::Stratopan; 4 | 5 | use Moose; 6 | use MooseX::StrictConstructor; 7 | use MooseX::MarkAsMethods ( autoclean => 1 ); 8 | 9 | use URI; 10 | use JSON qw(decode_json); 11 | use HTTP::Request::Common qw(GET); 12 | 13 | use Pinto::Util qw(whine); 14 | use Pinto::Constants qw(:stratopan); 15 | 16 | #----------------------------------------------------------------------------- 17 | 18 | # VERSION 19 | 20 | #----------------------------------------------------------------------------- 21 | 22 | extends qw(Pinto::Locator); 23 | 24 | #----------------------------------------------------------------------------- 25 | 26 | sub locate_package { 27 | my ($self, %args) = @_; 28 | 29 | return $self->_locate_any(%args); 30 | } 31 | 32 | #----------------------------------------------------------------------------- 33 | 34 | sub locate_distribution { 35 | my ($self, %args) = @_; 36 | 37 | return $self->_locate_any(%args); 38 | } 39 | 40 | #----------------------------------------------------------------------------- 41 | 42 | sub _locate_any { 43 | my ($self, %args) = @_; 44 | 45 | my $uri = $PINTO_STRATOPAN_LOCATOR_URI->clone; 46 | $uri->query_form(q => $args{target}->to_string); 47 | my $response = $self->request(GET($uri)); 48 | 49 | if (!$response->is_success) { 50 | my $status = $response->status_line; 51 | whine "Stratopan is not responding: $status"; 52 | return; 53 | } 54 | 55 | my $structs = eval { decode_json($response->content) }; 56 | whine "Invalid response from Stratopan: $@" and return if $@; 57 | 58 | return unless my $latest = $structs->[0]; 59 | 60 | # Avoid autovivification here... 61 | $latest->{version} = version->parse($latest->{version}) 62 | if exists $latest->{version}; 63 | 64 | # Avoid autovivification here... 65 | $latest->{uri} = URI->new($latest->{uri}) 66 | if exists $latest->{uri}; 67 | 68 | return $latest; 69 | } 70 | 71 | #----------------------------------------------------------------------------- 72 | 73 | __PACKAGE__->meta->make_immutable; 74 | 75 | #----------------------------------------------------------------------------- 76 | 1; 77 | 78 | __END__ -------------------------------------------------------------------------------- /lib/Pinto/Manual.pod: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Entry point for Pinto documentation 2 | 3 | package Pinto::Manual; 4 | 5 | #------------------------------------------------------------------------------ 6 | 7 | # VERSION 8 | 9 | #------------------------------------------------------------------------------ 10 | 1; 11 | 12 | __END__ 13 | 14 | =pod 15 | 16 | =for stopwords Stratopan 17 | 18 | =head1 TABLE OF CONTENTS 19 | 20 | The manual consists of the following documents: 21 | 22 | =head2 L 23 | 24 | Explains the goals, terminology, and concepts in L. 25 | 26 | =head2 L 27 | 28 | Some suggestions for installing L. 29 | 30 | =head2 L 31 | 32 | Presents a narrative explanation of how to use L. 33 | 34 | =head2 L 35 | 36 | Presents a condensed summary of L commands. 37 | 38 | =head2 L 39 | 40 | Names of those who helped to finance L. 41 | 42 | =head1 SEE ALSO 43 | 44 | L is a web service built on Pinto. 45 | Using Stratopan, you can store all your public and private Perl 46 | modules in the cloud without having to create and manage your own 47 | Pinto repository. Stratopan also has facilities for creating teams of 48 | collaborators, controlling access to your repositories, browsing your 49 | repository contents or revision history, and visualizing your 50 | dependency tree. 51 | 52 | At the time of this writing, L is 53 | still in the alpha stage. But it is definitely worth investigation. 54 | 55 | =cut 56 | -------------------------------------------------------------------------------- /lib/Pinto/Migrator.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Migrate an existing repository to a new version 2 | 3 | package Pinto::Migrator; 4 | 5 | use Moose; 6 | use MooseX::StrictConstructor; 7 | use MooseX::MarkAsMethods ( autoclean => 1 ); 8 | 9 | use Pinto::Types qw(Dir); 10 | use Pinto::Repository; 11 | 12 | #------------------------------------------------------------------------------ 13 | 14 | # VERSION 15 | 16 | #------------------------------------------------------------------------------ 17 | 18 | has root => ( 19 | is => 'ro', 20 | isa => Dir, 21 | default => $ENV{PINTO_REPOSITORY_ROOT}, 22 | coerce => 1, 23 | ); 24 | 25 | #------------------------------------------------------------------------------ 26 | 27 | sub migrate { 28 | my ($self) = @_; 29 | 30 | my $repo = Pinto::Repository->new( root => $self->root ); 31 | 32 | my $repo_version = $repo->get_version; 33 | my $code_version = $Pinto::Repository::REPOSITORY_VERSION; 34 | 35 | die "This repository is too old to migrate.\n" . "Contact thaljef\@cpan.org for a migration plan.\n" 36 | if not $repo_version; 37 | 38 | die "This repository is already up to date.\n" 39 | if $repo_version == $code_version; 40 | 41 | die "This repository too new. Upgrade Pinto instead.\n" 42 | if $repo_version > $code_version; 43 | 44 | die "Migration is not implemented yet\n"; 45 | } 46 | 47 | #------------------------------------------------------------------------------ 48 | 49 | __PACKAGE__->meta->make_immutable; 50 | 51 | #------------------------------------------------------------------------------ 52 | 53 | 1; 54 | 55 | __END__ 56 | -------------------------------------------------------------------------------- /lib/Pinto/ModlistWriter.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Generates a stub 03modlist.data.gz file 2 | 3 | package Pinto::ModlistWriter; 4 | 5 | use Moose; 6 | use MooseX::StrictConstructor; 7 | use MooseX::MarkAsMethods ( autoclean => 1 ); 8 | 9 | use IO::Zlib; 10 | use HTTP::Date qw(time2str); 11 | 12 | use Pinto::Types qw(File); 13 | use Pinto::Util qw(debug throw); 14 | 15 | #------------------------------------------------------------------------------ 16 | 17 | # VERSION 18 | 19 | #------------------------------------------------------------------------------ 20 | 21 | has stack => ( 22 | is => 'ro', 23 | isa => 'Pinto::Schema::Result::Stack', 24 | required => 1, 25 | ); 26 | 27 | has modlist_file => ( 28 | is => 'ro', 29 | isa => File, 30 | default => sub { $_[0]->stack->modules_dir->file('03modlist.data.gz') }, 31 | lazy => 1, 32 | ); 33 | 34 | #------------------------------------------------------------------------------ 35 | 36 | sub write_modlist { 37 | my ($self) = @_; 38 | 39 | my $stack = $self->stack; 40 | my $modlist_file = $self->modlist_file; 41 | 42 | debug("Writing module list for stack $stack at $modlist_file"); 43 | 44 | my $fh = IO::Zlib->new( $modlist_file->stringify, 'wb' ) or throw $!; 45 | print {$fh} $self->modlist_data; 46 | close $fh or throw $!; 47 | 48 | return $self; 49 | } 50 | 51 | #------------------------------------------------------------------------------ 52 | 53 | sub modlist_data { 54 | my ($self) = @_; 55 | 56 | my $writer = ref $self; 57 | my $version = $self->VERSION || 'UNKNOWN'; 58 | my $package = 'CPAN::Modulelist'; 59 | my $date = time2str(time); 60 | 61 | return <<"END_MODLIST"; 62 | File: 03modlist.data 63 | Description: This a placeholder for CPAN.pm 64 | Modcount: 0 65 | Written-By: $writer version $version 66 | Date: $date 67 | 68 | package $package; 69 | 70 | sub data { {} } 71 | 72 | 1; 73 | END_MODLIST 74 | 75 | } 76 | 77 | #------------------------------------------------------------------------------ 78 | 79 | __PACKAGE__->meta->make_immutable; 80 | 81 | #------------------------------------------------------------------------------ 82 | 83 | 1; 84 | 85 | __END__ 86 | -------------------------------------------------------------------------------- /lib/Pinto/PrerequisiteWalker.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Iterates through distribution prerequisites 2 | 3 | package Pinto::PrerequisiteWalker; 4 | 5 | use Moose; 6 | use MooseX::StrictConstructor; 7 | use MooseX::Types::Moose qw(CodeRef ArrayRef HashRef Bool); 8 | use MooseX::MarkAsMethods ( autoclean => 1 ); 9 | 10 | #------------------------------------------------------------------------------ 11 | 12 | # VERSION 13 | 14 | #------------------------------------------------------------------------------ 15 | 16 | has start => ( 17 | is => 'ro', 18 | isa => 'Pinto::Schema::Result::Distribution', 19 | required => 1, 20 | ); 21 | 22 | has callback => ( 23 | is => 'ro', 24 | isa => CodeRef, 25 | required => 1, 26 | ); 27 | 28 | has filters => ( 29 | is => 'ro', 30 | isa => ArrayRef [CodeRef], 31 | predicate => 'has_filters', 32 | ); 33 | 34 | has queue => ( 35 | isa => ArrayRef ['Pinto::Schema::Result::Prerequisite'], 36 | traits => [qw(Array)], 37 | handles => { enqueue => 'push', dequeue => 'shift' }, 38 | default => sub { return [ $_[0]->apply_filters( $_[0]->start->prerequisites ) ] }, 39 | init_arg => undef, 40 | lazy => 1, 41 | ); 42 | 43 | has seen => ( 44 | is => 'ro', 45 | isa => HashRef, 46 | default => sub { return { $_[0]->start->path => 1 } }, 47 | init_arg => undef, 48 | lazy => 1, 49 | ); 50 | 51 | #----------------------------------------------------------------------------- 52 | 53 | sub next { 54 | my ($self) = @_; 55 | 56 | my $prereq = $self->dequeue or return; 57 | my $dist = $self->callback->($prereq); 58 | 59 | if ( defined $dist ) { 60 | my $path = $dist->path; 61 | my @prereqs = $self->apply_filters( $dist->prerequisites ); 62 | $self->enqueue(@prereqs) unless $self->seen->{$path}; 63 | $self->seen->{$path} = 1; 64 | } 65 | 66 | return $prereq; 67 | } 68 | 69 | #------------------------------------------------------------------------------ 70 | 71 | sub apply_filters { 72 | my ( $self, @prereqs ) = @_; 73 | 74 | return @prereqs if not $self->has_filters; 75 | 76 | for my $filter ( @{ $self->filters } ) { 77 | @prereqs = grep { !$filter->($_) } @prereqs; 78 | } 79 | 80 | return @prereqs; 81 | } 82 | 83 | #------------------------------------------------------------------------------ 84 | 85 | __PACKAGE__->meta->make_immutable; 86 | 87 | #------------------------------------------------------------------------------- 88 | 1; 89 | 90 | __END__ 91 | -------------------------------------------------------------------------------- /lib/Pinto/Remote/Action/Add.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Add a distribution to a the repository 2 | 3 | package Pinto::Remote::Action::Add; 4 | 5 | use Moose; 6 | use MooseX::MarkAsMethods ( autoclean => 1 ); 7 | 8 | use JSON; 9 | 10 | use Pinto::Util qw(throw); 11 | 12 | #------------------------------------------------------------------------------ 13 | 14 | # VERSION 15 | 16 | #------------------------------------------------------------------------------ 17 | 18 | extends qw( Pinto::Remote::Action ); 19 | 20 | #------------------------------------------------------------------------------ 21 | 22 | around BUILDARGS => sub { 23 | my $orig = shift; 24 | my $class = shift; 25 | 26 | my $args = $class->$orig(@_); 27 | 28 | # I don't have a separate attribute for each action argument, 29 | # so I need to wedge in the default author identity somehow. 30 | # And if PINTO_AUTHOR_ID isn't defined either, then the server 31 | # will fall back to using the username. Perhaps I could also 32 | # do the same thing here just to make it clear what's going on. 33 | 34 | $args->{args}->{author} ||= $ENV{PINTO_AUTHOR_ID} if $ENV{PINTO_AUTHOR_ID}; 35 | 36 | return $args; 37 | }; 38 | 39 | #------------------------------------------------------------------------------ 40 | 41 | sub BUILD { 42 | my ($self) = @_; 43 | 44 | throw 'Only one archive can be remotely added at a time' 45 | if @{ $self->args->{archives} || [] } > 1; 46 | 47 | return $self; 48 | } 49 | 50 | #------------------------------------------------------------------------------ 51 | 52 | override _make_request_body => sub { 53 | my ($self) = @_; 54 | 55 | my $body = super; 56 | my $archive = ( delete $self->args->{archives} )->[0]; 57 | push @{$body}, ( archives => [$archive] ); 58 | 59 | return $body; 60 | }; 61 | 62 | #------------------------------------------------------------------------------ 63 | 64 | __PACKAGE__->meta->make_immutable; 65 | 66 | #------------------------------------------------------------------------------ 67 | 1; 68 | 69 | __END__ 70 | 71 | =for Pod::Coverage BUILD 72 | 73 | =cut 74 | 75 | -------------------------------------------------------------------------------- /lib/Pinto/Remote/Result.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: The result from running a remote Action 2 | 3 | package Pinto::Remote::Result; 4 | 5 | use Moose; 6 | 7 | use MooseX::Types::Moose qw(Bool); 8 | 9 | #----------------------------------------------------------------------------- 10 | 11 | # VERSION 12 | 13 | #------------------------------------------------------------------------------ 14 | 15 | has was_successful => ( 16 | is => 'ro', 17 | isa => Bool, 18 | default => 0, 19 | ); 20 | 21 | #----------------------------------------------------------------------------- 22 | 23 | =method exit_status() 24 | 25 | Returns 0 if this result was successful. Otherwise, returns 1. 26 | 27 | =cut 28 | 29 | sub exit_status { 30 | my ($self) = @_; 31 | return $self->was_successful ? 0 : 1; 32 | } 33 | 34 | #----------------------------------------------------------------------------- 35 | 36 | __PACKAGE__->meta->make_immutable; 37 | 38 | #----------------------------------------------------------------------------- 39 | 1; 40 | 41 | __END__ 42 | -------------------------------------------------------------------------------- /lib/Pinto/RevisionWalker.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Iterates through revision history 2 | 3 | package Pinto::RevisionWalker; 4 | 5 | use Moose; 6 | use MooseX::StrictConstructor; 7 | use MooseX::Types::Moose qw(ArrayRef); 8 | use MooseX::MarkAsMethods ( autoclean => 1 ); 9 | 10 | #------------------------------------------------------------------------------ 11 | 12 | # VERSION 13 | 14 | #------------------------------------------------------------------------------ 15 | # TODO: Rethink this API. Do we need start? Can we just use queue? What 16 | # about filtering, or walking forward? Sort chronological or topological? 17 | 18 | has start => ( 19 | is => 'ro', 20 | isa => 'Pinto::Schema::Result::Revision', 21 | required => 1, 22 | ); 23 | 24 | has queue => ( 25 | isa => ArrayRef, 26 | traits => [qw(Array)], 27 | handles => { enqueue => 'push', dequeue => 'shift' }, 28 | default => sub { [ $_[0]->start ] }, 29 | lazy => 1, 30 | ); 31 | 32 | #------------------------------------------------------------------------------ 33 | 34 | sub next { 35 | my ($self) = @_; 36 | 37 | my $next = $self->dequeue; 38 | 39 | return if not $next; 40 | return if $next->is_root; 41 | 42 | $self->enqueue( $next->parents ); 43 | 44 | return $next; 45 | } 46 | 47 | #------------------------------------------------------------------------------ 48 | 49 | __PACKAGE__->meta->make_immutable; 50 | 51 | #------------------------------------------------------------------------------- 52 | 1; 53 | 54 | __END__ 55 | -------------------------------------------------------------------------------- /lib/Pinto/Role/PauseConfig.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Something that has a pause config attribute 2 | 3 | package Pinto::Role::PauseConfig; 4 | 5 | use Moose::Role; 6 | use MooseX::Types::Moose qw(HashRef); 7 | 8 | use Pinto::Globals; 9 | use Pinto::Types qw(File); 10 | use Pinto::Util qw(current_author_id); 11 | 12 | use Path::Class; 13 | use File::HomeDir; 14 | 15 | #------------------------------------------------------------------------------ 16 | 17 | # VERSION 18 | 19 | #------------------------------------------------------------------------------ 20 | 21 | =attr pauserc 22 | 23 | The path to your PAUSE config file. By default, this is F<~/.pause>. 24 | 25 | =cut 26 | 27 | has pauserc => ( 28 | is => 'ro', 29 | isa => File, 30 | lazy => 1, 31 | coerce => 1, 32 | builder => '_build_pauserc', 33 | ); 34 | 35 | #------------------------------------------------------------------------------ 36 | 37 | =method pausecfg 38 | 39 | Returns a hashref representing the data of the PAUSE config file. 40 | 41 | =cut 42 | 43 | has pausecfg => ( 44 | is => 'ro', 45 | isa => HashRef, 46 | lazy => 1, 47 | init_arg => undef, 48 | builder => '_build_pausecfg', 49 | ); 50 | 51 | #------------------------------------------------------------------------------ 52 | 53 | sub _build_pauserc { 54 | my ($self) = @_; 55 | 56 | return file( File::HomeDir->my_home, '.pause' ); 57 | } 58 | 59 | #------------------------------------------------------------------------------ 60 | 61 | sub _build_pausecfg { 62 | my ($self) = @_; 63 | 64 | my $cfg = {}; 65 | return $cfg if $Pinto::Globals::current_author_id; 66 | return $cfg if not -e $self->pauserc(); 67 | my $fh = $self->pauserc->openr(); 68 | 69 | # basically taken from the parsing code used by cpan-upload 70 | # (maybe this should be part of the CPAN::Uploader api?) 71 | 72 | while (<$fh>) { 73 | next if /^ \s* (?: [#].*)? $/x; 74 | my ( $k, $v ) = /^ \s* (\w+) \s+ (.+?) \s* $/x; 75 | next unless $k; 76 | $cfg->{$k} = $v; 77 | } 78 | 79 | return $cfg; 80 | } 81 | 82 | #------------------------------------------------------------------------------ 83 | 1; 84 | 85 | =pod 86 | 87 | =for stopwords pauserc pausecfg 88 | 89 | =cut 90 | 91 | __END__ 92 | -------------------------------------------------------------------------------- /lib/Pinto/Role/Plated.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Something that has chrome plating 2 | 3 | package Pinto::Role::Plated; 4 | 5 | use Moose::Role; 6 | use MooseX::MarkAsMethods ( autoclean => 1 ); 7 | 8 | #----------------------------------------------------------------------------- 9 | 10 | # VERSION 11 | 12 | #----------------------------------------------------------------------------- 13 | 14 | has chrome => ( 15 | is => 'ro', 16 | isa => 'Pinto::Chrome', 17 | handles => [qw(show diag info notice warning error)], 18 | required => 1, 19 | ); 20 | 21 | #----------------------------------------------------------------------------- 22 | 1; 23 | 24 | __END__ 25 | -------------------------------------------------------------------------------- /lib/Pinto/Role/Schema/Result.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Attributes and methods for all Schema::Result objects 2 | 3 | package Pinto::Role::Schema::Result; 4 | 5 | use Moose::Role; 6 | use MooseX::MarkAsMethods ( autoclean => 1 ); 7 | 8 | #------------------------------------------------------------------------------ 9 | 10 | # VERSION 11 | 12 | #------------------------------------------------------------------------------ 13 | 14 | has repo => ( 15 | is => 'ro', 16 | isa => 'Pinto::Repository', 17 | default => sub { $_[0]->result_source->schema->repo }, 18 | init_arg => undef, 19 | lazy => 1, 20 | ); 21 | 22 | #------------------------------------------------------------------------------ 23 | 24 | sub refresh { 25 | my ($self) = @_; 26 | 27 | $self->discard_changes; 28 | 29 | return $self; 30 | } 31 | 32 | #------------------------------------------------------------------------------ 33 | 34 | sub refresh_column { 35 | my ( $self, $column ) = @_; 36 | 37 | $self->mark_column_dirty($column); 38 | 39 | return $self->get_column($column); 40 | } 41 | 42 | #------------------------------------------------------------------------------ 43 | 44 | 1; 45 | 46 | __END__ 47 | 48 | =head1 DESCRIPTION 49 | 50 | This role adds a L attributes. It should only be 51 | applied to L subclasses, as it will reach into 52 | the underlying L object to get at the repo. 53 | 54 | This gives us a back door for injecting additional attributes into 55 | L objects, since those are usually created by 56 | L and we don't have control over the construction 57 | process. 58 | 59 | =cut 60 | -------------------------------------------------------------------------------- /lib/Pinto/Role/Transactional.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Role for actions that are transactional 2 | 3 | package Pinto::Role::Transactional; 4 | 5 | use Moose::Role; 6 | use MooseX::MarkAsMethods ( autoclean => 1 ); 7 | 8 | use Try::Tiny; 9 | 10 | use Pinto::Util qw(throw); 11 | 12 | #------------------------------------------------------------------------------ 13 | 14 | # VERSION 15 | 16 | #------------------------------------------------------------------------------ 17 | 18 | requires qw( execute repo ); 19 | 20 | #------------------------------------------------------------------------------ 21 | 22 | around execute => sub { 23 | my ( $orig, $self, @args ) = @_; 24 | 25 | $self->repo->txn_begin; 26 | 27 | my $result = try { $self->$orig(@args); $self->repo->txn_commit } 28 | catch { $self->repo->txn_rollback; throw $_ }; 29 | 30 | return $self->result; 31 | }; 32 | 33 | #------------------------------------------------------------------------------ 34 | 1; 35 | 36 | __END__ 37 | -------------------------------------------------------------------------------- /lib/Pinto/Schema/ResultSet/Distribution.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Common queries for Distributions 2 | 3 | use utf8; 4 | 5 | package Pinto::Schema::ResultSet::Distribution; 6 | 7 | use strict; 8 | use warnings; 9 | 10 | use base 'DBIx::Class::ResultSet'; 11 | 12 | #------------------------------------------------------------------------------ 13 | 14 | # VERSION 15 | 16 | #------------------------------------------------------------------------------ 17 | 18 | sub with_packages { 19 | my ( $self, $where ) = @_; 20 | 21 | return $self->search( $where || {}, { prefetch => 'packages' } ); 22 | } 23 | 24 | #------------------------------------------------------------------------------ 25 | 26 | sub find_by_author_archive { 27 | my ( $self, $author, $archive ) = @_; 28 | 29 | my $where = { author => $author, archive => $archive }; 30 | my $attrs = { key => 'author_archive_unique' }; 31 | 32 | return $self->find( $where, $attrs ); 33 | } 34 | 35 | #------------------------------------------------------------------------------ 36 | 1; 37 | 38 | __END__ 39 | -------------------------------------------------------------------------------- /lib/Pinto/Schema/ResultSet/Package.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Common queries for Packages 2 | 3 | use utf8; 4 | 5 | package Pinto::Schema::ResultSet::Package; 6 | 7 | use strict; 8 | use warnings; 9 | 10 | use base 'DBIx::Class::ResultSet'; 11 | 12 | #------------------------------------------------------------------------------ 13 | 14 | # VERSION 15 | 16 | #------------------------------------------------------------------------------ 17 | 18 | sub with_distribution { 19 | my ( $self, $where ) = @_; 20 | 21 | return $self->search( $where || {}, { prefetch => 'distribution' } ); 22 | } 23 | 24 | #------------------------------------------------------------------------------ 25 | 1; 26 | 27 | __END__ 28 | -------------------------------------------------------------------------------- /lib/Pinto/Schema/ResultSet/Registration.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Common queries for Registrations 2 | 3 | use utf8; 4 | 5 | package Pinto::Schema::ResultSet::Registration; 6 | 7 | use strict; 8 | use warnings; 9 | 10 | use base 'DBIx::Class::ResultSet'; 11 | 12 | #------------------------------------------------------------------------------ 13 | 14 | # VERSION 15 | 16 | #------------------------------------------------------------------------------ 17 | 18 | sub with_package { 19 | my ( $self, $where ) = @_; 20 | 21 | return $self->search( $where || {}, { prefetch => 'package' } ); 22 | } 23 | 24 | #------------------------------------------------------------------------------ 25 | 26 | sub with_distribution { 27 | my ( $self, $where ) = @_; 28 | 29 | return $self->search( $where || {}, { prefetch => 'distribution' } ); 30 | } 31 | 32 | #------------------------------------------------------------------------------ 33 | 34 | sub with_revision { 35 | my ( $self, $where ) = @_; 36 | 37 | return $self->search( $where || {}, { revision => 'distribution' } ); 38 | } 39 | 40 | #------------------------------------------------------------------------------ 41 | 42 | sub as_hash { 43 | my ( $self, $cb ) = @_; 44 | 45 | $cb ||= sub { return ( $_[0]->id => $_[0] ) }; 46 | my %hash = map { $cb->($_) } $self->all; 47 | 48 | return wantarray ? %hash : \%hash; 49 | } 50 | 51 | #------------------------------------------------------------------------------ 52 | 1; 53 | 54 | __END__ 55 | -------------------------------------------------------------------------------- /lib/Pinto/Server/Responder.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Base class for responders 2 | 3 | package Pinto::Server::Responder; 4 | 5 | use Moose; 6 | 7 | use Carp; 8 | 9 | use Pinto::Types qw(Dir); 10 | 11 | #------------------------------------------------------------------------------- 12 | 13 | # VERSION 14 | 15 | #------------------------------------------------------------------------------- 16 | 17 | has request => ( 18 | is => 'ro', 19 | isa => 'Plack::Request', 20 | required => 1, 21 | ); 22 | 23 | has root => ( 24 | is => 'ro', 25 | isa => Dir, 26 | required => 1, 27 | ); 28 | 29 | #------------------------------------------------------------------------------- 30 | 31 | =method respond( $request ) 32 | 33 | Given a L, responds with the appropriate 34 | PSGI-compatible response. This is an abstract method. It is your job 35 | to implement it in a concrete subclass. 36 | 37 | =cut 38 | 39 | sub respond { croak 'abstract method' } 40 | 41 | #------------------------------------------------------------------------------- 42 | 43 | __PACKAGE__->meta->make_immutable; 44 | 45 | #------------------------------------------------------------------------------- 46 | 47 | 1; 48 | 49 | __END__ 50 | 51 | =pod 52 | 53 | =for stopwords responders 54 | 55 | =cut 56 | -------------------------------------------------------------------------------- /lib/Pinto/Server/Router.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Routes server requests 2 | 3 | package Pinto::Server::Router; 4 | 5 | use Moose; 6 | 7 | use Scalar::Util; 8 | use Plack::Request; 9 | use Router::Simple; 10 | 11 | #------------------------------------------------------------------------------- 12 | 13 | # VERSION 14 | 15 | #------------------------------------------------------------------------------- 16 | 17 | has route_handler => ( 18 | is => 'ro', 19 | isa => 'Router::Simple', 20 | default => sub { Router::Simple->new }, 21 | ); 22 | 23 | #------------------------------------------------------------------------------- 24 | 25 | sub BUILD { 26 | my ($self) = @_; 27 | 28 | my $r = $self->route_handler; 29 | 30 | $r->connect( '/action/{action}', { responder => 'Action' }, { method => 'POST' } ); 31 | 32 | $r->connect( '/*', { responder => 'File' }, { method => [ 'GET', 'HEAD' ] } ); 33 | 34 | return $self; 35 | } 36 | 37 | #------------------------------------------------------------------------------- 38 | 39 | =method route( $env, $root ) 40 | 41 | Given the request environment and the path to the repository root, 42 | dispatches the request to the appropriate responder and returns the 43 | response. 44 | 45 | =cut 46 | 47 | sub route { 48 | my ( $self, $env, $root ) = @_; 49 | 50 | my $p = $self->route_handler->match($env) 51 | or return [ 404, [], ['Not Found'] ]; 52 | 53 | my $responder_class = 'Pinto::Server::Responder::' . $p->{responder}; 54 | Class::Load::load_class($responder_class); 55 | 56 | my $request = Plack::Request->new($env); 57 | my $responder = $responder_class->new( request => $request, root => $root ); 58 | 59 | # HACK: Plack-1.02 calls URI::Escape::uri_escape() with arguments 60 | # that inadvertently cause $_ to be compiled into a regex. This 61 | # will emit warning if $_ is undef, or may blow up if it contains 62 | # certain stuff. To avoid this, just make sure $_ is empty for 63 | # now. A patch has been sent to Miyagawa. 64 | local $_ = ''; 65 | 66 | return $responder->respond; 67 | } 68 | 69 | #------------------------------------------------------------------------------- 70 | 71 | __PACKAGE__->meta->make_immutable; 72 | 73 | #------------------------------------------------------------------------------- 74 | 75 | 1; 76 | 77 | __END__ 78 | 79 | =pod 80 | 81 | =for stopwords responder 82 | 83 | =for Pod::Coverage BUILD 84 | 85 | =cut 86 | -------------------------------------------------------------------------------- /lib/Pinto/Shell.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Shell into a distribution 2 | 3 | package Pinto::Shell; 4 | 5 | use Moose; 6 | use MooseX::StrictConstructor; 7 | use MooseX::MarkAsMethods ( autoclean => 1 ); 8 | use MooseX::Types::Moose qw(Str); 9 | 10 | use Pinto::Util qw(throw); 11 | use Pinto::Types qw(File Dir); 12 | 13 | use Path::Class qw(file); 14 | use Cwd::Guard qw(cwd_guard); 15 | 16 | use overload ( q{""} => 'to_string' ); 17 | 18 | #------------------------------------------------------------------------------ 19 | 20 | # VERSION 21 | 22 | #------------------------------------------------------------------------------ 23 | 24 | has shell => ( 25 | is => 'ro', 26 | isa => File, 27 | builder => '_build_shell', 28 | ); 29 | 30 | has archive => ( 31 | is => 'ro', 32 | isa => File, 33 | required => 1, 34 | ); 35 | 36 | has unpacker => ( 37 | is => 'ro', 38 | isa => 'Pinto::ArchiveUnpacker', 39 | default => sub { Pinto::ArchiveUnpacker->new( archive => $_[0]->archive ) }, 40 | init_arg => undef, 41 | lazy => 1, 42 | ); 43 | 44 | has work_dir => ( 45 | is => 'ro', 46 | isa => Dir, 47 | default => sub { $_[0]->unpacker->unpack }, 48 | init_arg => undef, 49 | lazy => 1, 50 | ); 51 | 52 | #------------------------------------------------------------------------------ 53 | 54 | sub _build_shell { 55 | 56 | my $shell = $ENV{PINTO_SHELL} || $ENV{SHELL} || $ENV{COMSPEC} 57 | or throw "You don't seem to have a SHELL"; 58 | 59 | my $shell_resolved = eval { file($shell)->resolve } 60 | or throw "Can't resolve the path to your SHELL $shell"; 61 | 62 | -x $shell_resolved 63 | or throw "Your SHELL $shell is not executable"; 64 | 65 | return $shell_resolved; 66 | } 67 | 68 | #------------------------------------------------------------------------------ 69 | 70 | sub spawn { 71 | my ($self) = @_; 72 | 73 | my $cwd_guard = cwd_guard( $self->work_dir ); 74 | 75 | # TODO: This probably isn't very portable, especially if the 76 | # shell command contains spaces or special characters. We 77 | # probably need to shell-quote the command and pass a list. 78 | 79 | return system("$self") == 0; 80 | } 81 | 82 | #----------------------------------------------------------------------------- 83 | 84 | sub to_string { 85 | my ($self) = @_; 86 | 87 | return $self->shell->stringify; 88 | } 89 | #----------------------------------------------------------------------------- 90 | 91 | 1; 92 | 93 | __END__ 94 | -------------------------------------------------------------------------------- /lib/Pinto/Target.pm: -------------------------------------------------------------------------------- 1 | # ABSTRACT: Create Spec objects from strings 2 | 3 | package Pinto::Target; 4 | 5 | use strict; 6 | use warnings; 7 | 8 | use Class::Load; 9 | 10 | use Pinto::Exception; 11 | 12 | #------------------------------------------------------------------------------- 13 | 14 | # VERSION 15 | 16 | #------------------------------------------------------------------------------- 17 | 18 | =method new( $string ) 19 | 20 | [Class Method] Returns either a L or 21 | L object constructed from the given C<$string>. 22 | 23 | =cut 24 | 25 | sub new { 26 | my ( $class, $arg ) = @_; 27 | 28 | my $type = ref $arg; 29 | my $target_class; 30 | 31 | if ( not $type ) { 32 | 33 | $target_class = 34 | ( $arg =~ m{/}x ) 35 | ? 'Pinto::Target::Distribution' 36 | : 'Pinto::Target::Package'; 37 | } 38 | elsif ( ref $arg eq 'HASH' ) { 39 | 40 | $target_class = 41 | ( exists $arg->{author} ) 42 | ? 'Pinto::Target::Distribution' 43 | : 'Pinto::Target::Package'; 44 | } 45 | else { 46 | 47 | # I would just use throw() here, but I need to avoid 48 | # creating a circular dependency between this package, 49 | # Pinto::Types and Pinto::Util. 50 | 51 | my $message = "Don't know how to make target from $arg"; 52 | Pinto::Exception->throw( message => $message ); 53 | 54 | } 55 | 56 | Class::Load::load_class($target_class); 57 | return $target_class->new($arg); 58 | } 59 | 60 | #------------------------------------------------------------------------------- 61 | 1; 62 | 63 | __END__ 64 | -------------------------------------------------------------------------------- /t/01-common/03-target-distribution.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Exception; 8 | 9 | use Pinto::Target::Distribution; 10 | 11 | #------------------------------------------------------------------------------ 12 | 13 | subtest string_constructor => sub { 14 | 15 | my $target = Pinto::Target::Distribution->new('Author/subdir/Foo-1.2.tar.gz'); 16 | is $target->author, 'AUTHOR', 'author attribute'; 17 | is $target->archive, 'Foo-1.2.tar.gz', 'archive attribute'; 18 | is $target->path, 'A/AU/AUTHOR/subdir/Foo-1.2.tar.gz', 'Constructed path'; 19 | is "$target", 'AUTHOR/subdir/Foo-1.2.tar.gz', 'Stringified object'; 20 | 21 | }; 22 | 23 | #------------------------------------------------------------------------------ 24 | 25 | subtest hash_constructor => sub { 26 | 27 | my $target = Pinto::Target::Distribution->new( 28 | author => 'Author', 29 | subdirs => [qw(foo bar)], 30 | archive => 'Foo-1.2.tar.gz' 31 | ); 32 | 33 | is $target->author, 'AUTHOR', 'author attribute'; 34 | is $target->archive, 'Foo-1.2.tar.gz', 'archive attribute'; 35 | is $target->path, 'A/AU/AUTHOR/foo/bar/Foo-1.2.tar.gz', 'Constructed path'; 36 | is "$target", 'AUTHOR/foo/bar/Foo-1.2.tar.gz', 'Stringified object'; 37 | 38 | }; 39 | 40 | #------------------------------------------------------------------------------ 41 | subtest invalid_constructor => sub { 42 | 43 | throws_ok { Pinto::Target::Distribution->new('AUTHOR/') } qr{Invalid distribution target}, 'Invalid dist target'; 44 | 45 | throws_ok { Pinto::Target::Distribution->new('/Foo-1.2.tar.gz') } qr{Invalid distribution target}, 'Invalid dist target'; 46 | 47 | throws_ok { Pinto::Target::Distribution->new('Foo-1.2.tar.gz') } qr{Invalid distribution target}, 'Invalid dist target'; 48 | 49 | throws_ok { Pinto::Target::Distribution->new('') } qr{Invalid distribution target}, 'Empty dist target'; 50 | 51 | }; 52 | 53 | #------------------------------------------------------------------------------ 54 | 55 | done_testing; 56 | -------------------------------------------------------------------------------- /t/01-common/05-pauseconfig.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use File::Temp; 8 | use Pinto::Globals; 9 | 10 | #----------------------------------------------------------------------------- 11 | 12 | package Local::PauseConfig; 13 | use Moose; 14 | with qw(Pinto::Role::PauseConfig); 15 | 16 | #----------------------------------------------------------------------------- 17 | 18 | package main; 19 | 20 | sub write_temp_file { 21 | my ($content) = @_; 22 | 23 | my $temp = File::Temp->new; 24 | $temp->autoflush(1); 25 | print $temp $content; 26 | 27 | return $temp; 28 | } 29 | 30 | #----------------------------------------------------------------------------- 31 | 32 | my $pauserc = write_temp_file(<<'TEXT'); 33 | user SOMEUSER 34 | 35 | mailto somebody@example.com 36 | 37 | non_interactive 38 | TEXT 39 | 40 | #----------------------------------------------------------------------------- 41 | 42 | subtest 'Read from ~/.pause' => sub { 43 | my $obj = Local::PauseConfig->new( pauserc => $pauserc->filename ); 44 | is_deeply $obj->pausecfg, { user => "SOMEUSER", mailto => 'somebody@example.com' }; 45 | }; 46 | 47 | #----------------------------------------------------------------------------- 48 | 49 | subtest 'Override using current_author_id' => sub { 50 | local $Pinto::Globals::current_author_id = 'ME'; 51 | my $obj = Local::PauseConfig->new( pauserc => $pauserc->filename ); 52 | is_deeply $obj->pausecfg, {}; 53 | }; 54 | 55 | #----------------------------------------------------------------------------- 56 | 57 | done_testing; 58 | -------------------------------------------------------------------------------- /t/01-common/lib/TestClass.pm: -------------------------------------------------------------------------------- 1 | package TestClass; 2 | 3 | use Moose; 4 | 5 | use Pinto::Types qw( 6 | ANSIColor 7 | ANSIColorPalette 8 | AuthorID 9 | DiffStyle 10 | Dir 11 | DistributionTarget 12 | DistributionTargetList 13 | File 14 | Io 15 | PackageTarget 16 | PackageTargetList 17 | PropertyName 18 | RevisionID 19 | StackAll 20 | StackDefault 21 | StackName 22 | TargetList 23 | Uri 24 | Version 25 | ); 26 | 27 | #----------------------------------------------------------------------------- 28 | 29 | has file => ( 30 | is => 'rw', 31 | isa => File, 32 | coerce => 1, 33 | ); 34 | 35 | has dir => ( 36 | is => 'rw', 37 | isa => Dir, 38 | coerce => 1, 39 | ); 40 | 41 | has uri => ( 42 | is => 'rw', 43 | isa => Uri, 44 | coerce => 1, 45 | ); 46 | 47 | has io => ( 48 | is => 'rw', 49 | isa => Io, 50 | coerce => 1, 51 | ); 52 | 53 | has author => ( 54 | is => 'rw', 55 | isa => AuthorID, 56 | coerce => 1, 57 | ); 58 | 59 | has stack => ( 60 | is => 'rw', 61 | isa => StackName, 62 | ); 63 | 64 | has stack_all => ( 65 | is => 'rw', 66 | isa => StackAll, 67 | ); 68 | 69 | has stack_default => ( 70 | is => 'rw', 71 | isa => StackDefault, 72 | ); 73 | 74 | has property => ( 75 | is => 'rw', 76 | isa => PropertyName, 77 | ); 78 | 79 | has version => ( 80 | is => 'rw', 81 | isa => Version, 82 | coerce => 1, 83 | ); 84 | 85 | has pkg => ( 86 | is => 'rw', 87 | isa => PackageTarget, 88 | coerce => 1, 89 | ); 90 | 91 | has pkgs => ( 92 | is => 'rw', 93 | isa => PackageTargetList, 94 | coerce => 1, 95 | ); 96 | 97 | has dist => ( 98 | is => 'rw', 99 | isa => DistributionTarget, 100 | coerce => 1, 101 | ); 102 | 103 | has dists => ( 104 | is => 'rw', 105 | isa => DistributionTargetList, 106 | coerce => 1, 107 | ); 108 | 109 | has targets => ( 110 | is => 'rw', 111 | isa => TargetList, 112 | coerce => 1, 113 | ); 114 | 115 | has revision => ( 116 | is => 'rw', 117 | isa => RevisionID, 118 | coerce => 1, 119 | ); 120 | 121 | has color => ( 122 | is => 'rw', 123 | isa => ANSIColor, 124 | ); 125 | 126 | has palette => ( 127 | is => 'rw', 128 | isa => ANSIColorPalette, 129 | ); 130 | 131 | has diffstyle => ( 132 | is => 'rw', 133 | isa => DiffStyle, 134 | ); 135 | 136 | #----------------------------------------------------------------------------- 137 | 138 | 1; 139 | -------------------------------------------------------------------------------- /t/02-bowels/01-config.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Exception; 8 | 9 | use Path::Class; 10 | use File::Temp; 11 | use URI; 12 | 13 | use Pinto::Config; 14 | 15 | #------------------------------------------------------------------------------ 16 | 17 | subtest 'Default config' => sub { 18 | 19 | my %cases = ( 20 | root => 'nowhere', 21 | sources => 'http://cpan.stratopan.com http://www.cpan.org http://backpan.perl.org', 22 | ); 23 | 24 | my $cfg = Pinto::Config->new( root => 'nowhere' ); 25 | while ( my ( $method, $expect ) = each %cases ) { 26 | my $msg = "Got default value for '$method'"; 27 | is( $cfg->$method(), $expect, $msg ); 28 | } 29 | }; 30 | 31 | #------------------------------------------------------------------------------ 32 | 33 | subtest 'Custom config' => sub { 34 | 35 | my %cases = ( 36 | root => 'nowhere', 37 | sources => 'http://cpan.pair.com http://metacpan.org', 38 | ); 39 | 40 | my $cfg = Pinto::Config->new(%cases); 41 | while ( my ( $method, $expect ) = each %cases ) { 42 | my $msg = "Got custom value for '$method'"; 43 | is( $cfg->$method(), $expect, $msg ); 44 | } 45 | }; 46 | 47 | #------------------------------------------------------------------------------ 48 | 49 | subtest 'Multiple sources' => sub { 50 | 51 | my $expect = [ map { URI->new($_) } qw(here there) ]; 52 | 53 | my $cfg1 = Pinto::Config->new( root => 'anywhere', sources => 'here there' ); 54 | is_deeply( [ $cfg1->sources_list ], $expect, 'Parsed sources list' ); 55 | 56 | my $cfg2 = Pinto::Config->new( root => 'anywhere', sources => q{"here there"} ); 57 | is_deeply( [ $cfg2->sources_list ], $expect, 'Parsed sources list, with quotes' ); 58 | }; 59 | 60 | #------------------------------------------------------------------------------ 61 | 62 | done_testing; 63 | -------------------------------------------------------------------------------- /t/02-bowels/03-package.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use Path::Class; 9 | 10 | use lib 't/lib'; 11 | use Pinto::Tester::Util qw(make_dist_obj make_pkg_obj); 12 | 13 | #------------------------------------------------------------------------------ 14 | 15 | my $dist = make_dist_obj( author => 'AUTHOR', archive => 'Foo-2.001_02.tar.gz' ); 16 | my $pkg = make_pkg_obj( name => 'Foo', version => '2.001_02', distribution => $dist ); 17 | 18 | is( $pkg->name(), 'Foo', 'name attribute' ); 19 | is( $pkg->vname(), 'Foo~2.001_02', 'vname attribute' ); 20 | is( $pkg->version(), '2.001_02', 'version attribute' ); 21 | isa_ok( $pkg->version(), 'version', 'version attribute isa version object' ); 22 | is( "$pkg", 'AUTHOR/Foo-2.001_02/Foo~2.001_02', 'default strigification' ); 23 | 24 | #------------------------------------------------------------------------------ 25 | 26 | $dist = make_dist_obj( author => 'AUTHOR', archive => 'Foo-2.0.tar.gz', source => 'http://remote' ); 27 | $pkg = make_pkg_obj( name => 'Foo', distribution => $dist ); 28 | 29 | is( $pkg->vname(), 'Foo~0', 'vname with undef version' ); 30 | 31 | #------------------------------------------------------------------------------ 32 | 33 | $dist = make_dist_obj( author => 'AUTHOR', archive => 'Foo-2.0-TRIAL.tar.gz', source => 'http://remote' ); 34 | $pkg = make_pkg_obj( name => 'Foo', distribution => $dist, version => 1.2 ); 35 | 36 | my %formats = ( 37 | 'p' => 'Foo', 38 | 'P' => 'Foo~1.2', 39 | 'v' => '1.2', 40 | 'm' => 'd', 41 | 'h' => 'A/AU/AUTHOR/Foo-2.0-TRIAL.tar.gz', 42 | 's' => 'f', 43 | 'S' => 'http://remote', 44 | 'a' => 'AUTHOR', 45 | 'd' => 'Foo', 46 | 'D' => 'Foo-2.0-TRIAL', 47 | 'V' => '2.0-TRIAL', 48 | 'u' => 'http://remote/authors/id/A/AU/AUTHOR/Foo-2.0-TRIAL.tar.gz', 49 | ); 50 | 51 | while ( my ( $placeholder, $expected ) = each %formats ) { 52 | my $got = $pkg->to_string("%$placeholder"); 53 | is( $got, $expected, "Placeholder: %$placeholder" ); 54 | } 55 | 56 | #------------------------------------------------------------------------------ 57 | 58 | done_testing(); 59 | 60 | -------------------------------------------------------------------------------- /t/02-bowels/05-compare.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Exception; 8 | 9 | use lib 't/lib'; 10 | use Pinto::Tester::Util qw(make_dist_obj make_pkg_obj); 11 | 12 | #------------------------------------------------------------------------------ 13 | # Test package specification is as follows: 14 | # 15 | # dist_name-dist_mtime/pkg_name-pkg_version 16 | # 17 | # For example: 18 | # 19 | # Foo-1/Bar-0.3 20 | # 21 | # Means pacakge Bar version 0.3 in dist Foo with mtime 1 22 | #------------------------------------------------------------------------------ 23 | 24 | package_compare_ok( 'Dist-1/Pkg-undef', 'Dist-1/Pkg-1' ); 25 | package_compare_ok( 'Dist-1/Pkg-0', 'Dist-1/Pkg-1' ); 26 | package_compare_ok( 'Dist-1/Pkg-1', 'Dist-1/Pkg-2' ); 27 | package_compare_ok( 'Dist-1/Pkg-1', 'Dist-2/Pkg-1' ); 28 | package_compare_ok( 'Dist-1/Pkg-1.1.1', 'Dist-1/Pkg-1.1.2' ); 29 | package_compare_ok( 'Dist-1/Pkg-1.1.1', 'Dist-2/Pkg-1.1.1' ); 30 | 31 | # Exceptions 32 | throws_ok { package_compare_ok( 'Dist-1/Foo-1-0', 'Dist-1/Bar-1-1' ) } qr/packages with different names/; 33 | 34 | throws_ok { package_compare_ok( 'Dist-1/Foo-1-1', 'Dist-1/Foo-1-1' ) } qr/Unable to determine ordering/; 35 | 36 | throws_ok { package_compare_ok( 'Dist-1/Foo-1-0', 'Dist-1/Foo-1-0' ) } qr/Unable to determine ordering/; 37 | 38 | #=============================================================================== 39 | 40 | sub package_compare_ok { 41 | my ( $spec_A, $spec_B, $test_name ) = @_; 42 | 43 | $test_name = "Package A sorts before package B"; 44 | my ( $pkg_A, $pkg_B ) = map { _make_pkg($_) } ( $spec_A, $spec_B ); 45 | 46 | local $Test::Builder::Level = $Test::Builder::Level + 1; 47 | my $ok = is( $pkg_A <=> $pkg_B, -1, $test_name ); 48 | diag(" A: $spec_A \n B: $spec_B") if not $ok; 49 | return $ok; 50 | } 51 | 52 | #------------------------------------------------------------------------------ 53 | my $id = 0; 54 | 55 | sub _make_pkg { 56 | my ($spec) = @_; 57 | my ( $dist_spec, $pkg_spec ) = split '/', $spec; 58 | 59 | my ( $dist_name, $mtime ) = split '-', $dist_spec; 60 | my ( $pkg_name, $pkg_version, $is_local ) = split '-', $pkg_spec; 61 | 62 | my $dist = make_dist_obj( 63 | author => 'AUTHOR', 64 | archive => "$dist_name-0.00.tar.gz", 65 | mtime => $mtime || 0, 66 | id => $id++, 67 | ); 68 | 69 | my $pkg = make_pkg_obj( 70 | name => $pkg_name, 71 | version => $pkg_version, 72 | distribution => $dist, 73 | id => $id++, 74 | ); 75 | 76 | return $pkg; 77 | } 78 | 79 | #------------------------------------------------------------------------------ 80 | 81 | done_testing; 82 | -------------------------------------------------------------------------------- /t/02-bowels/11-tester.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use lib 't/lib'; 9 | use Pinto::Tester; 10 | use Pinto::Tester::Util qw(make_dist_struct parse_reg_spec); 11 | 12 | #------------------------------------------------------------------------------- 13 | subtest 'make_dist_struct' => sub { 14 | 15 | my $spec = 'AUTHOR/FooAndBar-1.2 = Foo~1.2; Bar~0.0 & Baz~3.1; Nuts~2.4'; 16 | my $struct = make_dist_struct($spec); 17 | is $struct->{cpan_author}, 'AUTHOR', 'Got author'; 18 | is $struct->{name}, 'FooAndBar', 'Got name'; 19 | is_deeply $struct->{provides}->{Foo}, { file => 'lib/Foo.pm', version => '1.2' }; 20 | is_deeply $struct->{provides}->{Bar}, { file => 'lib/Bar.pm', version => '0.0' }; 21 | is_deeply $struct->{requires}, { Baz => '3.1', Nuts => '2.4' }; 22 | is $struct->{version}, '1.2'; 23 | 24 | }; 25 | 26 | #------------------------------------------------------------------------------- 27 | subtest 'parse_reg_spec' => sub { 28 | 29 | my ( $author, $dist_archive, $pkg_name, $pkg_ver, $stack_name, $is_pinned ) = 30 | parse_reg_spec('AUTHOR/Foo-1.2/Foo~2.0/my_stack/*'); 31 | 32 | is $author, 'AUTHOR'; 33 | is $dist_archive, 'Foo-1.2.tar.gz'; 34 | is $pkg_name, 'Foo'; 35 | is $pkg_ver, '2.0'; 36 | is $stack_name, 'my_stack'; 37 | is $is_pinned, 1; 38 | 39 | }; 40 | 41 | #------------------------------------------------------------------------------- 42 | subtest 'populate' => sub { 43 | 44 | my $t = Pinto::Tester->new; 45 | 46 | $t->populate('AUTHOR/FooAndBar-1.2=Foo~1.2;Bar~0.0'); 47 | 48 | # Without .tar.gz extension 49 | $t->registration_ok('AUTHOR/FooAndBar-1.2/Foo~1.2/master'); 50 | 51 | # With .tar.gz extension 52 | $t->registration_ok('AUTHOR/FooAndBar-1.2.tar.gz/Foo~1.2/master'); 53 | 54 | # With explicit stack 55 | $t->registration_ok('AUTHOR/FooAndBar-1.2/Bar~0.0/master'); 56 | 57 | # Without explicit stack 58 | $t->registration_ok('AUTHOR/FooAndBar-1.2/Bar~0.0'); 59 | 60 | }; 61 | 62 | #------------------------------------------------------------------------------- 63 | done_testing; 64 | -------------------------------------------------------------------------------- /t/02-bowels/19-basic.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use lib 't/lib'; 9 | use Pinto::Tester; 10 | use Pinto::Tester::Util qw(make_dist_archive); 11 | 12 | use Pinto::Util qw(sha256); 13 | 14 | #------------------------------------------------------------------------------ 15 | subtest 'make_dist_archive' => sub { 16 | 17 | my $t = Pinto::Tester->new; 18 | my $archive = make_dist_archive('AUTHOR/Dist-1 = PkgA~1 & PkgB~1'); 19 | $t->run_ok( Add => { archives => $archive, author => 'AUTHOR', recurse => 0 } ); 20 | my $dist = $t->get_distribution(author => 'AUTHOR', archive => 'Dist-1.tar.gz'); 21 | 22 | is $dist->sha256, sha256($archive), 'SHA digest'; 23 | is $dist->source, 'LOCAL', 'Dist source'; 24 | is $dist->author, 'AUTHOR', 'Dist author'; 25 | is $dist->name, 'Dist', 'Dist name'; 26 | is $dist->vname, 'Dist-1', 'Dist vname'; 27 | is $dist->version, '1', 'Dist version'; 28 | is $dist->is_devel, '', 'Dist maturity'; 29 | 30 | my @packages = $dist->packages; 31 | is scalar @packages, 1, 'Package count'; 32 | 33 | my $pkg = $packages[0]; 34 | is $pkg->name, 'PkgA', 'Package name'; 35 | is $pkg->vname, 'PkgA~1', 'Package vname'; 36 | is $pkg->version, '1', 'Package version'; 37 | is $pkg->file, 'lib/PkgA.pm', 'Package file'; 38 | is $pkg->is_simile, 1, 'Package is simile'; 39 | 40 | my @prereqs = $dist->prerequisites; 41 | is scalar @prereqs, 1, 'Prereq count'; 42 | 43 | my $prereq = $prereqs[0]; 44 | is $prereq->package_name, 'PkgB', 'Prereq name'; 45 | is $prereq->package_version, '1', 'Prereq version'; 46 | 47 | }; 48 | 49 | #----------------------------------------------------------------------------- 50 | 51 | done_testing; 52 | -------------------------------------------------------------------------------- /t/02-bowels/21-add-no-index.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use File::Copy; 7 | use Path::Class; 8 | use Test::More; 9 | 10 | use lib 't/lib'; 11 | use Pinto::Tester; 12 | use Pinto::Tester::Util qw(make_dist_archive); 13 | 14 | use Pinto::Util qw(sha256); 15 | 16 | #------------------------------------------------------------------------------ 17 | 18 | subtest 'Excluding with exact match' => sub { 19 | 20 | my $t = Pinto::Tester->new; 21 | my $archive = make_dist_archive('Foo-Bar-0.01 = Foo~0.01; Bar~0.01'); 22 | $t->run_ok( Add => { archives => $archive, no_index => ['Foo'] } ); 23 | 24 | $t->registration_not_ok("AUTHOR/Foo-Bar-0.01/Foo~0.01/master"); 25 | $t->registration_ok("AUTHOR/Foo-Bar-0.01/Bar~0.01/master"); 26 | 27 | my $dist = $t->get_distribution( path => 'A/AU/AUTHOR/Foo-Bar-0.01.tar.gz' ); 28 | my @pkgs = $dist->packages; 29 | 30 | is( scalar @pkgs, 1, "Dist $dist has only one package" ); 31 | is( $pkgs[0]->name, 'Bar', "Remaining package is Bar" ); 32 | 33 | }; 34 | 35 | #----------------------------------------------------------------------------- 36 | 37 | subtest 'Excluding with regexes' => sub { 38 | 39 | my $t = Pinto::Tester->new; 40 | my $archive = make_dist_archive('Foo-Bar-0.01 = Foo~0.01; Bar~0.01; Baz~0.01'); 41 | $t->run_ok( Add => { archives => $archive, no_index => [ '/F', '/r' ] } ); 42 | 43 | $t->registration_not_ok("AUTHOR/Foo-Bar-0.01/Foo~0.01/master"); 44 | $t->registration_not_ok("AUTHOR/Foo-Bar-0.01/Bar~0.01/master"); 45 | $t->registration_ok("AUTHOR/Foo-Bar-0.01/Baz~0.01/master"); 46 | 47 | my $dist = $t->get_distribution( path => 'A/AU/AUTHOR/Foo-Bar-0.01.tar.gz' ); 48 | my @pkgs = $dist->packages; 49 | 50 | is( scalar @pkgs, 1, "Dist $dist has only one package" ); 51 | is( $pkgs[0]->name, 'Baz', "Remaining package is Baz" ); 52 | }; 53 | 54 | #----------------------------------------------------------------------------- 55 | 56 | subtest 'Excluding all packages in the dist' => sub { 57 | 58 | my $t = Pinto::Tester->new; 59 | my $archive = make_dist_archive('Foo-0.01 = Foo~0.01'); 60 | $t->run_throws_ok( 61 | Add => { archives => $archive, no_index => ['/o'] }, 62 | qr/has no packages left/, 'Cannot exclude all packages' 63 | ); 64 | }; 65 | 66 | #----------------------------------------------------------------------------- 67 | 68 | done_testing; 69 | -------------------------------------------------------------------------------- /t/02-bowels/21-pull-vreq.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use lib 't/lib'; 9 | use Pinto::Tester; 10 | use Pinto::Tester::Util qw(make_dist_archive); 11 | 12 | #------------------------------------------------------------------------------ 13 | 14 | my $source = Pinto::Tester->new; 15 | $source->populate('AUTHOR/Dist-1 = PkgA~1'); 16 | $source->populate('AUTHOR/Dist-2 = PkgB~2'); 17 | 18 | #------------------------------------------------------------------------------ 19 | 20 | subtest 'exact version' => sub { 21 | 22 | my $local = Pinto::Tester->new( init_args => { sources => $source->stack_url } ); 23 | $local->run_ok( Pull => {targets => 'PkgA@1'} ); 24 | $local->registration_ok('AUTHOR/Dist-1/PkgA~1'); 25 | 26 | $local->run_ok( Pull => {targets => 'PkgB==2'} ); 27 | $local->registration_ok('AUTHOR/Dist-2/PkgB~2'); 28 | }; 29 | 30 | #------------------------------------------------------------------------------ 31 | 32 | subtest 'not version' => sub { 33 | 34 | my $local = Pinto::Tester->new( init_args => { sources => $source->stack_url } ); 35 | $local->run_ok( Pull => {targets => 'PkgA!=2'} ); 36 | $local->registration_ok('AUTHOR/Dist-1/PkgA~1'); 37 | 38 | $local->run_throws_ok( Pull => {targets => 'PkgB!=2'}, qr/Cannot find PkgB!=2/ ); 39 | 40 | }; 41 | 42 | #------------------------------------------------------------------------------ 43 | 44 | subtest 'complex' => sub { 45 | 46 | my $local = Pinto::Tester->new( init_args => { sources => $source->stack_url } ); 47 | $local->run_ok( Pull => {targets => 'PkgA>0.5,!=2,<=4'} ); 48 | $local->registration_ok('AUTHOR/Dist-1/PkgA~1'); 49 | 50 | $local->run_throws_ok( Pull => {targets => 'PkgB>=1,<5,!=2,!=3'}, qr/Cannot find PkgB>=1,<5,!=2,!=3/ ); 51 | 52 | }; 53 | #------------------------------------------------------------------------------ 54 | done_testing; 55 | -------------------------------------------------------------------------------- /t/02-bowels/23-pull-multi.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use lib 't/lib'; 9 | use Pinto::Tester; 10 | 11 | #------------------------------------------------------------------------------ 12 | 13 | my $source_1 = Pinto::Tester->new; 14 | $source_1->populate( 15 | 'JOHN/DistA-1 = PkgA~1 & PkgB~1', 16 | 'JOHN/DistB-1 = PkgB~1 & PkgC~2', 17 | 'JOHN/DistC-1 = PkgC~1', 18 | 'JOHN/DistD-1 = PkgD~1 & PkgC~1' 19 | ); 20 | 21 | my $source_2 = Pinto::Tester->new; 22 | $source_2->populate( 'FRED/DistB-1 = PkgB~1', 'FRED/DistC-2 = PkgC~2' ); 23 | 24 | my $sources = sprintf '%s %s', $source_1->stack_url, $source_2->stack_url; 25 | 26 | #------------------------------------------------------------------------------ 27 | subtest 'simple multi' => sub { 28 | 29 | # DistB-1 requires PkgC-2. Source 1 only has PkgC-1, but source 2 has PkgC-2 30 | my $local = Pinto::Tester->new( init_args => { sources => $sources } ); 31 | $local->run_ok( 'Pull', { targets => 'PkgA~1' } ); 32 | $local->registration_ok('JOHN/DistA-1/PkgA~1'); 33 | $local->registration_ok('JOHN/DistB-1/PkgB~1'); 34 | $local->registration_ok('FRED/DistC-2/PkgC~2'); 35 | 36 | }; 37 | 38 | #------------------------------------------------------------------------------ 39 | subtest 'complex multi' => sub { 40 | 41 | # DistD-1 requires PkgC-1. Source 1 has PkgC-1, but source 2 has even 42 | # newer PkgC-2. Since Source 1 is the first source, we should only get PkgC~1. 43 | 44 | my $local = Pinto::Tester->new( init_args => { sources => $sources } ); 45 | $local->run_ok( 'Pull', { targets => 'PkgD~1' } ); 46 | $local->registration_ok('JOHN/DistD-1/PkgD~1'); 47 | $local->registration_ok('JOHN/DistC-1/PkgC~1'); 48 | 49 | }; 50 | 51 | #------------------------------------------------------------------------------ 52 | subtest 'complex multi cascade' => sub { 53 | 54 | # Same as last test but with cascade => 1, we should get newer PkgC~2 55 | # from Source 2, because it is the latest amongst all upstream repos. 56 | 57 | my $local = Pinto::Tester->new( init_args => { sources => $sources } ); 58 | $local->run_ok( 'Pull', { targets => 'PkgD~1', cascade => 1 } ); 59 | $local->registration_ok('JOHN/DistD-1/PkgD~1'); 60 | $local->registration_ok('FRED/DistC-2/PkgC~2'); 61 | 62 | }; 63 | 64 | #------------------------------------------------------------------------------ 65 | 66 | done_testing; 67 | -------------------------------------------------------------------------------- /t/02-bowels/24-skip-prereqs.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use lib 't/lib'; 9 | use Pinto::Tester; 10 | use Pinto::Tester::Util qw(make_dist_archive); 11 | 12 | #------------------------------------------------------------------------------ 13 | 14 | my $t1 = Pinto::Tester->new; # Empty upstream repository 15 | my $t2 = Pinto::Tester->new(init_args => {sources => $t1->stack_url}); 16 | my $archive = make_dist_archive('AUTHOR/DistA-1 = PkgA~1 & PkgB~1; PkgC~1'); 17 | my $expected_registration = 'AUTHOR/DistA-1/PkgA~1'; 18 | 19 | #------------------------------------------------------------------------------ 20 | 21 | subtest 'Skip all missing prereqs when adding' => sub { 22 | 23 | $t2->run_ok( Add => { archives => $archive, skip_all_missing_prerequisites => 1 } ); 24 | $t2->stderr_like(qr/Cannot find PkgB~1 anywhere. Skipping it/); 25 | $t2->registration_ok($expected_registration); 26 | }; 27 | 28 | #------------------------------------------------------------------------------ 29 | 30 | subtest 'Skip all missing prereqs when pulling' => sub { 31 | 32 | my $stack = 'foo'; 33 | 34 | $t2->run_ok( New => {stack => $stack}); 35 | $t2->stack_is_empty_ok($stack); 36 | 37 | $t2->run_ok( Pull => {targets => 'PkgA', stack => $stack, skip_all_missing_prerequisites => 1 }); 38 | $t2->stderr_like(qr/Cannot find PkgB~1 anywhere. Skipping it/); 39 | $t2->registration_ok("$expected_registration/$stack"); 40 | }; 41 | 42 | #------------------------------------------------------------------------------ 43 | 44 | subtest 'Skip all named missing prereqs when pulling' => sub { 45 | 46 | my $stack = 'bar'; 47 | 48 | $t2->run_ok( New => {stack => $stack}); 49 | $t2->stack_is_empty_ok($stack); 50 | 51 | $t2->run_ok( Pull => {targets => 'PkgA', stack => $stack, skip_missing_prerequisite => [qw(PkgB PkgC)] }); 52 | $t2->stderr_like(qr/Cannot find PkgB~1 anywhere. Skipping it/); 53 | $t2->registration_ok("AUTHOR/DistA-1/PkgA~1/bar/$stack"); 54 | }; 55 | 56 | #------------------------------------------------------------------------------ 57 | 58 | subtest 'Skip just some named missing prereqs when pulling' => sub { 59 | 60 | my $stack = 'baz'; 61 | 62 | $t2->run_ok( New => {stack => $stack}); 63 | $t2->stack_is_empty_ok($stack); 64 | 65 | $t2->run_throws_ok( Pull => {targets => 'PkgA', stack => $stack, skip_missing_prerequisite => [qw(PkgC)] }, 66 | qr/Cannot find PkgB~1 anywhere/ ); 67 | }; 68 | 69 | #------------------------------------------------------------------------------ 70 | done_testing; 71 | -------------------------------------------------------------------------------- /t/02-bowels/31-pin.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use lib 't/lib'; 9 | use Pinto::Tester; 10 | use Pinto::Tester::Util qw(make_dist_archive); 11 | 12 | #------------------------------------------------------------------------------ 13 | 14 | my $t = Pinto::Tester->new; 15 | 16 | #------------------------------------------------------------------------------ 17 | 18 | # Add a dist and pin it... 19 | my $foo_and_bar = make_dist_archive('FooAndBar-1 = Foo~1; Bar~1'); 20 | $t->run_ok( 'Add', { author => 'ME', archives => $foo_and_bar } ); 21 | $t->run_ok( 'Pin', { targets => 'Foo' } ); 22 | 23 | $t->registration_ok('ME/FooAndBar-1/Foo~1/master/*'); 24 | $t->registration_ok('ME/FooAndBar-1/Bar~1/master/*'); 25 | 26 | # Now try and add a newer dist with an overlapping package... 27 | my $bar_and_baz = make_dist_archive('BarAndBaz-2 = Bar~2; Baz~2'); 28 | $t->run_throws_ok( 29 | 'Add', 30 | { author => 'ME', archives => $bar_and_baz }, 31 | qr{Unable to register}, 32 | 'Cannot upgrade pinned package' 33 | ); 34 | 35 | $t->stderr_like(qr{Bar is pinned}); 36 | 37 | # Now unpin the FooAndBar dist... 38 | $t->run_ok( 'Unpin', { targets => 'Foo' } ); 39 | $t->registration_ok('ME/FooAndBar-1/Foo~1/master/-'); 40 | $t->registration_ok('ME/FooAndBar-1/Bar~1/master/-'); 41 | 42 | # Try adding the newer BarAndBaz dist again... 43 | $t->run_ok( 'Add', { author => 'ME', archives => $bar_and_baz } ); 44 | $t->registration_ok('ME/BarAndBaz-2/Bar~2/master/-'); 45 | $t->registration_ok('ME/BarAndBaz-2/Baz~2/master/-'); 46 | 47 | # The older Foo and Bar packages should now be gone... 48 | $t->registration_not_ok('ME/FooAndBar-1/Foo~1/master/-'); 49 | $t->registration_not_ok('ME/FooAndBar-1/Bar~1/master/-'); 50 | 51 | # Now pin Bar... 52 | $t->run_ok( 'Pin', { targets => 'Bar' } ); 53 | 54 | # Foo-2 and Bar-2 should now be pinned... 55 | $t->registration_ok('ME/BarAndBaz-2/Bar~2/master/*'); 56 | $t->registration_ok('ME/BarAndBaz-2/Baz~2/master/*'); 57 | 58 | #------------------------------------------------------------------------------ 59 | 60 | done_testing; 61 | 62 | -------------------------------------------------------------------------------- /t/02-bowels/32-pin-rjbs.t: -------------------------------------------------------------------------------- 1 | 2 | #!perl 3 | 4 | use strict; 5 | use warnings; 6 | 7 | use Test::More; 8 | 9 | use lib 't/lib'; 10 | use Pinto::Tester; 11 | use Pinto::Tester::Util qw(make_dist_archive); 12 | 13 | #------------------------------------------------------------------------------ 14 | # This test follows RJBS' use case.... 15 | #------------------------------------------------------------------------------ 16 | 17 | my $cpan = Pinto::Tester->new; 18 | $cpan->populate( 'JOHN/DistA-1 = PkgA~1 & PkgB~1', 'FRED/DistB-1 = PkgB~1', ); 19 | 20 | #------------------------------------------------------------------------------ 21 | 22 | my $local = Pinto::Tester->new( init_args => { sources => $cpan->stack_url } ); 23 | 24 | # PkgA requires PkgB (above). MyDist requires both PkgA and PkgB... 25 | my $archive = make_dist_archive('MyDist-1=MyPkg-1 & PkgA~1; PkgB~1'); 26 | $local->run_ok( 'Add', { archives => $archive, author => 'ME' } ); 27 | 28 | # So we should have pulled in PkgA and PkgB... 29 | $local->registration_ok('JOHN/DistA-1/PkgA~1'); 30 | $local->registration_ok('FRED/DistB-1/PkgB~1'); 31 | 32 | # Now, suppose that PkgA and PkgB both are upgraded on CPAN 33 | $cpan->populate( 'JOHN/DistA-2 = PkgA~2 & PkgB~2', 'FRED/DistB-2 = PkgB~2', ); 34 | 35 | $local->clear_cache; # Make sure we get new index from CPAN 36 | 37 | # We would like to try and upgrade to PkgA-2. So create a new stack 38 | $local->run_ok( 'Copy', { stack => 'master', to_stack => 'xxx' } ); 39 | 40 | # Now upgrade to PkgA-2 on the xxx stack 41 | $local->run_ok( 'Pull', { targets => 'PkgA~2', stack => 'xxx' } ); 42 | 43 | # We should now have the new versions of both PkgA and PkgB on stack xxx 44 | $local->registration_ok('JOHN/DistA-2/PkgA~2/xxx'); 45 | $local->registration_ok('FRED/DistB-2/PkgB~2/xxx'); 46 | 47 | # But wait! We learn that PkgB-2 breaks our app. We want to be sure 48 | # we don't upgrade that. So pin it on the master (prod) stack 49 | $local->run_ok( 'Pin', { targets => 'PkgB' } ); 50 | 51 | # Make sure PkgB-1 is now pinned on master stack 52 | $local->registration_ok('FRED/DistB-1/PkgB~1/master/*'); 53 | 54 | # Ooo! Super cool DistC-1 is released to CPAN 55 | $cpan->populate('MARK/DistC-1 = PkgC~2 & PkgB~2'); 56 | 57 | $local->clear_cache; # Make sure we get new index from CPAN 58 | 59 | # We've gotta start using DistC-1 in production! But... 60 | $local->run_throws_ok( 'Pull', { targets => 'MARK/DistC-1.tar.gz' }, qr{Unable to register} ); 61 | 62 | # DistC-1 requires PkgB-2, but were are still pinned at PkgB-1... 63 | $local->stderr_like(qr{Unable to register .* PkgB is pinned to FRED/DistB-1/PkgB~1}); 64 | 65 | # After a while, we fix our code to work with PkgB-2, so we unpin... 66 | $local->run_ok( 'Unpin', { targets => 'PkgB' } ); 67 | 68 | # Make sure PkgB-1 is not pinned on the master stack... 69 | $local->registration_ok('FRED/DistB-1/PkgB~1/master/-'); 70 | 71 | #------------------------------------------------------------------------------ 72 | 73 | done_testing; 74 | -------------------------------------------------------------------------------- /t/02-bowels/35-delete.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use lib 't/lib'; 9 | use Pinto::Tester; 10 | 11 | #------------------------------------------------------------------------------ 12 | 13 | my $t = Pinto::Tester->new; 14 | 15 | #------------------------------------------------------------------------------ 16 | 17 | my $dist_auth = 'AUTHOR'; 18 | my $dist_name = 'Dist-1.0.tar.gz'; 19 | my $dist_path = "$dist_auth/$dist_name"; 20 | my @auth_dir = qw(authors id A AU AUTHOR); 21 | my @pkgs = qw(PkgA~1 PkgB~1); 22 | 23 | my @files_to_check = ( 24 | [ @auth_dir, $dist_name ], 25 | [ @auth_dir, 'CHECKSUMS' ], 26 | [ qw(stacks master), @auth_dir, $dist_name ], 27 | [ qw(stacks master), @auth_dir, 'CHECKSUMS' ], 28 | ); 29 | 30 | #------------------------------------------------------------------------------ 31 | 32 | # Add a dist... 33 | $t->populate( "$dist_auth/$dist_name=" . join ';', @pkgs ); 34 | $t->registration_ok("$dist_auth/$dist_name/$_/master/-") for @pkgs; 35 | 36 | # Now pin it... 37 | $t->run_ok( Pin => { targets => 'PkgA' } ); 38 | $t->registration_ok("AUTHOR/Dist-1.0/$_/master/*") for @pkgs; 39 | 40 | # Make extra sure it is really there 41 | $t->path_exists_ok($_) for @files_to_check; 42 | 43 | # Get the dist so we can look it up later 44 | my $repo = $t->pinto->repo; 45 | my $dist = $repo->get_distribution( author => $dist_auth, archive => $dist_name ); 46 | ok defined $dist, "Got distribution $dist_name back from DB"; 47 | 48 | #----------------------------------------------------------------------------- 49 | 50 | # Now try to delete 51 | $t->run_throws_ok( Delete => { targets => $dist_path }, qr/cannot be deleted/ ); 52 | 53 | # Delete with force 54 | $t->run_ok( Delete => { targets => $dist_path, force => 1 } ); 55 | 56 | # Now make sure it is gone 57 | my $dist_id = $dist->id; 58 | my $schema = $repo->db->schema; 59 | 60 | is $schema->search_distribution( { id => $dist_id } )->count, 0, 'Records are gone from distribution table'; 61 | 62 | is $schema->search_package( { distribution => $dist_id } )->count, 0, 'Records are gone from package table'; 63 | 64 | is $schema->search_registration( { distribution => $dist_id } )->count, 0, 'Records are gone from registration table'; 65 | 66 | # Make extra sure it is really gone 67 | $t->path_not_exists_ok($_) for @files_to_check; 68 | 69 | #------------------------------------------------------------------------------ 70 | 71 | done_testing; 72 | 73 | -------------------------------------------------------------------------------- /t/02-bowels/41-log.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use Pinto::Globals; 9 | 10 | use lib 't/lib'; 11 | use Pinto::Tester; 12 | use Pinto::Tester::Util qw(make_dist_archive); 13 | 14 | #------------------------------------------------------------------------------ 15 | 16 | my $t = Pinto::Tester->new; 17 | $Pinto::Globals::current_utc_time = 0; # Freeze time to begining of epoch 18 | $Pinto::Globals::current_time_offset = 0; # Freeze local timezone to UTC 19 | 20 | $t->run_ok( 21 | Add => { 22 | stack => 'master', 23 | archives => make_dist_archive("ME/Foo-0.01 = Foo~0.01") 24 | } 25 | ); 26 | 27 | $t->run_ok( 28 | Copy => { 29 | stack => 'master', 30 | to_stack => 'branch' 31 | } 32 | ); 33 | 34 | $t->run_ok( 35 | Add => { 36 | stack => 'branch', 37 | archives => make_dist_archive("ME/Bar-0.02 = Bar~0.02") 38 | } 39 | ); 40 | 41 | #------------------------------------------------------------------------------ 42 | subtest 'log master' => sub { 43 | 44 | my $stack = 'master'; 45 | $t->run_ok( Log => { stack => $stack } ); 46 | 47 | my $msgs = () = ${ $t->outstr } =~ m/revision [0-9a-f\-]{36}/g; 48 | is $msgs, 1, "Stack $stack has correct message count"; 49 | 50 | $t->stdout_like( qr/Foo-0.01.tar.gz/, 'Log message has Foo archive' ); 51 | 52 | # TODO: Consider adding hook to set username on the Tester; 53 | $t->stdout_like( qr/User: USERNAME/, 'Log message has correct user' ); 54 | 55 | # This test might not be portable, based on locale settings: 56 | $t->stdout_like( qr/Date: Jan 1, 1970/, 'Log message has correct date' ); 57 | 58 | }; 59 | 60 | #------------------------------------------------------------------------------ 61 | subtest 'log branch' => sub { 62 | 63 | my $stack = 'branch'; 64 | $t->run_ok( Log => { stack => $stack } ); 65 | 66 | my $msgs = () = ${ $t->outstr } =~ m/revision [0-9a-f\-]{36}/g; 67 | is $msgs, 2, "Stack $stack has correct message count"; 68 | 69 | $t->stdout_like( qr/Foo-0.01.tar.gz/, 'Log messages have Foo archive' ); 70 | $t->stdout_like( qr/Bar-0.02.tar.gz/, 'Log messages have Bar archive' ); 71 | 72 | }; 73 | 74 | #----------------------------------------------------------------------------- 75 | 76 | done_testing; 77 | -------------------------------------------------------------------------------- /t/02-bowels/43-install-and-pull.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::File; 8 | use Test::Exception; 9 | use Path::Class qw(dir); 10 | use Capture::Tiny qw(capture_stderr); 11 | 12 | use lib 't/lib'; 13 | use Pinto::Tester; 14 | use Pinto::Tester::Util qw(has_cpanm); 15 | use Pinto::Constants qw($PINTO_MINIMUM_CPANM_VERSION); 16 | use Pinto::Util qw(tempdir); 17 | 18 | #------------------------------------------------------------------------------ 19 | # To prevent mucking with user's ~/.cpanm 20 | local $ENV{PERL_CPANM_HOME} = tempdir->stringify(); 21 | 22 | #------------------------------------------------------------------------------ 23 | 24 | plan skip_all => "Need cpanm $PINTO_MINIMUM_CPANM_VERSION or newer" 25 | unless has_cpanm($PINTO_MINIMUM_CPANM_VERSION); 26 | 27 | #------------------------------------------------------------------------------ 28 | 29 | my $upstream = Pinto::Tester->new; 30 | $upstream->populate('JOHN/DistA-1 = PkgA~1'); 31 | 32 | my $local = Pinto::Tester->new( init_args => { sources => $upstream->stack_url } ); 33 | $local->populate('MARK/DistB-1 = PkgB~1 & PkgA~1'); 34 | 35 | #------------------------------------------------------------------------------ 36 | 37 | subtest 'Install while pulling upstream prereqs' => sub { 38 | 39 | my $sandbox = File::Temp->newdir; 40 | my $p5_dir = dir( $sandbox, qw(lib perl5) ); 41 | my %cpanm_opts = ( cpanm_options => { q => undef, L => $sandbox->dirname } ); 42 | 43 | my $stderr = capture_stderr { 44 | $local->run_ok( Install => { targets => ['PkgB'], %cpanm_opts, do_pull => 1 } ); 45 | }; 46 | 47 | file_exists_ok( $p5_dir->file('PkgA.pm') ); 48 | file_exists_ok( $p5_dir->file('PkgB.pm') ); 49 | }; 50 | 51 | #------------------------------------------------------------------------------ 52 | 53 | done_testing; 54 | 55 | -------------------------------------------------------------------------------- /t/02-bowels/52-intermingle.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use lib 't/lib'; 9 | use Pinto::Tester; 10 | 11 | #------------------------------------------------------------------------------ 12 | 13 | subtest 'Not intermingled' => sub { 14 | 15 | my $t = Pinto::Tester->new; 16 | $t->populate('AUTHOR/Dist-1 = PkgA~1; PkgB~1'); 17 | $t->populate('AUTHOR/Dist-2 = PkgB~2; PkgC~2'); 18 | 19 | # When intermingling is not allowed (which is the default) 20 | # distributions may not overlap. Adding a distribution 21 | # with the same package as an existing one causes all 22 | # packages from the existing distribution to be removed. 23 | 24 | $t->registration_not_ok('AUTHOR/Dist-1/PkgA~1'); 25 | $t->registration_not_ok('AUTHOR/Dist-1/PkgB~1'); 26 | 27 | $t->registration_ok('AUTHOR/Dist-2/PkgB~2'); 28 | $t->registration_ok('AUTHOR/Dist-2/PkgC~2'); 29 | 30 | }; 31 | 32 | #------------------------------------------------------------------------------ 33 | 34 | subtest 'Interminged' => sub { 35 | 36 | my $t = Pinto::Tester->new(init_args => {intermingle => 1}); 37 | $t->populate('AUTHOR/Dist-1 = PkgA~1; PkgB~1'); 38 | $t->populate('AUTHOR/Dist-2 = PkgB~2; PkgC~2'); 39 | 40 | # When intermingling is allowed, distributions can overlap. 41 | # This means the stack may contain only some of the packages 42 | # in the dist. This is how PAUSE acutally behaves. 43 | 44 | $t->registration_ok('AUTHOR/Dist-1/PkgA~1'); 45 | $t->registration_not_ok('AUTHOR/Dist-1/PkgB~1'); 46 | 47 | $t->registration_ok('AUTHOR/Dist-2/PkgB~2'); 48 | $t->registration_ok('AUTHOR/Dist-2/PkgC~2'); 49 | 50 | }; 51 | 52 | #------------------------------------------------------------------------------ 53 | done_testing; 54 | -------------------------------------------------------------------------------- /t/02-bowels/53-roots.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use lib 't/lib'; 9 | use Pinto::Tester; 10 | 11 | #------------------------------------------------------------------------------ 12 | 13 | subtest 'Basic' => sub { 14 | 15 | my $t = Pinto::Tester->new; 16 | $t->populate('ME/Dist-1 = PkgA~1 & PkgB~1'); 17 | $t->populate('ME/Dist-2 = PkgB~1 & PkgC~1'); 18 | $t->populate('ME/Dist-3 = PkgC~1'); 19 | $t->populate('ME/Dist-4 = PkgD~1'); 20 | 21 | $t->run_ok( Roots => {format => '%D'}); 22 | my @lines = split /\n/, ${ $t->outstr }; 23 | is_deeply \@lines, [qw(Dist-1 Dist-4)], 'Got expected roots'; 24 | }; 25 | 26 | #------------------------------------------------------------------------------ 27 | 28 | subtest 'Circular dependency' => sub { 29 | 30 | my $t = Pinto::Tester->new; 31 | $t->populate('ME/Dist-1 = PkgA~1 & PkgB~1'); 32 | $t->populate('ME/Dist-2 = PkgB~1 & PkgA~1'); 33 | 34 | $t->run_ok( Roots => {format => '%D'}); 35 | my @lines = split /\n/, ${ $t->outstr }; 36 | 37 | # TODO: Not sure what to do with circular dependencies; 38 | # is_deeply \@lines, [qw(Dist-1 Dist-2)], 'Got expected roots in circular dependency'; 39 | }; 40 | 41 | #----------------------------------------------------------------------------- 42 | 43 | done_testing; 44 | -------------------------------------------------------------------------------- /t/02-bowels/60-dryrun.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use lib 't/lib'; 9 | use Pinto::Tester; 10 | use Pinto::Tester::Util qw(make_dist_archive); 11 | 12 | #------------------------------------------------------------------------------ 13 | 14 | my $source = Pinto::Tester->new; 15 | $source->populate('JOHN/Baz-1.2 = Baz~1.2 & Nuts~2.3'); 16 | $source->populate('PAUL/Nuts-2.3 = Nuts~2.3'); 17 | 18 | #------------------------------------------------------------------------------ 19 | # Do a bunch of operations with dry_run=1, and make sure repos is still empty 20 | subtest 'dry run leaves repo empty' => sub { 21 | 22 | my $local = Pinto::Tester->new( init_args => { sources => $source->stack_url } ); 23 | 24 | $local->run_ok( 'Pull', { dry_run => 1, targets => 'Baz~1.2' } ); 25 | $local->repository_clean_ok; 26 | 27 | my $archive = make_dist_archive('Qux-2.0 = Qux~2.0'); 28 | 29 | $local->run_ok( 'Add', { dry_run => 1, archives => $archive } ); 30 | $local->repository_clean_ok; 31 | 32 | }; 33 | 34 | #------------------------------------------------------------------------------ 35 | 36 | done_testing; 37 | -------------------------------------------------------------------------------- /t/02-bowels/63-prereq-circular.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use Pinto::PrerequisiteWalker; 9 | 10 | use lib 't/lib'; 11 | use Pinto::Tester; 12 | 13 | #------------------------------------------------------------------------------ 14 | 15 | my $t = Pinto::Tester->new; 16 | 17 | # Foo -> Bar -> Baz -> Foo 18 | $t->populate('AUTHOR/Foo-1 = Foo-1 & Bar~1'); 19 | $t->populate('AUTHOR/Bar-1 = Bar-1 & Baz~1'); 20 | $t->populate('AUTHOR/Baz-1 = Baz-1 & Foo~1'); 21 | 22 | #------------------------------------------------------------------------------ 23 | subtest 'handle circular prerequisites' => sub { 24 | 25 | my $cb = sub { 26 | my ($prereq) = @_; 27 | my $dist = $t->pinto->repo->get_distribution( target => $prereq->as_target ); 28 | ok defined $dist, "Got distribution for prereq $prereq"; 29 | return $dist; 30 | }; 31 | 32 | my $dist = $t->get_distribution( author => 'AUTHOR', archive => 'Foo-1.tar.gz' ); 33 | my $walker = Pinto::PrerequisiteWalker->new( start => $dist, callback => $cb ); 34 | while ( $walker->next ) { } 35 | 36 | # All we need to do is make sure we get out... 37 | ok 1, 'Escaped circular dependencies'; 38 | 39 | }; 40 | 41 | #------------------------------------------------------------------------------ 42 | 43 | done_testing; 44 | -------------------------------------------------------------------------------- /t/02-bowels/63-prereq-core.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use Pinto::PrerequisiteWalker; 9 | 10 | use lib 't/lib'; 11 | use Pinto::Tester; 12 | 13 | #------------------------------------------------------------------------------ 14 | 15 | # Module::Build was first introduced in perl 5.9.4 as 0.2805 16 | # Module::Build~0.2808_01 entered perl in 5.10.0 17 | 18 | my $t = Pinto::Tester->new; 19 | $t->populate('AUTHOR/Foo-1 = Foo-1 & Bar~1; perl~5.6.0; strict'); 20 | $t->populate('AUTHOR/Bar-1 = Bar-1 & Module::Build~0.2808_01'); 21 | 22 | my $dist = $t->pinto->repo->get_distribution( path => 'A/AU/AUTHOR/Foo-1.tar.gz' ); 23 | ok defined $dist, 'Got Foo distribution from repo'; 24 | 25 | my @total_prereqs = $dist->prerequisites; 26 | is scalar @total_prereqs, 3, 'Dist Foo has correct number of prereqs'; 27 | 28 | #------------------------------------------------------------------------------ 29 | 30 | my %bar = ( 'Bar' => '1' ); 31 | my %mb = ( 'Module::Build' => '0.2808_01' ); 32 | my %core = ( 'perl' => 'v5.6.0', 'strict' => '0' ); 33 | 34 | my %test_cases = ( 35 | 'v5.10.0' => {%bar}, 36 | 'v5.9.4' => { %bar, %mb }, 37 | 'v5.6.0' => { %bar, %mb }, 38 | '0' => { %bar, %mb, %core }, 39 | ); 40 | 41 | while ( my ( $pv, $expect ) = each %test_cases ) { 42 | 43 | my $walked_prereqs = {}; 44 | 45 | my $cb = sub { 46 | my ($prereq) = @_; 47 | $walked_prereqs->{ $prereq->package_name } = $prereq->package_version; 48 | return $t->pinto->repo->get_distribution( target => $prereq->as_target ); 49 | }; 50 | 51 | # If $pv is not a true value, then do not make a filter 52 | my %filter = $pv ? ( filters => [ sub { $_[0]->is_perl || $_[0]->is_core( in => $pv ) } ] ) : (); 53 | 54 | my $walker = Pinto::PrerequisiteWalker->new( start => $dist, callback => $cb, %filter ); 55 | while ( $walker->next ) { } 56 | 57 | my $test_name = "Got expected prereqs against perl version $pv"; 58 | is_deeply $walked_prereqs, $expect, $test_name; 59 | } 60 | 61 | #------------------------------------------------------------------------------ 62 | 63 | done_testing; 64 | -------------------------------------------------------------------------------- /t/02-bowels/64-metadata.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use lib 't/lib'; 9 | use Pinto::Tester; 10 | use Pinto::Tester::Util qw(make_dist_archive); 11 | 12 | #------------------------------------------------------------------------------ 13 | # TODO: What we really need here are tests that verify what happens when a dist 14 | # has broken META (or no META at all). To do that, we need to hand-roll some 15 | # broken distribution archives and ship them along as test data 16 | #------------------------------------------------------------------------------ 17 | 18 | my $t = Pinto::Tester->new; 19 | $t->populate('AUTHOR/Foo-3 = Foo-4 & Bar~1; perl~5.6.0; strict'); 20 | my $dist = $t->get_distribution( author => 'AUTHOR', archive => 'Foo-3.tar.gz' ); 21 | ok defined $dist, 'Got the distribution back'; 22 | 23 | my $meta = $dist->metadata; 24 | isa_ok $meta, 'CPAN::Meta'; 25 | is $meta->as_struct->{version}, '3', 'META has correct dist version'; 26 | is $meta->as_struct->{provides}->{Foo}->{version}, '4', 'META has correct package version'; 27 | is $meta->as_struct->{'meta-spec'}->{version}, '2', 'META has correct meta spec version'; 28 | 29 | my $prereqs = $meta->as_struct->{prereqs}; 30 | is $prereqs->{runtime}->{requires}->{Bar}, '1', 'Requires Bar~1'; 31 | is $prereqs->{runtime}->{requires}->{perl}, 'v5.6.0', 'Requires perl~5.6.0'; 32 | is $prereqs->{runtime}->{requires}->{strict}, '0', 'Requires strict~0'; 33 | 34 | #------------------------------------------------------------------------------ 35 | 36 | done_testing; 37 | -------------------------------------------------------------------------------- /t/02-bowels/71-stack-kill.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Exception; 8 | 9 | use lib 't/lib'; 10 | use Pinto::Tester; 11 | use Pinto::Tester::Util qw(make_dist_archive); 12 | 13 | #------------------------------------------------------------------------------ 14 | subtest 'kill existing master stack' => sub { 15 | 16 | my $t = Pinto::Tester->new; 17 | 18 | # Check that master stack dir exists in the first place 19 | $t->path_exists_ok( [qw(stacks master)] ); 20 | 21 | # Put archive on the master stack. 22 | my $archive = make_dist_archive('Dist-1=PkgA~1'); 23 | $t->run_ok( Add => { archives => $archive, author => 'JOHN', recurse => 0 } ); 24 | $t->registration_ok('JOHN/Dist-1/PkgA~1/master'); 25 | 26 | # Copy the "master" stack to "dev" and make it the default 27 | $t->run_ok( Copy => { stack => 'master', to_stack => 'dev', default => 1 } ); 28 | $t->registration_ok('JOHN/Dist-1/PkgA~1/dev'); 29 | $t->stack_is_default_ok('dev'); 30 | 31 | # Delete the "master" stack. 32 | $t->run_ok( Kill => { stack => 'master' } ); 33 | $t->stack_not_exists_ok('master'); 34 | 35 | # The dev stack should still be the same 36 | $t->registration_ok('JOHN/Dist-1/PkgA~1/dev'); 37 | 38 | }; 39 | 40 | #------------------------------------------------------------------------------ 41 | subtest 'kill default stack' => sub { 42 | 43 | my $t = Pinto::Tester->new; 44 | 45 | # Make sure master is the default 46 | $t->stack_is_default_ok('master'); 47 | 48 | # Try killing the default stack 49 | $t->run_throws_ok( 50 | Kill => { stack => 'master' }, 51 | qr/Cannot kill the default stack/, 52 | 'Killing default stack throws exception' 53 | ); 54 | 55 | # Is stack still there? 56 | $t->stack_exists_ok('master'); 57 | 58 | }; 59 | 60 | #------------------------------------------------------------------------------ 61 | subtest 'kill locked stack' => sub { 62 | 63 | my $t = Pinto::Tester->new( init_args => { no_default => 1 } ); 64 | $t->no_default_stack_ok; 65 | 66 | # Lock the master stack 67 | $t->run_ok( Lock => { stack => 'master' } ); 68 | $t->stack_is_locked_ok('master'); 69 | 70 | # Try killing the locked stack 71 | $t->run_throws_ok( 72 | Kill => { stack => 'master' }, 73 | qr/is locked/, 74 | 'Killing locked stack throws exception' 75 | ); 76 | 77 | # Is stack still there? 78 | $t->stack_exists_ok('master'); 79 | 80 | # Try killing locked stack with force 81 | $t->run_ok( Kill => { stack => 'master', force => 1 } ); 82 | 83 | # Is stack still there? 84 | $t->stack_not_exists_ok('master'); 85 | 86 | }; 87 | 88 | #------------------------------------------------------------------------------ 89 | 90 | done_testing; 91 | -------------------------------------------------------------------------------- /t/02-bowels/72-stack-rename.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Exception; 8 | 9 | use lib 't/lib'; 10 | use Pinto::Tester; 11 | use Pinto::Tester::Util qw(make_dist_archive); 12 | 13 | #------------------------------------------------------------------------------ 14 | subtest 'rename master stack' => sub { 15 | 16 | my $t = Pinto::Tester->new; 17 | my $archive = make_dist_archive('Dist-1=PkgA~1'); 18 | 19 | # Put archive on the master stack. 20 | $t->run_ok( Add => { archives => $archive, author => 'JOHN', recurse => 0 } ); 21 | $t->registration_ok('JOHN/Dist-1/PkgA~1/master'); 22 | 23 | # Rename the master stack. 24 | $t->run_ok( Rename => { stack => 'master', to_stack => 'dev' } ); 25 | $t->registration_ok('JOHN/Dist-1/PkgA~1/dev'); 26 | 27 | # Can't use old stack name any more 28 | throws_ok { $t->pinto->repo->get_stack('master') } qr/does not exist/; 29 | 30 | # Renamed stack should still be the default 31 | $t->stack_is_default_ok( 'dev', 'after renaming stack' ); 32 | 33 | # Check the filesystem 34 | $t->path_not_exists_ok( [qw(stacks master)] ); 35 | $t->path_exists_ok( [qw(stacks dev modules 02packages.details.txt.gz)] ); 36 | $t->path_exists_ok( [qw(stacks dev modules 03modlist.data.gz)] ); 37 | $t->path_exists_ok( [qw(stacks dev authors 01mailrc.txt.gz)] ); 38 | 39 | }; 40 | 41 | #------------------------------------------------------------------------------ 42 | subtest 'compare stacks' => sub { 43 | 44 | my $t = Pinto::Tester->new; 45 | 46 | $t->path_exists_ok( [qw(stacks master)] ); 47 | #$t->path_not_exists_ok( [qw(stacks MASTER)] ); 48 | 49 | my $master = $t->get_stack('master'); 50 | $t->run_ok( Rename => { stack => 'master', to_stack => 'MASTER' } ); 51 | my $MASTER = $t->get_stack('master'); 52 | 53 | $t->path_exists_ok( [qw(stacks MASTER)] ); 54 | #$t->path_not_exists_ok( [qw(stacks master)] ); 55 | 56 | is($master->id, $MASTER->id, 'Stacks are the same') 57 | 58 | }; 59 | 60 | #------------------------------------------------------------------------------ 61 | subtest 'rename non-existant stack' => sub { 62 | 63 | my $t = Pinto::Tester->new; 64 | $t->run_throws_ok( 65 | Rename => { stack => 'bogus', to_stack => 'whatever' }, 66 | qr/does not exist/, 'Cannot rename non-existant stack' 67 | ); 68 | 69 | $t->run_ok( New => { stack => 'existing' } ); 70 | 71 | $t->run_throws_ok( 72 | Rename => { stack => 'master', to_stack => 'existing' }, 73 | qr/already exists/, 'Cannot rename to stack that already exists' 74 | ); 75 | 76 | $t->run_throws_ok( 77 | Rename => { stack => 'existing', to_stack => 'existing' }, 78 | qr/already exists/, 'Cannot rename to stack to itself' 79 | ); 80 | 81 | }; 82 | 83 | #------------------------------------------------------------------------------ 84 | 85 | done_testing; 86 | -------------------------------------------------------------------------------- /t/02-bowels/73-stack-lock.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use lib 't/lib'; 9 | use Pinto::Tester; 10 | use Pinto::Tester::Util qw(make_dist_archive); 11 | 12 | #------------------------------------------------------------------------------ 13 | subtest 'stack lock' => sub { 14 | 15 | my $t = Pinto::Tester->new->populate('AUTHOR/Foo-1=Foo~1'); 16 | my $archive = make_dist_archive('Foo-2=Foo~2'); 17 | 18 | # First, assert stack is initially unlocked 19 | $t->stack_is_not_locked_ok('master'); 20 | 21 | # Now lock the stack 22 | $t->run_ok( Lock => {} ); 23 | $t->stack_is_locked_ok('master'); 24 | 25 | # Try and modify the stack 26 | $t->run_throws_ok( 27 | Add => { archives => $archive }, 28 | qr/is locked/, 'Cannot Add to locked stack' 29 | ); 30 | 31 | $t->run_throws_ok( 32 | Pin => { targets => 'Foo' }, 33 | qr/is locked/, 'Cannot Pin on locked stack' 34 | ); 35 | 36 | $t->run_throws_ok( 37 | Unpin => { targets => 'Foo' }, 38 | qr/is locked/, 'Cannot Unpin on locked stack' 39 | ); 40 | 41 | $t->run_throws_ok( 42 | Unregister => { targets => 'AUTHOR/Foo-1.tar.gz' }, 43 | qr/is locked/, 'Cannot Unregister from locked stack' 44 | ); 45 | 46 | $t->run_throws_ok( 47 | Register => { targets => 'AUTHOR/Foo-1.tar.gz' }, 48 | qr/is locked/, 'Cannot Register on locked stack' 49 | ); 50 | 51 | # Now unlock the stack 52 | $t->run_ok( Unlock => {} ); 53 | $t->stack_is_not_locked_ok('master'); 54 | 55 | # Try modifying again 56 | $t->run_ok( Add => { archives => $archive } ); 57 | $t->run_ok( Pin => { targets => 'Foo' } ); 58 | $t->run_ok( Unpin => { targets => 'Foo' } ); 59 | $t->run_ok( Unregister => { targets => 'AUTHOR/Foo-2.tar.gz' } ); 60 | $t->run_ok( Register => { targets => 'AUTHOR/Foo-2.tar.gz' } ); 61 | 62 | }; 63 | 64 | #------------------------------------------------------------------------------ 65 | 66 | done_testing; 67 | 68 | -------------------------------------------------------------------------------- /t/02-bowels/74-stack-default.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use Test::More; 4 | use Test::Exception; 5 | 6 | use lib 't/lib'; 7 | use Pinto::Tester; 8 | 9 | #------------------------------------------------------------------------------ 10 | subtest 'stack default' => sub { 11 | 12 | my $t = Pinto::Tester->new; 13 | $t->stack_is_default_ok('master'); 14 | 15 | $t->run_ok( New => { stack => 'dev' } ); 16 | $t->stack_is_not_default_ok('dev'); 17 | 18 | $t->run_ok( Default => { stack => 'dev' } ); 19 | $t->stack_is_default_ok('dev'); 20 | $t->stack_is_not_default_ok('master'); 21 | 22 | $t->run_ok( Default => { none => 1 } ); 23 | $t->stack_is_not_default_ok('master'); 24 | $t->stack_is_not_default_ok('dev'); 25 | $t->no_default_stack_ok; 26 | 27 | throws_ok { $t->pinto->repo->get_stack } 28 | qr/default stack has not been set/, 29 | 'There is no default stack at all'; 30 | 31 | $t->path_not_exists_ok( [qw(modules)] ); 32 | 33 | }; 34 | 35 | #------------------------------------------------------------------------------ 36 | 37 | done_testing; 38 | 39 | -------------------------------------------------------------------------------- /t/02-bowels/75-stack-props.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Exception; 8 | 9 | use lib 't/lib'; 10 | use Pinto::Tester; 11 | 12 | #------------------------------------------------------------------------------ 13 | 14 | my $t = Pinto::Tester->new; 15 | 16 | #------------------------------------------------------------------------------ 17 | subtest 'create stack' => sub { 18 | 19 | # Create a stack... 20 | my $stack = $t->pinto->repo->create_stack( name => 'test' ); 21 | 22 | # Set a property... 23 | $stack->set_property( a => 1 ); 24 | is $stack->get_property('a'), 1, 'set/get one property'; 25 | 26 | # Set several properties... 27 | $stack->set_properties( { b => 2, c => 3 } ); 28 | is_deeply $stack->get_properties, { a => 1, b => 2, c => 3 }, 'get/set many props at once'; 29 | 30 | # Copy stack... 31 | my $new_stack = $t->pinto->repo->copy_stack( stack => $stack, name => 'qa' ); 32 | my $new_props = $new_stack->get_properties; 33 | 34 | # All the copied properties should be identical 35 | is_deeply $new_props, $stack->get_properties, 'Copied stack has same properties'; 36 | 37 | # Delete a property... 38 | $new_stack->delete_property('a'); 39 | ok !exists $new_stack->get_properties->{'a'}, 'Deleted a prop'; 40 | 41 | # Delete a property by setting to empty string... 42 | $new_stack->set_property( a => '' ); 43 | ok !exists $new_stack->get_properties->{'a'}, 'Deleted a prop by setting to empty'; 44 | 45 | # Invalid property name.. 46 | throws_ok { $new_stack->set_property( 'foo#bar' => 4 ) } qr{Invalid property name}; 47 | 48 | # Property names forced to lowercase... 49 | $new_stack->set_property( SHOUTING => 4 ); 50 | ok exists $new_stack->get_properties->{'shouting'}, 'Get/Set property irrespective of case'; 51 | 52 | # Property names forced to lowercase... 53 | $new_stack->delete_property('ShOuTiNg'); 54 | ok !exists $new_stack->get_properties->{'shouting'}, 'Delete property irrespective of case'; 55 | 56 | }; 57 | 58 | #------------------------------------------------------------------------------ 59 | 60 | done_testing; 61 | 62 | -------------------------------------------------------------------------------- /t/03-remote/01-requests.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::LWP::UserAgent; 8 | 9 | use JSON; 10 | use HTTP::Body; 11 | use HTTP::Response; 12 | use File::Temp; 13 | 14 | use Pinto::Remote; 15 | use Pinto::Globals; 16 | use Pinto::Constants qw($PINTO_DEFAULT_PALETTE $PINTO_PROTOCOL_ACCEPT); 17 | 18 | #----------------------------------------------------------------------------- 19 | subtest 'request dialog' => sub { 20 | 21 | local $ENV{PINTO_PALETTE} = undef; 22 | my $ua = local $Pinto::Globals::UA = Test::LWP::UserAgent->new; 23 | 24 | my $res = HTTP::Response->new(200); 25 | $ua->map_response( qr{.*} => $res ); 26 | 27 | my $action = 'Add'; 28 | my $temp = File::Temp->new; 29 | my %pinto_args = ( username => 'myname' ); 30 | my %chrome_args = ( verbose => 2, color => 0, quiet => 0, palette => $PINTO_DEFAULT_PALETTE ); 31 | my %action_args = ( archives => [ $temp->filename ], author => 'ME', stack => 'mystack' ); 32 | 33 | my $chrome = Pinto::Chrome::Term->new(%chrome_args); 34 | my $pinto = Pinto::Remote->new( root => 'http://myhost:3111', chrome => $chrome, %pinto_args ); 35 | $pinto->run( $action, %action_args ); 36 | 37 | my $req = $ua->last_http_request_sent; 38 | is $req->method, 'POST', "Correct HTTP method in request for action $action"; 39 | is $req->uri, 'http://myhost:3111/action/add', "Correct uri in request for action $action"; 40 | is $req->header('Accept'), $PINTO_PROTOCOL_ACCEPT, 'Accept header'; 41 | 42 | my $req_params = parse_req_params($req); 43 | my $got_chrome_args = decode_json( $req_params->{chrome} ); 44 | my $got_pinto_args = decode_json( $req_params->{pinto} ); 45 | my $got_action_args = decode_json( $req_params->{action} ); 46 | 47 | my $got_time_offset = delete $got_pinto_args->{time_offset}; 48 | is $got_time_offset, DateTime->now(time_zone => 'local')->offset, 'Correct time_offset'; 49 | 50 | is_deeply $got_chrome_args, \%chrome_args, "Correct chrome args in request for action $action"; 51 | is_deeply $got_pinto_args, \%pinto_args, "Correct pinto args in request for action $action"; 52 | is_deeply $got_action_args, \%action_args, "Correct action args in request for action $action"; 53 | 54 | }; 55 | 56 | #----------------------------------------------------------------------------- 57 | 58 | sub parse_req_params { 59 | my ($req) = @_; 60 | my $type = $req->header('Content-Type'); 61 | my $length = $req->header('Content-Length'); 62 | my $hb = HTTP::Body->new( $type, $length ); 63 | $hb->add( $req->content ); 64 | return $hb->param; 65 | } 66 | 67 | #----------------------------------------------------------------------------- 68 | 69 | done_testing; 70 | -------------------------------------------------------------------------------- /t/03-remote/02-responses.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::LWP::UserAgent 0.018; # Older versions caused this test to fail 8 | 9 | use IO::String; 10 | use HTTP::Response; 11 | 12 | use Pinto::Remote; 13 | use Pinto::Globals; 14 | use Pinto::Chrome::Term; 15 | use Pinto::Constants qw(:server :protocol); 16 | 17 | #----------------------------------------------------------------------------- 18 | subtest 'response dialog' => sub { 19 | 20 | my $ua = local $Pinto::Globals::UA = Test::LWP::UserAgent->new; 21 | 22 | my $res = HTTP::Response->new(200); 23 | $res->content("DATA-GOES-HERE\n## DIAG-MSG-HERE\n$PINTO_PROTOCOL_STATUS_OK\n"); 24 | $ua->map_response( qr{.*}, $res ); 25 | 26 | my $out_buffer = ''; 27 | my $out_fh = IO::String->new( \$out_buffer ); 28 | 29 | my $err_buffer = ''; 30 | my $err_fh = IO::String->new( \$err_buffer ); 31 | 32 | my $chrome = Pinto::Chrome::Term->new( stdout => $out_fh, stderr => $err_fh ); 33 | my $pinto = Pinto::Remote->new( chrome => $chrome, root => $PINTO_SERVER_DEFAULT_ROOT ); 34 | my $result = $pinto->run('List'); 35 | 36 | is $result->was_successful, 1, 'Got successful result' or diag $err_buffer; 37 | 38 | is $out_buffer, "DATA-GOES-HERE\n", 'Got correct data output'; 39 | 40 | is $err_buffer, "DIAG-MSG-HERE\n", 'Got correct diagnostic output'; 41 | 42 | }; 43 | 44 | #----------------------------------------------------------------------------- 45 | 46 | done_testing; 47 | -------------------------------------------------------------------------------- /t/03-remote/05-timezone.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use DateTime; 8 | 9 | use Pinto::Remote; 10 | 11 | use lib 't/lib'; 12 | use Pinto::Server::Tester; 13 | use Pinto::Tester::Util qw(make_dist_archive); 14 | 15 | #------------------------------------------------------------------------------ 16 | 17 | my $t = Pinto::Server::Tester->new->start_server; 18 | plan skip_all => "Can't open connection to $t" unless $t->can_connect; 19 | 20 | #------------------------------------------------------------------------------ 21 | 22 | subtest 'User vs Local vs UTC time' => sub { 23 | 24 | $Pinto::Globals::UA->no_proxy("localhost"); # See GH #202 25 | 26 | my $remote = Pinto::Remote->new( root => $t->server_url ); 27 | my $archive = make_dist_archive('AUTHOR/DistA-1 = PkgA~1'); 28 | 29 | my $offset = 10; 30 | 31 | { 32 | local $Pinto::Globals::current_time_offset = $offset; 33 | my $result = $remote->run( Add => ( archives => [$archive->stringify] ) ); 34 | ok $result->was_successful, 'Add action was successful'; 35 | } 36 | 37 | my $rev = $t->get_stack->head; 38 | my $utc_time = $rev->utc_time; 39 | 40 | is $rev->time_offset, $offset, 'Time offset'; 41 | 42 | is $rev->datetime->epoch, $utc_time, 'UTC datetime'; 43 | is $rev->datetime_user->epoch, $utc_time, 'User datetime utc'; 44 | is $rev->datetime_local->epoch, $utc_time, 'Local datetime utc'; 45 | 46 | my $local_offset = DateTime->now( time_zone => 'local' )->offset; 47 | 48 | is $rev->datetime->offset, 0, 'UTC datetime offset'; 49 | is $rev->datetime_user->offset, $offset, 'User datetime offset'; 50 | is $rev->datetime_local->offset, $local_offset, 'Local datetime offset'; 51 | 52 | is $rev->to_string('%u'), $rev->datetime_local->strftime('%c'), 53 | 'Stringify to local time'; 54 | }; 55 | #------------------------------------------------------------------------------ 56 | done_testing; 57 | 58 | -------------------------------------------------------------------------------- /t/04-server/03-security.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Plack::Test; 8 | 9 | use HTTP::Request::Common; 10 | 11 | use Pinto::Server; 12 | 13 | use lib 't/lib'; 14 | use Pinto::Tester; 15 | 16 | #------------------------------------------------------------------------------ 17 | # Setup... 18 | 19 | my $t = Pinto::Tester->new; 20 | my %opts = ( root => $t->pinto->root ); 21 | my $app = Pinto::Server->new(%opts)->to_app; 22 | 23 | #------------------------------------------------------------------------------ 24 | # GET a path outside the repository 25 | 26 | test_psgi 27 | app => $app, 28 | client => sub { 29 | my $cb = shift; 30 | 31 | my $base = 'foobar.txt'; 32 | my $file = $t->pinto->root->parent->file("$base"); 33 | 34 | unless ($file->open('w')) { 35 | pass && diag 'Cannot create test file, skipping test'; 36 | return; 37 | } 38 | 39 | my $req = GET("../$base"); 40 | is $cb->($req)->code, 404, 'Status of files outside repo'; 41 | $file->remove if -e $file; 42 | }; 43 | 44 | #------------------------------------------------------------------------------ 45 | 46 | done_testing; 47 | 48 | -------------------------------------------------------------------------------- /weaver.ini: -------------------------------------------------------------------------------- 1 | [@CorePrep] ; [@Default] 2 | 3 | [-SingleEncoding] ; Assume UTF-8 encoding for all files 4 | 5 | [-StopWords] ; generate some stopwords and gather them together 6 | 7 | [Name] ; [@Default] 8 | 9 | [Version] ; [@Default] 10 | 11 | [Generic / SYNOPSIS] ; [@Default] 12 | 13 | [Generic / DESCRIPTION] ; [@Default] 14 | 15 | [Collect / ATTRIBUTES] ; [@Default] 16 | command = attr 17 | 18 | [Collect / METHODS] ; [@Default] 19 | command = method 20 | 21 | [Collect / FUNCTIONS] ; [@Default] 22 | command = func 23 | 24 | [Leftovers] ; [@Default] 25 | 26 | [Support] 27 | bugs_content = {WEB} 28 | bugs = metadata 29 | irc = irc.perl.org, #pinto, thaljef 30 | websites = metacpan, ratings, kwalitee, testers, testmatrix, deps 31 | 32 | [Contributors] 33 | 34 | [Authors] ; [@Default] 35 | 36 | [Legal] ; [@Default] 37 | -------------------------------------------------------------------------------- /xt/help/50-manual_cmd.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use warnings; 4 | use strict; 5 | 6 | use Test::More; 7 | use Test::Trap qw| 8 | trap $trap 9 | :flow 10 | :stderr(systemsafe) 11 | :stdout(systemsafe) 12 | :warn 13 | |; 14 | 15 | #------------------------------------------------------------------------------- 16 | 17 | subtest 'manual for valid command' => sub { 18 | run_cmd_and_trap( 'manual', 'init' ); 19 | 20 | like( 21 | $trap->stdout, qr/creates a new repository/i, 22 | qq['init' manual page returned] 23 | ); 24 | }; 25 | 26 | #------------------------------------------------------------------------------- 27 | 28 | subtest 'manual for invalid command' => sub { 29 | run_cmd_and_trap( 'manual', 'foobar' ); 30 | 31 | like( 32 | $trap->stdout, qr/unrecognized command/i, 33 | qq['foobar' doesn't exist] 34 | ); 35 | 36 | unlike( 37 | $trap->stdout, qr/App::Cmd::Command::commands/, 38 | qq[A wrong manpage is not returned] 39 | ); 40 | 41 | TODO: { 42 | local $TODO = 'Difficult to subvert App::Cmd here'; 43 | unlike( 44 | $trap->stdout, qr/Usage:/, 45 | qq[Usage is not attempted to be printed] 46 | ); 47 | }; 48 | }; 49 | 50 | #------------------------------------------------------------------------------- 51 | # (App::Cmd::Tester doesn't capture pod2usage() pager output) 52 | 53 | sub run_cmd_and_trap { 54 | my (@args) = @_; 55 | my $program_name = 'pinto'; 56 | 57 | local $ENV{PINTO_HOME} = undef; 58 | my @cmd = ( "perl", "-Ilib", "bin/${program_name}" ); 59 | 60 | diag("\$ $program_name @args"); 61 | my @r = trap { system( @cmd, @args ) }; 62 | 63 | return @r; 64 | } 65 | 66 | #------------------------------------------------------------------------------- 67 | done_testing; 68 | -------------------------------------------------------------------------------- /xt/release/02-workarounds.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | 8 | use lib 't/lib'; 9 | use Pinto::Tester; 10 | 11 | #------------------------------------------------------------------------------ 12 | note("This test requires a live internet connection to pull stuff from CPAN"); 13 | #------------------------------------------------------------------------------ 14 | 15 | # FCGI and common::sense both generate the .pm files at build time. So it 16 | # appears that they don't have any packages. The PackageExctractor class 17 | # has workaround for these 18 | 19 | for my $pkg (qw(common::sense FCGI Net::LibIDN)) { 20 | my $t = Pinto::Tester->new; 21 | $t->run_ok( Pull => { targets => $pkg } ); 22 | $t->run_ok( List => {} ); 23 | $t->stdout_like( qr{$pkg}, "$pkg registered ok" ); 24 | } 25 | 26 | #------------------------------------------------------------------------------ 27 | # For inexplicable reasons, pulling DateTime::TimeZone causes Pinto to blow 28 | # up on perl 5.14.x (and possibly others). It has something to do with 29 | # Class::Load claiming that a module is already loaded when it really isn't. 30 | 31 | for my $pkg (qw(DateTime::TimeZone)) { 32 | my $t = Pinto::Tester->new; 33 | $t->run_ok( Pull => { targets => $pkg } ); 34 | $t->run_ok( List => {} ); 35 | $t->stdout_like( qr{$pkg}, "$pkg registered ok" ); 36 | } 37 | 38 | #------------------------------------------------------------------------------ 39 | # Module::Metadata mistakenly thinks that EU::MM has a "version" package. 40 | # See https://github.com/thaljef/Pinto/issues/204 for all the gory details 41 | #------------------------------------------------------------------------------ 42 | { 43 | my $t = Pinto::Tester->new; 44 | $t->run_ok( Pull => { targets => 'version@0.9912' } ); 45 | $t->registration_ok('JPEACOCK/version-0.9912/version~0.9912'); 46 | 47 | $t->run_ok( Pull => { targets => 'ExtUtils::MakeMaker@7.04' } ); 48 | $t->registration_ok('JPEACOCK/version-0.9912/version~0.9912'); 49 | } 50 | 51 | done_testing; 52 | 53 | -------------------------------------------------------------------------------- /xt/release/03-stratopan-live.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use URI; 8 | 9 | use lib 't/lib'; 10 | use Pinto::Tester; 11 | 12 | use Pinto::Constants qw(:stratopan); 13 | 14 | #------------------------------------------------------------------------------ 15 | 16 | note("This test requires a live internet connection to contact stratopan"); 17 | 18 | #------------------------------------------------------------------------------ 19 | 20 | my $stratopan_host = $PINTO_STRATOPAN_CPAN_URI->host; 21 | 22 | #------------------------------------------------------------------------------ 23 | 24 | subtest 'Pull precise version' => sub { 25 | 26 | my $t = Pinto::Tester->new(init_args => {recurse => 0}); 27 | $t->run_ok( Pull => { targets => 'Pinto==0.094'} ); 28 | $t->registration_ok('THALJEF/Pinto-0.094/Pinto~0.094'); 29 | 30 | my $target = Pinto::Target->new('THALJEF/Pinto-0.094.tar.gz'); 31 | my $dist = $t->get_distribution(target => $target); 32 | my $uri = URI->new($dist->source); 33 | is $uri->host, $stratopan_host, 'Dist came from Stratopan'; 34 | }; 35 | 36 | #------------------------------------------------------------------------------ 37 | 38 | subtest 'Pull version range' => sub { 39 | 40 | my $t = Pinto::Tester->new(init_args => {recurse => 0}); 41 | $t->run_ok( Pull => { targets => 'Pinto>=0.084,!=0.085,<0.087'} ); 42 | $t->registration_ok('THALJEF/Pinto-0.086/Pinto~0.086'); 43 | 44 | my $target = Pinto::Target->new('THALJEF/Pinto-0.086.tar.gz'); 45 | my $dist = $t->get_distribution(target => $target); 46 | my $uri = URI->new($dist->source); 47 | is $uri->host, $stratopan_host, 'Dist came from Stratopan'; 48 | }; 49 | 50 | #------------------------------------------------------------------------------ 51 | 52 | subtest 'Pull development version' => sub { 53 | 54 | my $t = Pinto::Tester->new(init_args => {recurse => 0}); 55 | $t->run_ok( Pull => { targets => 'Pinto==0.097_01'} ); 56 | $t->registration_ok('THALJEF/Pinto-0.097_01/Pinto~0.097_01'); 57 | 58 | my $target = Pinto::Target->new('THALJEF/Pinto-0.097_01.tar.gz'); 59 | my $dist = $t->get_distribution(target => $target); 60 | my $uri = URI->new($dist->source); 61 | is $uri->host, $stratopan_host, 'Dist came from Stratopan'; 62 | }; 63 | 64 | #------------------------------------------------------------------------------ 65 | 66 | subtest 'Pull distribution' => sub { 67 | 68 | my $t = Pinto::Tester->new(init_args => {recurse => 0}); 69 | $t->run_ok( Pull => { targets => 'THALJEF/Pinto-0.065'} ); 70 | $t->registration_ok('THALJEF/Pinto-0.065/Pinto~0.065'); 71 | 72 | my $target = Pinto::Target->new('THALJEF/Pinto-0.065.tar.gz'); 73 | my $dist = $t->get_distribution(target => $target); 74 | my $uri = URI->new($dist->source); 75 | is $uri->host, $stratopan_host, 'Dist came from Stratopan'; 76 | }; 77 | 78 | #------------------------------------------------------------------------------ 79 | done_testing; 80 | -------------------------------------------------------------------------------- /xt/release/99-memory-cycle.t: -------------------------------------------------------------------------------- 1 | #!perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Test::More; 7 | use Test::Memory::Cycle; 8 | 9 | use lib 't/lib'; 10 | use Pinto::Tester; 11 | 12 | #------------------------------------------------------------------------------ 13 | note("This test requires a live internet connection to pull stuff from CPAN"); 14 | 15 | #------------------------------------------------------------------------------ 16 | 17 | { 18 | my $t = Pinto::Tester->new; 19 | 20 | my $result = $t->run_ok( Pull => { targets => 'Perl::Critic' } ); 21 | memory_cycle_ok( $t->pinto ); 22 | memory_cycle_ok($result); 23 | } 24 | 25 | #------------------------------------------------------------------------------ 26 | 27 | { 28 | 29 | # Throwable::Error has a memory leak. I've submitted a patch (and patched 30 | # my own installation) but it hasn't been released yet. 31 | 32 | my $t = Pinto::Tester->new; 33 | 34 | no warnings qw(once redefine); 35 | local *Pinto::ArchiveExtractor::requires = sub { die 'FAKE ERROR' }; 36 | 37 | my $result = $t->run_ok( Pull => { targets => 'Perl::Critic' } ); 38 | memory_cycle_ok( $t->pinto ); 39 | memory_cycle_ok($result); 40 | } 41 | 42 | #------------------------------------------------------------------------------ 43 | 44 | done_testing; 45 | --------------------------------------------------------------------------------