new plugin to allow gathering individual files

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 Ⅲ!)

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<FileGatherer|Dist::Zilla::Role::FileGatherer>
+plugin.  It adds all the files referenced by the C<filename> option that are
+found in the directory named in the L</root> attribute.  If the root begins
+with a tilde, the tilde is replaced with the current user's home directory
+according to L<File::HomeDir>.
+
+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<exclude_match> 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<dist.ini> 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<description|DESCRIPTION> 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<root>.
+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;

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;

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;