diff options
Diffstat (limited to 'lib')
30 files changed, 2035 insertions, 0 deletions
diff --git a/lib/Carton.pm b/lib/Carton.pm new file mode 100644 index 0000000..7546c77 --- /dev/null +++ b/lib/Carton.pm @@ -0,0 +1,179 @@ +package Carton; +use strict; +use 5.008_005; +use version; our $VERSION = version->declare("v1.0.21"); + +1; +__END__ + +=head1 NAME + +Carton - Perl module dependency manager (aka Bundler for Perl) + +=head1 SYNOPSIS + + # On your development environment + > cat cpanfile + requires 'Plack', '0.9980'; + requires 'Starman', '0.2000'; + + > carton install + > git add cpanfile cpanfile.snapshot + > git commit -m "add Plack and Starman" + + # Other developer's machine, or on a deployment box + > carton install + > carton exec starman -p 8080 myapp.psgi + +=head1 AVAILABILITY + +Carton only works with perl installation with the complete set of core +modules. If you use perl installed by a vendor package with modules +stripped from core, Carton is not expected to work correctly. + +Also, Carton requires you to run your command/application with +C<carton exec> command, which means it's difficult or impossible to +run in an embedded perl use case such as mod_perl. + +=head1 DESCRIPTION + +carton is a command line tool to track the Perl module dependencies +for your Perl application. Dependencies are declared using L<cpanfile> +format, and the managed dependencies are tracked in a +I<cpanfile.snapshot> file, which is meant to be version controlled, +and the snapshot file allows other developers of your application will +have the exact same versions of the modules. + +For C<cpanfile> syntax, see L<cpanfile> documentation. + +=head1 TUTORIAL + +=head2 Initializing the environment + +carton will use the I<local> directory to install modules into. You're +recommended to exclude these directories from the version control +system. + + > echo local/ >> .gitignore + > git add cpanfile cpanfile.snapshot + > git commit -m "Start using carton" + +=head2 Tracking the dependencies + +You can manage the dependencies of your application via C<cpanfile>. + + # cpanfile + requires 'Plack', '0.9980'; + requires 'Starman', '0.2000'; + +And then you can install these dependencies via: + + > carton install + +The modules are installed into your I<local> directory, and the +dependencies tree and version information are analyzed and saved into +I<cpanfile.snapshot> in your directory. + +Make sure you add I<cpanfile> and I<cpanfile.snapshot> to your version +controlled repository and commit changes as you update +dependencies. This will ensure that other developers on your app, as +well as your deployment environment, use exactly the same versions of +the modules you just installed. + + > git add cpanfile cpanfile.snapshot + > git commit -m "Added Plack and Starman" + +=head2 Deploying your application + +Once you've done installing all the dependencies, you can push your +application directory to a remote machine (excluding I<local> and +I<.carton>) and run the following command: + + > carton install --deployment + +This will look at the I<cpanfile.snapshot> and install the exact same +versions of the dependencies into I<local>, and now your application +is ready to run. + +The C<--deployment> flag makes sure that carton will only install +modules and versions available in your snapshot, and won't fallback to +query for CPAN Meta DB for missing modules. + +=head2 Bundling modules + +carton can bundle all the tarballs for your dependencies into a +directory so that you can even install dependencies that are not +available on CPAN, such as internal distribution aka DarkPAN. + + > carton bundle + +will bundle these tarballs into I<vendor/cache> directory, and + + > carton install --cached + +will install modules using this local cache. Combined with +C<--deployment> option, you can avoid querying for a database like +CPAN Meta DB or downloading files from CPAN mirrors upon deployment +time. + +=head1 PERL VERSIONS + +When you take a snapshot in one perl version and deploy on another +(different) version, you might have troubles with core modules. + +The simplest solution, which might not work for everybody, is to use +the same version of perl in the development and deployment. + +To enforce that, you're recommended to use L<plenv> and +C<.perl-version> to lock perl versions in development. + +You can also specify the minimum perl required in C<cpanfile>: + + requires 'perl', '5.16.3'; + +and carton (and cpanm) will give you errors when deployed on hosts +with perl lower than the specified version. + +=head1 COMMUNITY + +=over 4 + +=item L<https://github.com/miyagawa/carton> + +Code repository, Wiki and Issue Tracker + +=item L<irc://irc.perl.org/#carton> + +IRC chat room + +=back + +=head1 AUTHOR + +Tatsuhiko Miyagawa + +=head1 COPYRIGHT + +Tatsuhiko Miyagawa 2011- + +=head1 LICENSE + +This software is licensed under the same terms as Perl itself. + +=head1 SEE ALSO + +L<cpanm> + +L<cpanfile> + +L<Bundler|http://gembundler.com/> + +L<pip|http://pypi.python.org/pypi/pip> + +L<npm|http://npmjs.org/> + +L<perlrocks|https://github.com/gugod/perlrocks> + +L<only> + +=cut diff --git a/lib/Carton/Builder.pm b/lib/Carton/Builder.pm new file mode 100644 index 0000000..de456d7 --- /dev/null +++ b/lib/Carton/Builder.pm @@ -0,0 +1,114 @@ +package Carton::Builder; +use strict; +use Class::Tiny { + mirror => undef, + index => undef, + cascade => sub { 1 }, + without => sub { [] }, + cpanfile => undef, + fatscript => sub { $_[0]->_build_fatscript }, +}; + +sub effective_mirrors { + my $self = shift; + + # push default CPAN mirror always, as a fallback + # TODO don't pass fallback if --cached is set? + + my @mirrors = ($self->mirror); + push @mirrors, Carton::Mirror->default if $self->custom_mirror; + push @mirrors, Carton::Mirror->new('http://backpan.perl.org/'); + + @mirrors; +} + +sub custom_mirror { + my $self = shift; + ! $self->mirror->is_default; +} + +sub bundle { + my($self, $path, $cache_path, $snapshot) = @_; + + for my $dist ($snapshot->distributions) { + my $source = $path->child("cache/authors/id/" . $dist->pathname); + my $target = $cache_path->child("authors/id/" . $dist->pathname); + + if ($source->exists) { + warn "Copying ", $dist->pathname, "\n"; + $target->parent->mkpath; + $source->copy($target) or warn "$target: $!"; + } else { + warn "Couldn't find @{[ $dist->pathname ]}\n"; + } + } +} + +sub install { + my($self, $path) = @_; + + $self->run_cpanm( + "-L", $path, + (map { ("--mirror", $_->url) } $self->effective_mirrors), + ( $self->index ? ("--mirror-index", $self->index) : () ), + ( $self->cascade ? "--cascade-search" : () ), + ( $self->custom_mirror ? "--mirror-only" : () ), + "--save-dists", "$path/cache", + $self->groups, + "--cpanfile", $self->cpanfile, + "--installdeps", $self->cpanfile->dirname, + ) or die "Installing modules failed\n"; +} + +sub groups { + my $self = shift; + + # TODO support --without test (don't need test on deployment) + my @options = ('--with-all-features', '--with-develop'); + + for my $group (@{$self->without}) { + push @options, '--without-develop' if $group eq 'develop'; + push @options, "--without-feature=$group"; + } + + return @options; +} + +sub update { + my($self, $path, @modules) = @_; + + $self->run_cpanm( + "-L", $path, + (map { ("--mirror", $_->url) } $self->effective_mirrors), + ( $self->custom_mirror ? "--mirror-only" : () ), + "--save-dists", "$path/cache", + @modules + ) or die "Updating modules failed\n"; +} + +sub _build_fatscript { + my $self = shift; + + my $fatscript; + if ($Carton::Fatpacked) { + require Module::Reader; + my $content = Module::Reader::module_content('App::cpanminus::fatscript') + or die "Can't locate App::cpanminus::fatscript"; + $fatscript = Path::Tiny->tempfile; + $fatscript->spew($content); + } else { + require Module::Metadata; + $fatscript = Module::Metadata->find_module_by_name("App::cpanminus::fatscript") + or die "Can't locate App::cpanminus::fatscript"; + } + + return $fatscript; +} + +sub run_cpanm { + my($self, @args) = @_; + local $ENV{PERL_CPANM_OPT}; + !system $^X, $self->fatscript, "--quiet", "--notest", @args; +} + +1; diff --git a/lib/Carton/CLI.pm b/lib/Carton/CLI.pm new file mode 100644 index 0000000..b990ad2 --- /dev/null +++ b/lib/Carton/CLI.pm @@ -0,0 +1,396 @@ +package Carton::CLI; +use strict; +use warnings; +use Config; +use Getopt::Long; +use Path::Tiny; +use Try::Tiny; +use Module::CoreList; +use Scalar::Util qw(blessed); + +use Carton; +use Carton::Builder; +use Carton::Mirror; +use Carton::Snapshot; +use Carton::Util; +use Carton::Environment; +use Carton::Error; + +use constant { SUCCESS => 0, INFO => 1, WARN => 2, ERROR => 3 }; + +our $UseSystem = 0; # 1 for unit testing + +use Class::Tiny { + verbose => undef, + carton => sub { $_[0]->_build_carton }, + mirror => sub { $_[0]->_build_mirror }, +}; + +sub _build_mirror { + my $self = shift; + Carton::Mirror->new($ENV{PERL_CARTON_MIRROR} || $Carton::Mirror::DefaultMirror); +} + +sub run { + my($self, @args) = @_; + + my @commands; + my $p = Getopt::Long::Parser->new( + config => [ "no_ignore_case", "pass_through" ], + ); + $p->getoptionsfromarray( + \@args, + "h|help" => sub { unshift @commands, 'help' }, + "v|version" => sub { unshift @commands, 'version' }, + "verbose!" => sub { $self->verbose($_[1]) }, + ); + + push @commands, @args; + + my $cmd = shift @commands || 'install'; + + my $code = try { + my $call = $self->can("cmd_$cmd") + or Carton::Error::CommandNotFound->throw(error => "Could not find command '$cmd'"); + $self->$call(@commands); + return 0; + } catch { + die $_ unless blessed $_ && $_->can('rethrow'); + + if ($_->isa('Carton::Error::CommandExit')) { + return $_->code || 255; + } elsif ($_->isa('Carton::Error::CommandNotFound')) { + warn $_->error, "\n\n"; + $self->cmd_usage; + return 255; + } elsif ($_->isa('Carton::Error')) { + warn $_->error, "\n"; + return 255; + } + }; + + return $code; +} + +sub commands { + my $self = shift; + + no strict 'refs'; + map { s/^cmd_//; $_ } + grep { /^cmd_.*/ && $self->can($_) } sort keys %{__PACKAGE__."::"}; +} + +sub cmd_usage { + my $self = shift; + $self->print(<<HELP); +Usage: carton <command> + +where <command> is one of: + @{[ join ", ", $self->commands ]} + +Run carton -h <command> for help. +HELP +} + +sub parse_options { + my($self, $args, @spec) = @_; + my $p = Getopt::Long::Parser->new( + config => [ "no_auto_abbrev", "no_ignore_case" ], + ); + $p->getoptionsfromarray($args, @spec); +} + +sub parse_options_pass_through { + my($self, $args, @spec) = @_; + + my $p = Getopt::Long::Parser->new( + config => [ "no_auto_abbrev", "no_ignore_case", "pass_through" ], + ); + $p->getoptionsfromarray($args, @spec); + + # with pass_through keeps -- in args + shift @$args if $args->[0] && $args->[0] eq '--'; +} + +sub printf { + my $self = shift; + my $type = pop; + my($temp, @args) = @_; + $self->print(sprintf($temp, @args), $type); +} + +sub print { + my($self, $msg, $type) = @_; + my $fh = $type && $type >= WARN ? *STDERR : *STDOUT; + print {$fh} $msg; +} + +sub error { + my($self, $msg) = @_; + $self->print($msg, ERROR); + Carton::Error::CommandExit->throw; +} + +sub cmd_help { + my $self = shift; + my $module = $_[0] ? ("Carton::Doc::" . ucfirst $_[0]) : "Carton.pm"; + system "perldoc", $module; +} + +sub cmd_version { + my $self = shift; + $self->print("carton $Carton::VERSION\n"); +} + +sub cmd_bundle { + my($self, @args) = @_; + + my $env = Carton::Environment->build; + $env->snapshot->load; + + $self->print("Bundling modules using @{[$env->cpanfile]}\n"); + + my $builder = Carton::Builder->new( + mirror => $self->mirror, + cpanfile => $env->cpanfile, + ); + $builder->bundle($env->install_path, $env->vendor_cache, $env->snapshot); + + $self->printf("Complete! Modules were bundled into %s\n", $env->vendor_cache, SUCCESS); +} + +sub cmd_fatpack { + my($self, @args) = @_; + + my $env = Carton::Environment->build; + require Carton::Packer; + Carton::Packer->new->fatpack_carton($env->vendor_bin); +} + +sub cmd_install { + my($self, @args) = @_; + + my($install_path, $cpanfile_path, @without); + + $self->parse_options( + \@args, + "p|path=s" => \$install_path, + "cpanfile=s" => \$cpanfile_path, + "without=s" => sub { push @without, split /,/, $_[1] }, + "deployment!" => \my $deployment, + "cached!" => \my $cached, + ); + + my $env = Carton::Environment->build($cpanfile_path, $install_path); + $env->snapshot->load_if_exists; + + if ($deployment && !$env->snapshot->loaded) { + $self->error("--deployment requires cpanfile.snapshot: Run `carton install` and make sure cpanfile.snapshot is checked into your version control.\n"); + } + + my $builder = Carton::Builder->new( + cascade => 1, + mirror => $self->mirror, + without => \@without, + cpanfile => $env->cpanfile, + ); + + # TODO: --without with no .lock won't fetch the groups, resulting in insufficient requirements + + if ($deployment) { + $self->print("Installing modules using @{[$env->cpanfile]} (deployment mode)\n"); + $builder->cascade(0); + } else { + $self->print("Installing modules using @{[$env->cpanfile]}\n"); + } + + # TODO merge CPANfile git to mirror even if lock doesn't exist + if ($env->snapshot->loaded) { + my $index_file = $env->install_path->child("cache/modules/02packages.details.txt"); + $index_file->parent->mkpath; + + $env->snapshot->write_index($index_file); + $builder->index($index_file); + } + + if ($cached) { + $builder->mirror(Carton::Mirror->new($env->vendor_cache)); + } + + $builder->install($env->install_path); + + unless ($deployment) { + $env->cpanfile->load; + $env->snapshot->find_installs($env->install_path, $env->cpanfile->requirements); + $env->snapshot->save; + } + + $self->print("Complete! Modules were installed into @{[$env->install_path]}\n", SUCCESS); +} + +sub cmd_show { + my($self, @args) = @_; + + my $env = Carton::Environment->build; + $env->snapshot->load; + + for my $module (@args) { + my $dist = $env->snapshot->find($module) + or $self->error("Couldn't locate $module in cpanfile.snapshot\n"); + $self->print( $dist->name . "\n" ); + } +} + +sub cmd_list { + my($self, @args) = @_; + + my $format = 'name'; + + $self->parse_options( + \@args, + "distfile" => sub { $format = 'distfile' }, + ); + + my $env = Carton::Environment->build; + $env->snapshot->load; + + for my $dist ($env->snapshot->distributions) { + $self->print($dist->$format . "\n"); + } +} + +sub cmd_tree { + my($self, @args) = @_; + + my $env = Carton::Environment->build; + $env->snapshot->load; + $env->cpanfile->load; + + my %seen; + my $dumper = sub { + my($dependency, $reqs, $level) = @_; + return if $level == 0; + return Carton::Tree::STOP if $dependency->dist->is_core; + return Carton::Tree::STOP if $seen{$dependency->distname}++; + $self->printf( "%s%s (%s)\n", " " x ($level - 1), $dependency->module, $dependency->distname, INFO ); + }; + + $env->tree->walk_down($dumper); +} + +sub cmd_check { + my($self, @args) = @_; + + my $cpanfile_path; + $self->parse_options( + \@args, + "cpanfile=s" => \$cpanfile_path, + ); + + my $env = Carton::Environment->build($cpanfile_path); + $env->snapshot->load; + $env->cpanfile->load; + + # TODO remove snapshot + # TODO pass git spec to Requirements? + my $merged_reqs = $env->tree->merged_requirements; + + my @missing; + for my $module ($merged_reqs->required_modules) { + my $install = $env->snapshot->find_or_core($module); + if ($install) { + unless ($merged_reqs->accepts_module($module => $install->version_for($module))) { + push @missing, [ $module, 1, $install->version_for($module) ]; + } + } else { + push @missing, [ $module, 0 ]; + } + } + + if (@missing) { + $self->print("Following dependencies are not satisfied.\n", INFO); + for my $missing (@missing) { + my($module, $unsatisfied, $version) = @$missing; + if ($unsatisfied) { + $self->printf(" %s has version %s. Needs %s\n", + $module, $version, $merged_reqs->requirements_for_module($module), INFO); + } else { + $self->printf(" %s is not installed. Needs %s\n", + $module, $merged_reqs->requirements_for_module($module), INFO); + } + } + $self->printf("Run `carton install` to install them.\n", INFO); + Carton::Error::CommandExit->throw; + } else { + $self->print("cpanfile's dependencies are satisfied.\n", INFO); + } +} + +sub cmd_update { + my($self, @args) = @_; + + my $env = Carton::Environment->build; + $env->cpanfile->load; + + + my $cpanfile = Module::CPANfile->load($env->cpanfile); + @args = grep { $_ ne 'perl' } $env->cpanfile->required_modules unless @args; + + $env->snapshot->load; + + my @modules; + for my $module (@args) { + my $dist = $env->snapshot->find_or_core($module) + or $self->error("Could not find module $module.\n"); + next if $dist->is_core; + push @modules, "$module~" . $env->cpanfile->requirements_for_module($module); + } + + my $builder = Carton::Builder->new( + mirror => $self->mirror, + cpanfile => $env->cpanfile, + ); + $builder->update($env->install_path, @modules); + + $env->snapshot->find_installs($env->install_path, $env->cpanfile->requirements); + $env->snapshot->save; +} + +sub cmd_exec { + my($self, @args) = @_; + + my $env = Carton::Environment->build; + $env->snapshot->load; + + # allows -Ilib + @args = map { /^(-[I])(.+)/ ? ($1,$2) : $_ } @args; + + while (@args) { + if ($args[0] eq '-I') { + warn "exec -Ilib is deprecated. You might want to run: carton exec perl -Ilib ...\n"; + splice(@args, 0, 2); + } else { + last; + } + } + + $self->parse_options_pass_through(\@args); # to handle -- + + unless (@args) { + $self->error("carton exec needs a command to run.\n"); + } + + # PERL5LIB takes care of arch + my $path = $env->install_path; + local $ENV{PERL5LIB} = "$path/lib/perl5"; + local $ENV{PATH} = "$path/bin:$ENV{PATH}"; + + if ($UseSystem) { + system @args; + } else { + exec @args; + exit 127; # command not found + } +} + +1; diff --git a/lib/Carton/CPANfile.pm b/lib/Carton/CPANfile.pm new file mode 100644 index 0000000..a60d690 --- /dev/null +++ b/lib/Carton/CPANfile.pm @@ -0,0 +1,44 @@ +package Carton::CPANfile; +use Path::Tiny (); +use Module::CPANfile; + +use overload q{""} => sub { $_[0]->stringify }, fallback => 1; + +use subs 'path'; + +use Class::Tiny { + path => undef, + _cpanfile => undef, + requirements => sub { $_[0]->_build_requirements }, +}; + +sub stringify { shift->path->stringify(@_) } +sub dirname { shift->path->dirname(@_) } +sub prereqs { shift->_cpanfile->prereqs(@_) } +sub required_modules { shift->requirements->required_modules(@_) } +sub requirements_for_module { shift->requirements->requirements_for_module(@_) } + +sub path { + my $self = shift; + if (@_) { + $self->{path} = Path::Tiny->new($_[0]); + } else { + $self->{path}; + } +} + +sub load { + my $self = shift; + $self->_cpanfile( Module::CPANfile->load($self->path) ); +} + +sub _build_requirements { + my $self = shift; + my $reqs = CPAN::Meta::Requirements->new; + $reqs->add_requirements($self->prereqs->requirements_for($_, 'requires')) + for qw( configure build runtime test develop ); + $reqs->clear_requirement('perl'); + $reqs; +} + +1; diff --git a/lib/Carton/Dependency.pm b/lib/Carton/Dependency.pm new file mode 100644 index 0000000..d3e11ac --- /dev/null +++ b/lib/Carton/Dependency.pm @@ -0,0 +1,21 @@ +package Carton::Dependency; +use strict; +use Class::Tiny { + module => undef, + requirement => undef, + dist => undef, +}; + +sub requirements { shift->dist->requirements(@_) } + +sub distname { + my $self = shift; + $self->dist->name; +} + +sub version { + my $self = shift; + $self->dist->version_for($self->module); +} + +1; diff --git a/lib/Carton/Dist.pm b/lib/Carton/Dist.pm new file mode 100644 index 0000000..9310e70 --- /dev/null +++ b/lib/Carton/Dist.pm @@ -0,0 +1,37 @@ +package Carton::Dist; +use strict; +use Class::Tiny { + name => undef, + pathname => undef, + provides => sub { +{} }, + requirements => sub { $_[0]->_build_requirements }, +}; + +use CPAN::Meta; + +sub add_string_requirement { shift->requirements->add_string_requirement(@_) } +sub required_modules { shift->requirements->required_modules(@_) } +sub requirements_for_module { shift->requirements->requirements_for_module(@_) } + +sub is_core { 0 } + +sub distfile { + my $self = shift; + $self->pathname; +} + +sub _build_requirements { + CPAN::Meta::Requirements->new; +} + +sub provides_module { + my($self, $module) = @_; + exists $self->provides->{$module}; +} + +sub version_for { + my($self, $module) = @_; + $self->provides->{$module}{version}; +} + +1; diff --git a/lib/Carton/Dist/Core.pm b/lib/Carton/Dist/Core.pm new file mode 100644 index 0000000..760ce66 --- /dev/null +++ b/lib/Carton/Dist/Core.pm @@ -0,0 +1,23 @@ +package Carton::Dist::Core; +use strict; +use parent 'Carton::Dist'; + +use Class::Tiny qw( module_version ); + +sub BUILDARGS { + my($class, %args) = @_; + + # TODO represent dual-life + $args{name} =~ s/::/-/g; + + \%args; +} + +sub is_core { 1 } + +sub version_for { + my($self, $module) = @_; + $self->module_version; +} + +1; diff --git a/lib/Carton/Doc/Bundle.pod b/lib/Carton/Doc/Bundle.pod new file mode 100644 index 0000000..68ce8cc --- /dev/null +++ b/lib/Carton/Doc/Bundle.pod @@ -0,0 +1,20 @@ +=head1 NAME + +Carton::Doc::Bundle - Bundle cached tarballs in vendor/cache + +=head1 SYNOPSIS + + carton bundle + +=head1 DESCRIPTION + +This command bundles cached tarballs into C<vendor/cache> +directory. These tarballs have been cached in C<local/cache> while +resolving dependencies in the snapshot file.snapshot. + +Bundled modules can be committed to a version control system, or +transferred to another host with scp/rsync etc. to use with C<carton +install --cached>. + +See also C<carton fatpack> that generates C<carton> executable in +C<vendor/bin>. diff --git a/lib/Carton/Doc/Check.pod b/lib/Carton/Doc/Check.pod new file mode 100644 index 0000000..5283a7a --- /dev/null +++ b/lib/Carton/Doc/Check.pod @@ -0,0 +1,24 @@ +=head1 NAME + +Carton::Doc::Check - Check if your cpanfile and local environment are in sync + +=head1 SYNOPSIS + + carton check + +=head1 DESCRIPTION + +This command checks the consistency between your C<cpanfile>, +C<cpanfile.snapshot> and the local environment. + +=head2 MISSING MODULES + +If one or more of the modules specified in your I<cpanfile> are not +found in your snapshot, C<carton check> will warn you about this: + + $ carton check + Following dependencies are not satisfied. + JSON has version 2.51. Needs 2.52 + Run `carton install` to install them. + +You can run C<carton install> again to reinstall these missing dependencies. diff --git a/lib/Carton/Doc/Exec.pod b/lib/Carton/Doc/Exec.pod new file mode 100644 index 0000000..9eeca09 --- /dev/null +++ b/lib/Carton/Doc/Exec.pod @@ -0,0 +1,19 @@ +=head1 NAME + +Carton::Doc::Exec - execute your script in a carton local environment + +=head1 SYNOPSIS + + carton exec perl myscript.pl + +=head1 DESCRIPTION + +This command allows you to run your script in an isolated carton local +environment, which means the perl 5 library path C<@INC> are the only +ones from perl's core library path, carton's library path +(i.e. C<local/lib/perl5>) and the current directory. + +This is useful to make sure your scripts and application use the exact +same versions of the modules in your library path, and are not using +any of the modules you accidentally installed into your system perl or +perlbrew's site library path. diff --git a/lib/Carton/Doc/FAQ.pod b/lib/Carton/Doc/FAQ.pod new file mode 100644 index 0000000..ec9a575 --- /dev/null +++ b/lib/Carton/Doc/FAQ.pod @@ -0,0 +1,112 @@ +=head1 NAME + +Carton::Doc::FAQ - Frequently Asked Questions + +=head1 QUESTIONS + +=head2 It looks useful, but what is the use case of this tool? + +The particular problem that carton is trying to address is this: + +You develop a Perl-based application, possibly but not limited to +webapps, with dozens of CPAN module dependencies. You install these +modules on your development machine, and describe these dependencies +in your I<cpanfile>. + +Now you get a production environment, either on PaaS provider or some +VPS, you install the dependencies using C<cpanm --installdeps .> and +it will pull all the latest releases from CPAN as of today and +everything just works. + +A few weeks later, your application becomes more popular, and you +think you need another machine to serve more requests. You set up +another machine with vanilla perl installation and install the +dependencies the same way. That will pull the I<latest> releases from +CPAN I<on that date>, rather than the same as what you have today. + +And that is the problem. It's not likely that everything just breaks +one day, but there's always a chance that one of the dependencies +breaks an API compatibility, or just uploaded a buggy version to CPAN +on that particular day. + +Carton allows you to I<lock> these dependencies into a version +controlled system, so that every time you deploy from a checkout, it +is guaranteed that all the same versions are installed into the local +environment. + +=head2 How is this different from Pinto or CPAN::Mini::Inject? + +carton definitely shares the goal with these private CPAN repository +management tool. But the main difference is that rather than creating +an actual CPAN-like repository that works with any CPAN clients, +Carton provides a way to install specific versions of distributions +from CPAN, or any CPAN-like mirrors (as well as git repositories in +the future version of Carton). + +Existing tools are designed to work I<with> CPAN clients such as +L<CPAN> or L<CPANPLUS>, and have accomplished that by working around +the CPAN mirror structure. + +carton I<internally> does the same thing, but its user interface is +centered around the installer, by implementing a wrapper for +L<cpanm|App::cpanminus>, so you can use the same commands in the +development mode and deployment mode. + +Carton automatically maintains the L<cpanfile.snapshot> file, which is meant +to be version controlled, inside your application directory. You don't +need a separate database, a directory or a web server to maintain +tarballs outside your application. The I<cpanfile.snapshot> file can always +be generated with C<carton install> command, and C<carton install> on +another machine can use the version in the snapshot. + +=head2 I already use Pinto to create DarkPAN mirror. Can I use Carton with this? + +Yes, by specifying Pinto mirror as your Carton mirror, you can take a +snapshot of your dependencies including your private modules on Pinto, +or whatever DarkPAN mirror. + +=head2 I'm already using perlbrew and local::lib. Can I use carton with this? + +If you're using L<local::lib> already with L<perlbrew> perl, possibly +with the new C<perlbrew lib> command, that's great! There are multiple +benefits over using L<perlbrew> and L<local::lib> for development and +use L<Carton> for deployment. + +The best practice and workflow to get your perl environment as clean +as possible with lots of modules installed for quick development would +be this: + +=over + +=item * + +Install fresh perl using perlbrew. The version must be the same +against the version you'll run on the production environment. + +=item * + +Once the installation is done, use C<perlbrew lib> command to create a +new local lib environment (let's call it I<devel>) and always use the +library as a default environment. Install as many modules as you would +like into the I<devel> library path. + +This ensures to have a vanilla C<perl> library path as clean as +possible. + +=item * + +When you build a new project that you want to manage dependencies via +Carton, turn off the I<devel> local::lib and create a new one, like +I<myapp>. Install L<Carton> and all of its dependencies to the +I<myapp> local::lib path. Then run C<carton install> like you +normally do. + +Becuase I<devel> and I<myapp> are isolated, the modules you installed +into I<devel> doesn't affect the process when carton builds the +dependency tree for your new project at all. This could often be +critical when you have a conditional dependency in your tree, like +L<Any::Moose>. + +=back + + diff --git a/lib/Carton/Doc/Fatpack.pod b/lib/Carton/Doc/Fatpack.pod new file mode 100644 index 0000000..15282e0 --- /dev/null +++ b/lib/Carton/Doc/Fatpack.pod @@ -0,0 +1,15 @@ +=head1 NAME + +Carton::Doc::Fatpack - Fatpack carton executable into vendor/bin + +=head1 SYNOPSIS + + carton fatpack + +=head1 DESCRIPTION + +This command creates a fatpack executable of C<carton> in +C<vendor/bin> directory, so that it can be used to bootstrap +deployment process, combined with C<carton bundle> and C<carton +install --cached>. + diff --git a/lib/Carton/Doc/Install.pod b/lib/Carton/Doc/Install.pod new file mode 100644 index 0000000..df3b58f --- /dev/null +++ b/lib/Carton/Doc/Install.pod @@ -0,0 +1,95 @@ +=head1 NAME + +Carton::Doc::Install - Install the dependencies + +=head1 SYNOPSIS + + carton install [--deployment] [--cached] [--path=PATH] [--without develop] + +=head1 DESCRIPTION + +Install the dependencies for your application. This command has two +modes and the behavior is slightly different. + +=head2 DEVELOPMENT MODE + +=over 4 + +=item carton install + +If you run C<carton install> without any arguments and if I<cpanfile> +exists, carton will scan dependencies from I<cpanfile> and install +the modules. + +=back + +If you run C<carton install> for the first time +(i.e. I<cpanfile.snapshot> does not exist), carton will fetch all the +modules specified, resolve dependencies and install all required +modules from CPAN. + +If I<cpanfile.snapshot> file does exist, carton will still try to install +modules specified or updated in I<cpanfile>, but uses I<cpanfile.snapshot> +for the dependency resolution, and then cascades to CPAN. + +carton will analyze all the dependencies and their version +information, and it is saved into I<cpanfile.snapshot> file. It is important +to add I<cpanfile.snapshot> file into a version controlled repository and +commit the changes as you update your dependencies. + +=head2 DEPLOYMENT MODE + +If you specify the C<--deployment> command line option or the +I<cpanfile.snapshot> exists, carton will only use the dependencies +specified in the I<cpanfile.snapshot> instead of resolving +dependencies. + +=head1 OPTIONS + +=over 4 + +=item --deployment + +Force the deployment mode. See L</"DEPLOYMENT MODE"> above. + +=item --cached + +Locate distribution tarballs in C<vendor/cache> rather than fetching +them from CPAN mirrors. This requires you to run C<carton bundle> +prior to the deployment and commit or sync the content of C<vendor> +directory to the other host you run C<carton install> on. + +=item --cpanfile + +Specify the alternate path for cpanfile. By default, C<carton install> +will look for the file C<cpanfile> in the current directory, then +upwards till the root directory, in case the command runs from a sub +directory. + +Carton assumes the directory where your cpanfile (or altenate path) +exists as a project root directory, and will look for the snapshot file as +well as install directory (C<local>) and C<vendor/cache> relative to it. + +=item --path + +Specify the path to install modules to. Defaults to I<local> in the +directory relative to where C<cpanfile> is. + +B<NOTE>: this option, as of version 1.0, is not preserved across +multiple runs of C<carton install> or other commands such as C<carton +list> or C<carton exec>. You can choose to set the path in +C<PERL_CARTON_PATH> environment variable to persist it across +commands. + +=item --without + +By default, C<carton install> will install all the phases for +dependencies, including C<develop>. You can specify phases or features +to exclude, in the comma separated list. + + carton install --deployment --without develop + +B<NOTE>: C<--without> for the initial installation (without +cpanfile.snapshot) is not supported at this moment. + +=back diff --git a/lib/Carton/Doc/List.pod b/lib/Carton/Doc/List.pod new file mode 100644 index 0000000..40c54e0 --- /dev/null +++ b/lib/Carton/Doc/List.pod @@ -0,0 +1,23 @@ +=head1 NAME + +Carton::Doc::List - List dependencies tracked in the cpanfile.snapshot file + +=head1 SYNOPSIS + + carton list + +=head1 DESCRIPTION + +List the dependencies and version information tracked in the +I<cpanfile.snapshot> file. This command by default displays the name of the +distribution (e.g. I<Foo-Bar-0.01>) in a flat list. + +=head1 OPTIONS + +=over 4 + +=item --distfile + +Displays the list of distributions in a distfile format (i.e. C<AUTHOR/Dist-1.23.tar.gz>) + +=back diff --git a/lib/Carton/Doc/Show.pod b/lib/Carton/Doc/Show.pod new file mode 100644 index 0000000..20618b4 --- /dev/null +++ b/lib/Carton/Doc/Show.pod @@ -0,0 +1,12 @@ +=head1 NAME + +Carton::Doc::Show - Show the module information + +=head1 SYNOPSIS + + carton show Module + +=head1 DESCRIPTION + +Displays the information about modules, distribution and its versions. + diff --git a/lib/Carton/Doc/Tree.pod b/lib/Carton/Doc/Tree.pod new file mode 100644 index 0000000..0080eef --- /dev/null +++ b/lib/Carton/Doc/Tree.pod @@ -0,0 +1,13 @@ +=head1 NAME + +Carton::Doc::Tree - Show the tree of dependency graph + +=head1 SYNOPSIS + + carton tree + +=head1 DESCRIPTION + +Displays the tree representation of dependency graph for your application. + + diff --git a/lib/Carton/Doc/Update.pod b/lib/Carton/Doc/Update.pod new file mode 100644 index 0000000..146f03e --- /dev/null +++ b/lib/Carton/Doc/Update.pod @@ -0,0 +1,40 @@ +=head1 NAME + +Carton::Doc::Update - Update the dependencies + +=head1 SYNOPSIS + + carton update [module] + +=head1 DESCRIPTION + +Update the dependencies version for your application. + +Carton is designed to update your dependency in a conservative way, +meaning that it doesn't update modules that aren't explicitly required +to. + +C<carton update> is a command to explicitly update one or all of +modules in your cpanfile to the latest available that satisfies the +requirements in cpanfile. + +=head1 EXAMPLE + +Suppose you have a cpanfile with: + + requires 'DBI', '1.600'; + requires 'Plack', '== 1.0011'; + +and then run C<carton install> to get DBI 1.610 (the latest at that +time) and Plack 1.0011 (as specified in the requirement). + +A few weeks later, DBI and Plack have been updated a couple of +times. Running C<carton install> I<won't> update the versions, because +the installed versions satisfy the requirements in C<cpanfile>. + +Running C<carton update> will update DBI to the latest version, say +1.611, because the version still satisfies the requirement. However, +it won't update Plack's version, since whatever latest version on CPAN +will not satisfy the Plack's requirement C<== 1.0011> because it wants +an exact version. + diff --git a/lib/Carton/Doc/Upgrading.pod b/lib/Carton/Doc/Upgrading.pod new file mode 100644 index 0000000..d7ad57e --- /dev/null +++ b/lib/Carton/Doc/Upgrading.pod @@ -0,0 +1,48 @@ +=head1 NAME + +Carton::Doc::Upgrading - Upgrading document + +=head1 UPGRADING + +Carton adds, changes and deprecates some features between major +releases in backward incompatible ways. Here's the list of major +changes between versions. See C<Changes> file for more details. + +=head2 v0.9 to v1.0 + +=over 4 + +=item * + +C<carton exec -Ilib> is deprecated. You must pass the optional include +path to perl interpreter in the normal way, like: + + carton exec perl -Ilib myscript + +Or make your script to take its own C<-I> option, like many command line +launcher does (i.e. plackup, prove) + + carton exec plackup -Ilib myapp.psgi + +=item * + +C<carton.lock> is now C<cpanfile.snapshot>. Its name and file format +has been changed. There's no automatic migration, but you can do: + + # run with Carton v0.9.64 + > carton install + + # upgrade to Carton v1.0 + > cpanm Carton + > carton install + > git add cpanfile.snapshot + > git rm carton.lock + +This process will most likely preserve modules in your local library. + +=item * + +cpanfile is now a requirement, and extracting requirements from build +files (C<Makefile.PL>, C<Build.PL>) is not supported. + +=back diff --git a/lib/Carton/Doc/Version.pod b/lib/Carton/Doc/Version.pod new file mode 100644 index 0000000..8ff36ad --- /dev/null +++ b/lib/Carton/Doc/Version.pod @@ -0,0 +1,11 @@ +=head1 NAME + +Carton::Doc::Version - Display version + +=head1 SYNOPSIS + + carton version + +=head1 DESCRIPTION + +This command displays the current version number of carton. diff --git a/lib/Carton/Environment.pm b/lib/Carton/Environment.pm new file mode 100644 index 0000000..6a58944 --- /dev/null +++ b/lib/Carton/Environment.pm @@ -0,0 +1,100 @@ +package Carton::Environment; +use strict; +use Carton::CPANfile; +use Carton::Snapshot; +use Carton::Error; +use Carton::Tree; +use Path::Tiny; + +use Class::Tiny { + cpanfile => undef, + snapshot => sub { $_[0]->_build_snapshot }, + install_path => sub { $_[0]->_build_install_path }, + vendor_cache => sub { $_[0]->_build_vendor_cache }, + tree => sub { $_[0]->_build_tree }, +}; + +sub _build_snapshot { + my $self = shift; + Carton::Snapshot->new(path => $self->cpanfile . ".snapshot"); +} + +sub _build_install_path { + my $self = shift; + if ($ENV{PERL_CARTON_PATH}) { + return Path::Tiny->new($ENV{PERL_CARTON_PATH}); + } else { + return $self->cpanfile->path->parent->child("local"); + } +} + +sub _build_vendor_cache { + my $self = shift; + Path::Tiny->new($self->install_path->dirname . "/vendor/cache"); +} + +sub _build_tree { + my $self = shift; + Carton::Tree->new(cpanfile => $self->cpanfile, snapshot => $self->snapshot); +} + +sub vendor_bin { + my $self = shift; + $self->vendor_cache->parent->child('bin'); +} + +sub build_with { + my($class, $cpanfile) = @_; + + $cpanfile = Path::Tiny->new($cpanfile)->absolute; + if ($cpanfile->is_file) { + return $class->new(cpanfile => Carton::CPANfile->new(path => $cpanfile)); + } else { + Carton::Error::CPANfileNotFound->throw(error => "Can't locate cpanfile: $cpanfile"); + } +} + +sub build { + my($class, $cpanfile_path, $install_path) = @_; + + my $self = $class->new; + + $cpanfile_path &&= Path::Tiny->new($cpanfile_path)->absolute; + + my $cpanfile = $self->locate_cpanfile($cpanfile_path || $ENV{PERL_CARTON_CPANFILE}); + if ($cpanfile && $cpanfile->is_file) { + $self->cpanfile( Carton::CPANfile->new(path => $cpanfile) ); + } else { + Carton::Error::CPANfileNotFound->throw(error => "Can't locate cpanfile: (@{[ $cpanfile_path || 'cpanfile' ]})"); + } + + $self->install_path( Path::Tiny->new($install_path)->absolute ) if $install_path; + + $self; +} + +sub locate_cpanfile { + my($self, $path) = @_; + + if ($path) { + return Path::Tiny->new($path)->absolute; + } + + my $current = Path::Tiny->cwd; + my $previous = ''; + + until ($current eq '/' or $current eq $previous) { + # TODO support PERL_CARTON_CPANFILE + my $try = $current->child('cpanfile'); + if ($try->is_file) { + return $try->absolute; + } + + ($previous, $current) = ($current, $current->parent); + } + + return; +} + +1; + diff --git a/lib/Carton/Error.pm b/lib/Carton/Error.pm new file mode 100644 index 0000000..b469eac --- /dev/null +++ b/lib/Carton/Error.pm @@ -0,0 +1,42 @@ +package Carton::Error; +use strict; +use overload '""' => sub { $_[0]->error }; +use Carp; + +sub throw { + my($class, @args) = @_; + die $class->new(@args); +} + +sub rethrow { + die $_[0]; +} + +sub new { + my($class, %args) = @_; + bless \%args, $class; +} + +sub error { + $_[0]->{error} || ref $_[0]; +} + +package Carton::Error::CommandNotFound; +use parent 'Carton::Error'; + +package Carton::Error::CommandExit; +use parent 'Carton::Error'; +sub code { $_[0]->{code} } + +package Carton::Error::CPANfileNotFound; +use parent 'Carton::Error'; + +package Carton::Error::SnapshotParseError; +use parent 'Carton::Error'; +sub path { $_[0]->{path} } + +package Carton::Error::SnapshotNotFound; +use parent 'Carton::Error'; +sub path { $_[0]->{path} } + +1; diff --git a/lib/Carton/Index.pm b/lib/Carton/Index.pm new file mode 100644 index 0000000..3ce215c --- /dev/null +++ b/lib/Carton/Index.pm @@ -0,0 +1,68 @@ +package Carton::Index; +use strict; +use Class::Tiny { + _packages => sub { +{} }, + generator => sub { require Carton; "Carton $Carton::VERSION" }, +}; + +sub add_package { + my($self, $package) = @_; + $self->_packages->{$package->name} = $package; # XXX ||= +} + +sub count { + my $self = shift; + scalar keys %{$self->_packages}; +} + +sub packages { + my $self = shift; + sort { lc $a->name cmp lc $b->name } values %{$self->_packages}; +} + +sub write { + my($self, $fh) = @_; + + print $fh <<EOF; +File: 02packages.details.txt +URL: http://www.perl.com/CPAN/modules/02packages.details.txt +Description: Package names found in cpanfile.snapshot +Columns: package name, version, path +Intended-For: Automated fetch routines, namespace documentation. +Written-By: @{[ $self->generator ]} +Line-Count: @{[ $self->count ]} +Last-Updated: @{[ scalar localtime ]} + +EOF + for my $p ($self->packages) { + print $fh $self->_format_line($p->name, $p->version || 'undef', $p->pathname); + } +} + +sub _format_line { + my($self, @row) = @_; + + # from PAUSE::mldistwatch::rewrite02 + my $one = 30; + my $two = 8; + + if (length $row[0] > $one) { + $one += 8 - length $row[1]; + $two = length $row[1]; + } + + sprintf "%-${one}s %${two}s %s\n", @row; +} + +sub pad { + my($str, $len, $left) = @_; + + my $howmany = $len - length($str); + return $str if $howmany <= 0; + + my $pad = " " x $howmany; + return $left ? "$pad$str" : "$str$pad"; +} + + +1; diff --git a/lib/Carton/Mirror.pm b/lib/Carton/Mirror.pm new file mode 100644 index 0000000..60bc937 --- /dev/null +++ b/lib/Carton/Mirror.pm @@ -0,0 +1,23 @@ +package Carton::Mirror; +use strict; +use Class::Tiny qw( url ); + +our $DefaultMirror = 'http://cpan.metacpan.org/'; + +sub BUILDARGS { + my($class, $url) = @_; + return { url => $url }; +} + +sub default { + my $class = shift; + $class->new($DefaultMirror); +} + +sub is_default { + my $self = shift; + $self->url eq $DefaultMirror; +} + +1; + diff --git a/lib/Carton/Package.pm b/lib/Carton/Package.pm new file mode 100644 index 0000000..6b1f381 --- /dev/null +++ b/lib/Carton/Package.pm @@ -0,0 +1,12 @@ +package Carton::Package; +use strict; +use Class::Tiny qw( name version pathname ); + +sub BUILDARGS { + my($class, @args) = @_; + return { name => $args[0], version => $args[1], pathname => $args[2] }; +} + +1; + + diff --git a/lib/Carton/Packer.pm b/lib/Carton/Packer.pm new file mode 100644 index 0000000..dc1a2cf --- /dev/null +++ b/lib/Carton/Packer.pm @@ -0,0 +1,97 @@ +package Carton::Packer; +use Class::Tiny; +use warnings NONFATAL => 'all'; +use App::FatPacker; +use File::pushd (); +use Path::Tiny (); +use CPAN::Meta (); +use File::Find (); + +sub fatpack_carton { + my($self, $dir) = @_; + + my $temp = Path::Tiny->tempdir; + my $pushd = File::pushd::pushd $temp; + + my $file = $temp->child('carton.pre.pl'); + + $file->spew(<<'EOF'); +#!/usr/bin/env perl +use strict; +use 5.008001; +use Carton::CLI; +$Carton::Fatpacked = 1; +exit Carton::CLI->new->run(@ARGV); +EOF + + my $fatpacked = $self->do_fatpack($file); + + my $executable = $dir->child('carton'); + warn "Bundling $executable\n"; + + $dir->mkpath; + $executable->spew($fatpacked); + chmod 0755, $executable; +} + +sub do_fatpack { + my($self, $file) = @_; + + my $packer = App::FatPacker->new; + + my @modules = split /\r?\n/, $packer->trace(args => [$file], use => $self->required_modules); + my @packlists = $packer->packlists_containing(\@modules); + $packer->packlists_to_tree(Path::Tiny->new('fatlib')->absolute, \@packlists); + + my $fatpacked = do { + local $SIG{__WARN__} = sub {}; + $packer->fatpack_file($file); + }; + + # HACK: File::Spec bundled into arch in < 5.16, but is loadable as pure-perl + use Config; + $fatpacked =~ s/\$fatpacked{"$Config{archname}\/(Cwd|File)/\$fatpacked{"$1/g; + + $fatpacked; +} + +sub required_modules { + my($self, $packer) = @_; + + my $meta = $self->installed_meta('Carton') + or die "Couldn't find install metadata for Carton"; + + my %excludes = ( + perl => 1, + 'ExtUtils::MakeMaker' => 1, + 'Module::Build' => 1, + ); + + my @requirements = grep !$excludes{$_}, + $meta->effective_prereqs->requirements_for('runtime', 'requires')->required_modules; + + return \@requirements; +} + +sub installed_meta { + my($self, $dist) = @_; + + my @meta; + my $finder = sub { + if (m!\b$dist-.*[\\/]MYMETA.json!) { + my $meta = CPAN::Meta->load_file($_); + push @meta, $meta if $meta->name eq $dist; + } + }; + + my @meta_dirs = grep -d, map "$_/.meta", @INC; + File::Find::find({ wanted => $finder, no_chdir => 1 }, @meta_dirs) + if @meta_dirs; + + # return the latest version + @meta = sort { version->new($b->version) cmp version->new($a->version) } @meta; + + return $meta[0]; +} + +1; diff --git a/lib/Carton/Snapshot.pm b/lib/Carton/Snapshot.pm new file mode 100644 index 0000000..9e57f18 --- /dev/null +++ b/lib/Carton/Snapshot.pm @@ -0,0 +1,191 @@ +package Carton::Snapshot; +use strict; +use Config; +use Carton::Dist; +use Carton::Dist::Core; +use Carton::Error; +use Carton::Package; +use Carton::Index; +use Carton::Util; +use Carton::Snapshot::Emitter; +use Carton::Snapshot::Parser; +use CPAN::Meta; +use CPAN::Meta::Requirements; +use File::Find (); +use Try::Tiny; +use Path::Tiny (); +use Module::CoreList; + +use constant CARTON_SNAPSHOT_VERSION => '1.0'; + +use subs 'path'; +use Class::Tiny { + path => undef, + version => sub { CARTON_SNAPSHOT_VERSION }, + loaded => undef, + _distributions => sub { +[] }, +}; + +sub BUILD { + my $self = shift; + $self->path( $self->{path} ); +} + +sub path { + my $self = shift; + if (@_) { + $self->{path} = Path::Tiny->new($_[0]); + } else { + $self->{path}; + } +} + +sub load_if_exists { + my $self = shift; + $self->load if $self->path->is_file; +} + +sub load { + my $self = shift; + + return 1 if $self->loaded; + + if ($self->path->is_file) { + my $parser = Carton::Snapshot::Parser->new; + $parser->parse($self->path->slurp_utf8, $self); + $self->loaded(1); + + return 1; + } else { + Carton::Error::SnapshotNotFound->throw( + error => "Can't find cpanfile.snapshot: Run `carton install` to build the snapshot file.", + path => $self->path, + ); + } +} + +sub save { + my $self = shift; + $self->path->spew_utf8( Carton::Snapshot::Emitter->new->emit($self) ); +} + +sub find { + my($self, $module) = @_; + (grep $_->provides_module($module), $self->distributions)[0]; +} + +sub find_or_core { + my($self, $module) = @_; + $self->find($module) || $self->find_in_core($module); +} + +sub find_in_core { + my($self, $module) = @_; + + if (exists $Module::CoreList::version{$]}{$module}) { + my $version = $Module::CoreList::version{$]}{$module}; # maybe undef + return Carton::Dist::Core->new(name => $module, module_version => $version); + } + + return; +} + +sub index { + my $self = shift; + + my $index = Carton::Index->new; + for my $package ($self->packages) { + $index->add_package($package); + } + + return $index; +} + +sub distributions { + @{$_[0]->_distributions}; +} + +sub add_distribution { + my($self, $dist) = @_; + push @{$self->_distributions}, $dist; +} + +sub packages { + my $self = shift; + + my @packages; + for my $dist ($self->distributions) { + while (my($package, $provides) = each %{$dist->provides}) { + # TODO what if duplicates? + push @packages, Carton::Package->new($package, $provides->{version}, $dist->pathname); + } + } + + return @packages; +} + +sub write_index { + my($self, $file) = @_; + + open my $fh, ">", $file or die $!; + $self->index->write($fh); +} + +sub find_installs { + my($self, $path, $reqs) = @_; + + my $libdir = "$path/lib/perl5/$Config{archname}/.meta"; + return {} unless -e $libdir; + + my @installs; + my $wanted = sub { + if ($_ eq 'install.json') { + push @installs, [ $File::Find::name, "$File::Find::dir/MYMETA.json" ]; + } + }; + File::Find::find($wanted, $libdir); + + my %installs; + + my $accepts = sub { + my $module = shift; + + return 0 unless $reqs->accepts_module($module->{name}, $module->{provides}{$module->{name}}{version}); + + if (my $exist = $installs{$module->{name}}) { + my $old_ver = version::->new($exist->{provides}{$module->{name}}{version}); + my $new_ver = version::->new($module->{provides}{$module->{name}}{version}); + return $new_ver >= $old_ver; + } else { + return 1; + } + }; + + for my $file (@installs) { + my $module = Carton::Util::load_json($file->[0]); + my $prereqs = -f $file->[1] ? CPAN::Meta->load_file($file->[1])->effective_prereqs : CPAN::Meta::Prereqs->new; + + my $reqs = CPAN::Meta::Requirements->new; + $reqs->add_requirements($prereqs->requirements_for($_, 'requires')) + for qw( configure build runtime ); + + if ($accepts->($module)) { + $installs{$module->{name}} = Carton::Dist->new( + name => $module->{dist}, + pathname => $module->{pathname}, + provides => $module->{provides}, + version => $module->{version}, + requirements => $reqs, + ); + } + } + + my @new_dists; + for my $module (sort keys %installs) { + push @new_dists, $installs{$module}; + } + + $self->_distributions(\@new_dists); +} + +1; diff --git a/lib/Carton/Snapshot/Emitter.pm b/lib/Carton/Snapshot/Emitter.pm new file mode 100644 index 0000000..9486ba7 --- /dev/null +++ b/lib/Carton/Snapshot/Emitter.pm @@ -0,0 +1,30 @@ +package Carton::Snapshot::Emitter; +use Class::Tiny; +use warnings NONFATAL => 'all'; + +sub emit { + my($self, $snapshot) = @_; + + my $data = ''; + $data .= "# carton snapshot format: version @{[$snapshot->version]}\n"; + $data .= "DISTRIBUTIONS\n"; + + for my $dist (sort { $a->name cmp $b->name } $snapshot->distributions) { + $data .= " @{[$dist->name]}\n"; + $data .= " pathname: @{[$dist->pathname]}\n"; + + $data .= " provides:\n"; + for my $package (sort keys %{$dist->provides}) { + $data .= " $package @{[$dist->provides->{$package}{version} || 'undef' ]}\n"; + } + + $data .= " requirements:\n"; + for my $module (sort $dist->required_modules) { + $data .= " $module @{[ $dist->requirements_for_module($module) || '0' ]}\n"; + } + } + + $data; +} + +1; diff --git a/lib/Carton/Snapshot/Parser.pm b/lib/Carton/Snapshot/Parser.pm new file mode 100644 index 0000000..21aa0c1 --- /dev/null +++ b/lib/Carton/Snapshot/Parser.pm @@ -0,0 +1,126 @@ +package Carton::Snapshot::Parser; +use Class::Tiny; +use warnings NONFATAL => 'all'; +use Carton::Dist; +use Carton::Error; + +my $machine = { + init => [ + { + re => qr/^\# carton snapshot format: version (1\.0)/, + code => sub { + my($stash, $snapshot, $ver) = @_; + $snapshot->version($ver); + }, + goto => 'section', + }, + # TODO support pasing error and version mismatch etc. + ], + section => [ + { + re => qr/^DISTRIBUTIONS$/, + goto => 'dists', + }, + { + re => qr/^__EOF__$/, + done => 1, + }, + ], + dists => [ + { + re => qr/^ (\S+)$/, + code => sub { $_[0]->{dist} = Carton::Dist->new(name => $1) }, + goto => 'distmeta', + }, + { + re => qr/^\S/, + goto => 'section', + redo => 1, + }, + ], + distmeta => [ + { + re => qr/^ pathname: (.*)$/, + code => sub { $_[0]->{dist}->pathname($1) }, + }, + { + re => qr/^\s{4}provides:$/, + code => sub { $_[0]->{property} = 'provides' }, + goto => 'properties', + }, + { + re => qr/^\s{4}requirements:$/, + code => sub { + $_[0]->{property} = 'requirements'; + }, + goto => 'properties', + }, + { + re => qr/^\s{0,2}\S/, + code => sub { + my($stash, $snapshot) = @_; + $snapshot->add_distribution($stash->{dist}); + %$stash = (); # clear + }, + goto => 'dists', + redo => 1, + }, + ], + properties => [ + { + re => qr/^\s{6}([0-9A-Za-z_:]+) ([v0-9\._,=\!<>\s]+|undef)/, + code => sub { + my($stash, $snapshot, $module, $version) = @_; + + if ($stash->{property} eq 'provides') { + $stash->{dist}->provides->{$module} = { version => $version }; + } else { + $stash->{dist}->add_string_requirement($module, $version); + } + }, + }, + { + re => qr/^\s{0,4}\S/, + goto => 'distmeta', + redo => 1, + }, + ], +}; + +sub parse { + my($self, $data, $snapshot) = @_; + + my @lines = split /\r?\n/, $data; + + my $state = $machine->{init}; + my $stash = {}; + + LINE: + for my $line (@lines, '__EOF__') { + last LINE unless @$state; + + STATE: { + for my $trans (@{$state}) { + if (my @match = $line =~ $trans->{re}) { + if (my $code = $trans->{code}) { + $code->($stash, $snapshot, @match); + } + if (my $goto = $trans->{goto}) { + $state = $machine->{$goto}; + if ($trans->{redo}) { + redo STATE; + } else { + next LINE; + } + } + + last STATE; + } + } + + Carton::Error::SnapshotParseError->throw(error => "Could not parse snapshot file."); + } + } +} + +1; diff --git a/lib/Carton/Tree.pm b/lib/Carton/Tree.pm new file mode 100644 index 0000000..6ce22a1 --- /dev/null +++ b/lib/Carton/Tree.pm @@ -0,0 +1,69 @@ +package Carton::Tree; +use strict; +use Carton::Dependency; + +use Class::Tiny qw( cpanfile snapshot ); + +use constant STOP => -1; + +sub walk_down { + my($self, $cb) = @_; + + my $dumper; $dumper = sub { + my($dependency, $reqs, $level, $parent) = @_; + + my $ret = $cb->($dependency, $reqs, $level); + return if $ret && $ret == STOP; + + local $parent->{$dependency->distname} = 1 if $dependency; + + for my $module (sort $reqs->required_modules) { + my $dependency = $self->dependency_for($module, $reqs); + if ($dependency->dist) { + next if $parent->{$dependency->distname}; + $dumper->($dependency, $dependency->requirements, $level + 1, $parent); + } else { + # no dist found in lock + } + } + }; + + $dumper->(undef, $self->cpanfile->requirements, 0, {}); + undef $dumper; +} + +sub dependency_for { + my($self, $module, $reqs) = @_; + + my $requirement = $reqs->requirements_for_module($module); + + my $dep = Carton::Dependency->new; + $dep->module($module); + $dep->requirement($requirement); + + if (my $dist = $self->snapshot->find_or_core($module)) { + $dep->dist($dist); + } + + return $dep; +} + +sub merged_requirements { + my $self = shift; + + my $merged_reqs = CPAN::Meta::Requirements->new; + + my %seen; + $self->walk_down(sub { + my($dependency, $reqs, $level) = @_; + return Carton::Tree::STOP if $dependency && $seen{$dependency->distname}++; + $merged_reqs->add_requirements($reqs); + }); + + $merged_reqs->clear_requirement('perl'); + $merged_reqs->finalize; + + $merged_reqs; +} + +1; diff --git a/lib/Carton/Util.pm b/lib/Carton/Util.pm new file mode 100644 index 0000000..cc9c775 --- /dev/null +++ b/lib/Carton/Util.pm @@ -0,0 +1,31 @@ +package Carton::Util; +use strict; +use warnings; + +sub load_json { + my $file = shift; + + open my $fh, "<", $file or die "$file: $!"; + from_json(join '', <$fh>); +} + +sub dump_json { + my($data, $file) = @_; + + open my $fh, ">", $file or die "$file: $!"; + binmode $fh; + print $fh to_json($data); +} + +sub from_json { + require JSON; + JSON::decode_json(@_); +} + +sub to_json { + my($data) = @_; + require JSON; + JSON->new->utf8->pretty->canonical->encode($data); +} + +1; |