File Coverage

blib/lib/Minilla/WorkDir.pm
Criterion Covered Total %
statement 57 156 36.5
branch 0 30 0.0
condition 0 3 0.0
subroutine 19 32 59.3
pod 0 7 0.0
total 76 228 33.3


line stmt bran cond sub pod time code
1             package Minilla::WorkDir;
2 1     1   10 use strict;
  1         2  
  1         30  
3 1     1   6 use warnings;
  1         2  
  1         24  
4 1     1   10 use utf8;
  1         3  
  1         6  
5 1     1   836 use Archive::Tar;
  1         87026  
  1         78  
6 1     1   11 use File::pushd;
  1         2  
  1         55  
7 1     1   626 use Data::Dumper; # serializer
  1         6233  
  1         65  
8 1     1   9 use File::Spec::Functions qw(splitdir);
  1         4  
  1         49  
9 1     1   11 use File::Spec;
  1         2  
  1         23  
10 1     1   6 use Time::Piece qw(gmtime);
  1         2  
  1         12  
11 1     1   96 use File::Basename qw(dirname);
  1         2  
  1         48  
12 1     1   6 use File::Path qw(mkpath);
  1         3  
  1         39  
13 1     1   506 use File::Copy qw(copy);
  1         2378  
  1         58  
14 1     1   7 use Config;
  1         2  
  1         31  
15              
16 1     1   9 use Minilla::Logger;
  1         2  
  1         64  
17 1     1   8 use Minilla::Util qw(randstr cmd cmd_perl slurp slurp_raw spew spew_raw pod_escape);
  1         2  
  1         78  
18 1     1   444 use Minilla::FileGatherer;
  1         3  
  1         35  
19 1     1   452 use Minilla::ReleaseTest;
  1         5  
  1         31  
20              
21 1     1   6 use Moo;
  1         5  
  1         9  
22              
23             has project => (
24             is => 'ro',
25             required => 1,
26             handles => [qw(files)],
27             );
28              
29             has dir => (
30             is => 'lazy',
31             isa => sub {
32             Carp::confess("'dir' must not be undef") unless defined $_[0];
33             },
34             );
35              
36             has manifest_files => (
37             is => 'lazy',
38             );
39              
40             has [qw(prereq_specs)] => (
41             is => 'lazy',
42             );
43              
44             has 'cleanup' => (
45             is => 'ro',
46             default => sub { $Minilla::DEBUG ? 0 : 1 },
47             );
48              
49             has changes_time => (
50             is => 'lazy',
51             );
52              
53 1     1   566 no Moo;
  1         3  
  1         4  
54              
55 0     0     sub _build_changes_time { scalar(gmtime()) }
56              
57             sub DEMOLISH {
58 0     0 0   my $self = shift;
59 0 0         if ($self->cleanup) {
60 0           infof("Removing %s\n", $self->dir);
61 0           File::Path::rmtree($self->dir)
62             }
63             }
64              
65             sub _build_dir {
66 0     0     my $self = shift;
67 0 0         my $dirname = $^O eq 'MSWin32' ? '_build' : '.build';
68 0           File::Spec->catfile($self->project->dir, $dirname, randstr(8));
69             }
70              
71             sub _build_prereq_specs {
72 0     0     my $self = shift;
73              
74 0           my $cpanfile = Module::CPANfile->load(File::Spec->catfile($self->project->dir, 'cpanfile'));
75 0           return $cpanfile->prereq_specs;
76             }
77              
78             sub _build_manifest_files {
79 0     0     my $self = shift;
80 0           my @files = (@{$self->files}, qw(LICENSE META.json META.yml MANIFEST));
  0            
81 0 0         if (-f File::Spec->catfile($self->dir, 'Makefile.PL')) {
82 0           push @files, 'Makefile.PL';
83             } else {
84 0           push @files, 'Build.PL';
85             }
86              
87 0           [do {
88 0           my %h;
89 0           grep {!$h{$_}++} @files;
  0            
90             }];
91             }
92              
93             sub as_string {
94 0     0 0   my $self = shift;
95 0           $self->dir;
96             }
97              
98             sub BUILD {
99 0     0 0   my ($self) = @_;
100              
101 0           infof("Creating working directory: %s\n", $self->dir);
102              
103             # copying
104 0           mkpath($self->dir);
105 0           for my $src (@{$self->files}) {
  0            
106 0 0         next if -d $src;
107 0           debugf("Copying %s\n", $src);
108              
109 0 0         if (not -e $src) {
110 0           warnf("Trying to copy non-existing file '$src', ignored\n");
111 0           next;
112             }
113 0           my $dst = File::Spec->catfile($self->dir, File::Spec->abs2rel($src, $self->project->dir));
114 0           mkpath(dirname($dst));
115 0           infof("cp %s %s\n", $src, $dst);
116 0 0         copy($src => $dst) or die "Copying failed: $src $dst, $!\n";
117 0 0         chmod((stat($src))[2], $dst) or die "Cannot change mode: $dst, $!\n";
118             }
119             }
120              
121             sub build {
122 0     0 0   my ($self) = @_;
123              
124 0 0         return if $self->{build}++;
125              
126 0           my $guard = pushd($self->dir);
127              
128 0           infof("Building %s\n", $self->dir);
129              
130             # Generate meta file
131             {
132 0           my $meta = $self->project->cpan_meta();
133 0           $meta->save('META.yml', {
134             version => 1.4,
135             });
136 0           $meta->save('META.json', {
137             version => 2.0,
138             });
139             }
140              
141             {
142 0           infof("Writing MANIFEST file\n");
  0            
  0            
143 0           spew('MANIFEST', join("\n", @{$self->manifest_files}));
  0            
144             }
145              
146 0           $self->project->regenerate_files();
147 0           $self->_rewrite_changes();
148 0           $self->_rewrite_pod();
149              
150 0 0         unless ($ENV{MINILLA_DISABLE_WRITE_RELEASE_TEST}) { # DO NOT USE THIS ENVIRONMENT VARIABLE.
151 0           Minilla::ReleaseTest->write_release_tests($self->project, $self->dir);
152             }
153              
154 0 0         if (-f 'Build.PL') {
    0          
155 0           cmd_perl('Build.PL');
156 0           cmd_perl('Build', 'build');
157             } elsif (-f 'Makefile.PL') {
158 0           cmd_perl('Makefile.PL');
159 0           cmd($Config{make});
160             } else {
161 0           die "There is no Makefile.PL/Build.PL";
162             }
163             }
164              
165             sub _rewrite_changes {
166 0     0     my $self = shift;
167              
168 0           my $orig = slurp_raw('Changes');
169 0           $orig =~ s!\{\{\$NEXT\}\}!
170 0           $self->project->version . ' ' . $self->changes_time->strftime('%Y-%m-%dT%H:%M:%SZ')
171             !e;
172 0           spew_raw('Changes', $orig);
173             }
174              
175             sub _rewrite_pod {
176 0     0     my $self = shift;
177              
178             # Disabled this feature.
179             # my $orig =slurp_raw($self->project->main_module_path);
180             # if (@{$self->project->contributors}) {
181             # $orig =~ s!
182             # (^=head \d \s+ (?:authors?)\b \s*)
183             # (.*?)
184             # (^=head \d \s+ | \z)
185             # !
186             # ( $1
187             # . $2
188             # . "=head1 CONTRIBUTORS\n\n=over 4\n\n"
189             # . join( '', map { "=item $_\n\n" } map { pod_escape($_) } @{ $self->project->contributors } )
190             # . "=back\n\n"
191             # . $3 )
192             # !ixmse;
193             # spew_raw($self->project->main_module_path => $orig);
194             # }
195             }
196              
197             # Return non-zero if fail
198             sub dist_test {
199 0     0 0   my ($self, @targets) = @_;
200              
201 0           $self->build();
202              
203 0           $self->project->verify_prereqs();
204              
205 0           eval {
206 0           my $guard = pushd($self->dir);
207 0           $self->project->module_maker->run_tests();
208             };
209 0 0         return $@ ? 1 : 0;
210             }
211              
212             sub dist {
213 0     0 0   my ($self) = @_;
214              
215 0   0       $self->{tarball} ||= do {
216 0           $self->build();
217              
218 0           my $guard = pushd($self->dir);
219              
220             # Create tar ball
221 0           my $tarball = sprintf('%s-%s.tar.gz', $self->project->dist_name, $self->project->version);
222              
223 0           my $force_mode = 0;
224              
225 0           my $tar = Archive::Tar->new;
226 0           for my $file (@{$self->manifest_files}) {
  0            
227 0           my $filename = File::Spec->catfile($self->project->dist_name . '-' . $self->project->version, $file);
228 0           my $data = slurp($file);
229              
230 0           my $mode = (stat($file))[2];
231              
232             # On Windows, (stat($file))[2] * ALWAYS * results in octal 0100666 (which means it is
233             # world writeable). World writeable files are always rejected by PAUSE. The solution is to
234             # change a file mode octal 0100666 to octal 000664, such that it is * NOT * world
235             # writeable. This works on Windows, as well as on other systems (Linux, Mac, etc...), because
236             # the filemode 0100666 only occurs on Windows. (If it occurred on Linux, it would be wrong anyway)
237              
238 0 0         if ($mode == 0100666) {
239 0           $mode = 0644;
240 0           $force_mode++;
241             }
242              
243 0           $tar->add_data($filename, $data, { mode => $mode });
244             }
245 0           $tar->write($tarball, COMPRESS_GZIP);
246 0 0         infof("Wrote %s\n", $tarball.($force_mode == 0 ? '' : ' --> forced to mode 000664'));
247              
248 0           File::Spec->rel2abs($tarball);
249             };
250             }
251              
252             sub run {
253 0     0 0   my ($self, @cmd) = @_;
254 0           $self->build();
255              
256 0           eval {
257 0           my $guard = pushd($self->dir);
258 0           cmd(@cmd);
259             };
260 0 0         return $@ ? 1 : 0;
261             }
262              
263             1;