From e0d850e69991ae19fe888600fcafd8adc60ba1bd Mon Sep 17 00:00:00 2001 From: Karen Etheridge Date: Sat, 14 May 2016 12:26:54 -0700 Subject: [PATCH] new plugin to allow gathering individual files --- Changes | 2 + lib/Dist/Zilla/Plugin/GatherFile.pm | 134 ++++++++++++++++++++++++++++ lib/Dist/Zilla/Types.pm | 13 ++- t/plugins/gatherfile.t | 125 ++++++++++++++++++++++++++ 4 files changed, 271 insertions(+), 3 deletions(-) create mode 100644 lib/Dist/Zilla/Plugin/GatherFile.pm create mode 100644 t/plugins/gatherfile.t diff --git a/Changes b/Changes index 36acbed5f..0f4e7a843 100644 --- a/Changes +++ b/Changes @@ -12,6 +12,8 @@ Revision history for {{$dist->name}} Karen!) - the config loading of the "perl" config loader is more reliable, but still please don't use it (thanks, Karen!) + - introducing a new plugin, [GatherFile], to support adding individual + files to the distribution (thanks, Karen!) 6.008 2016-10-05 21:35:23-04:00 America/New_York - fix the skip message from ExtraTests (thanks, Roy Ivy Ⅲ!) diff --git a/lib/Dist/Zilla/Plugin/GatherFile.pm b/lib/Dist/Zilla/Plugin/GatherFile.pm new file mode 100644 index 000000000..6d0d7f80f --- /dev/null +++ b/lib/Dist/Zilla/Plugin/GatherFile.pm @@ -0,0 +1,134 @@ +package Dist::Zilla::Plugin::GatherFile; +# ABSTRACT: gather individual file(s) + +use Moose; +use Dist::Zilla::Types qw(Path ArrayRefOfPaths); +with 'Dist::Zilla::Role::FileGatherer'; + +use MooseX::Types::Moose 'ArrayRef'; +use Path::Tiny; +use Dist::Zilla::File::OnDisk; +use namespace::autoclean; + +=head1 SYNOPSIS + + [GatherFile] + filename = examples/file.txt + +=head1 DESCRIPTION + +This is a very, very simple L +plugin. It adds all the files referenced by the C option that are +found in the directory named in the L attribute. If the root begins +with a tilde, the tilde is replaced with the current user's home directory +according to L. + +Since normally every distribution will use a GatherDir plugin, you would only +need to use the GatherFile plugin if the file was already being excluded (e.g. +from an C configuration). + +=cut + +=attr root + +This is the directory in which to look for files. If not given, it defaults to +the dist root -- generally, the place where your F or other +configuration file is located. + +=cut + +has root => ( + is => 'ro', + isa => Path, + lazy => 1, + coerce => 1, + required => 1, + default => sub { shift->zilla->root }, +); + +=attr prefix + +This parameter can be set to place the gathered files under a particular +directory. See the L above for an example. + +=cut + +has prefix => ( + is => 'ro', + isa => 'Str', + default => '', +); + +=attr filename + +The name of the file to gather, relative to the C. +Can be used more than once. + +=cut + +has filenames => ( + is => 'ro', isa => ArrayRefOfPaths, + lazy => 1, + coerce => 1, + default => sub { [] }, +); + +sub mvp_aliases { +{ filename => 'filenames' } } +sub mvp_multivalue_args { qw(filenames) } + +around dump_config => sub { + my $orig = shift; + my $self = shift; + + my $config = $self->$orig; + + $config->{+__PACKAGE__} = { + prefix => $self->prefix, + # only report relative to dist root to avoid leaking private info + root => path($self->root)->relative($self->zilla->root), + filenames => [ sort @{ $self->filenames } ], + }; + + return $config; +}; + +sub gather_files { + my ($self) = @_; + + my $repo_root = $self->zilla->root; + my $root = "" . $self->root; + $root =~ s{^~([\\/])}{require File::HomeDir; File::HomeDir::->my_home . $1}e; + $root = path($root); + $root = $root->absolute($repo_root) if path($root)->is_relative; + + for my $filename (@{ $self->filenames }) + { + $filename = $root->child($filename); + $self->log_fatal("$filename is a directory! Use [GatherDir] instead?") if -d $filename; + + my $fileobj = $self->_file_from_filename($filename->stringify); + + $filename = $fileobj->name; + my $file = path($filename)->relative($root); + $file = path($self->prefix, $file) if $self->prefix; + + $fileobj->name($file->stringify); + $self->add_file($fileobj); + } + + return; +} + +# as in GatherDir +sub _file_from_filename { + my ($self, $filename) = @_; + + my @stat = stat $filename or $self->log_fatal("$filename does not exist!"); + + return Dist::Zilla::File::OnDisk->new({ + name => $filename, + mode => $stat[2] & 0755, # kill world-writeability + }); +} + +__PACKAGE__->meta->make_immutable; diff --git a/lib/Dist/Zilla/Types.pm b/lib/Dist/Zilla/Types.pm index b2e7e6d5f..3b2d6bfcc 100644 --- a/lib/Dist/Zilla/Types.pm +++ b/lib/Dist/Zilla/Types.pm @@ -15,10 +15,11 @@ that's what you want. use MooseX::Types -declare => [qw( License OneZero YesNoStr ReleaseStatus - Path + Path ArrayRefOfPaths _Filename )]; -use MooseX::Types::Moose qw(Str Int Defined); +use MooseX::Types::Moose qw(Str Int Defined ArrayRef); +use Path::Tiny; subtype License, as class_type('Software::License'); @@ -28,6 +29,12 @@ coerce Path, from Defined, via { Dist::Zilla::Path::path($_); }; +subtype ArrayRefOfPaths, as ArrayRef[Path]; +coerce ArrayRefOfPaths, from ArrayRef[Defined], via { + require Dist::Zilla::Path; + [ map { Dist::Zilla::Path::path($_) } @$_ ]; +}; + subtype OneZero, as Str, where { $_ eq '0' or $_ eq '1' }; subtype YesNoStr, as Str, where { /\A(?:y|ye|yes)\Z/i or /\A(?:n|no)\Z/i }; @@ -38,6 +45,6 @@ coerce OneZero, from YesNoStr, via { /\Ay/i ? 1 : 0 }; subtype _Filename, as Str, where { $_ !~ qr/(?:\x{0a}|\x{0b}|\x{0c}|\x{0d}|\x{85}|\x{2028}|\x{2029})/ }, - message { "Filename contains a newline or other vertical whitespace" }; + message { "Filename not a Str, or contains a newline or other vertical whitespace" }; 1; diff --git a/t/plugins/gatherfile.t b/t/plugins/gatherfile.t new file mode 100644 index 000000000..ecc933b06 --- /dev/null +++ b/t/plugins/gatherfile.t @@ -0,0 +1,125 @@ +use strict; +use warnings; + +use Test::More 0.88; +use if $ENV{AUTHOR_TESTING}, 'Test::Warnings'; +use Test::DZil; +use Test::Fatal; +use Path::Tiny; + +{ + my $tzil = Builder->from_config( + { dist_root => 'does-not-exist' }, + { + add_files => { + path(qw(source dist.ini)) => simple_ini( + [ 'GatherFile' => { + filename => 'lib/DZT/Sample.pm', + }], + ), + path(qw(source lib DZT Sample.pm)) => "package DZT::Sample;\n1", + }, + }, + ); + + $tzil->chrome->logger->set_debug(1); + is( + exception { $tzil->build }, + undef, + 'build proceeds normally', + ); + + my $build_dir = path($tzil->tempdir)->child('build'); + ok(-e $build_dir->child(qw(lib DZT Sample.pm)), 'file was gathered correctly'); + + diag 'got log messages: ', explain $tzil->log_messages + if not Test::Builder->new->is_passing; +} + +{ + my $tzil = Builder->from_config( + { dist_root => 'does-not-exist' }, + { + add_files => { + path(qw(source dist.ini)) => simple_ini( + [ 'GatherFile' => { + filename => 'lib/DZT/Sample.pm', + }], + ), + # no source/lib/DZT/Sample.pm + }, + }, + ); + + $tzil->chrome->logger->set_debug(1); + like( + exception { $tzil->build }, + qr{lib/DZT/Sample.pm does not exist!}, + 'missing file is detected', + ); + + diag 'got log messages: ', explain $tzil->log_messages + if not Test::Builder->new->is_passing; +} + +{ + my $tzil = Builder->from_config( + { dist_root => 'does-not-exist' }, + { + add_files => { + path(qw(source dist.ini)) => simple_ini( + [ 'GatherFile' => { + filename => 'subdir/index.html', + root => 'corpus/extra', + }], + ), + }, + also_copy => { 'corpus/extra' => 'source/corpus/extra' }, + }, + ); + + $tzil->chrome->logger->set_debug(1); + is( + exception { $tzil->build }, + undef, + 'build proceeds normally', + ); + + my $build_dir = path($tzil->tempdir)->child('build'); + ok(-e $build_dir->child(qw(subdir index.html)), 'file was gathered correctly from a different root'); + + diag 'got log messages: ', explain $tzil->log_messages + if not Test::Builder->new->is_passing; +} + +{ + my $tzil = Builder->from_config( + { dist_root => 'does-not-exist' }, + { + add_files => { + path(qw(source dist.ini)) => simple_ini( + [ 'GatherFile' => { + filename => 'lib/DZT/Sample.pm', + prefix => 'stuff', + }], + ), + path(qw(source lib DZT Sample.pm)) => "package DZT::Sample;\n1", + }, + }, + ); + + $tzil->chrome->logger->set_debug(1); + is( + exception { $tzil->build }, + undef, + 'build proceeds normally', + ); + + my $build_dir = path($tzil->tempdir)->child('build'); + ok(-e $build_dir->child(qw(stuff lib DZT Sample.pm)), 'file was gathered correctly into the prefix dir'); + + diag 'got log messages: ', explain $tzil->log_messages + if not Test::Builder->new->is_passing; +} + +done_testing;