File Coverage

blib/lib/Zilla/Dist.pm
Criterion Covered Total %
statement 21 156 13.4
branch 0 92 0.0
condition 0 11 0.0
subroutine 7 27 25.9
pod 1 20 5.0
total 29 306 9.4


line stmt bran cond sub pod time code
1 1     1   1226 use strict; use warnings;
  1     1   2  
  1         28  
  1         5  
  1         1  
  1         46  
2             package Zilla::Dist;
3             our $VERSION = '0.1.17';
4              
5 1     1   457 use version;
  1         3605  
  1         6  
6 1     1   519 use File::Share;
  1         29235  
  1         107  
7 1     1   566 use Hash::Merge 'merge';
  1         9918  
  1         60  
8 1     1   551 use IO::All;
  1         12473  
  1         9  
9 1     1   782 use YAML::PP;
  1         70220  
  1         2573  
10              
11             Hash::Merge::set_behavior('RIGHT_PRECEDENT');
12              
13             sub new {
14 0     0 1   my $class = shift;
15 0           bless {@_}, $class;
16             }
17              
18             sub run {
19 0     0 0   my ($self, @args) = @_;
20 0 0         @args = ('help') unless @args;
21 0 0         @args = ('version') if "@args" =~ /^(-v|--version)$/;
22 0           my $cmd = lc(shift @args);
23 0 0         if ($cmd =~ /^(?:
24             test|install|release|update|prereqs|clean|
25             dist|distdir|distshell|disttest|
26             cpan|cpanshell
27             )$/x) {
28 0           unshift @args, $cmd;
29 0           $cmd = 'make';
30             }
31 0           my $method = "do_$cmd";
32 0 0         $self->usage, return unless $self->can($method);
33 0           $self->{meta} = $self->get_meta;
34 0           $self->$method(@args);
35             }
36              
37             sub get_meta {
38 0     0 0   my ($self) = @_;
39             my $meta = -f 'Meta'
40 0 0 0       ? eval { YAML::PP::LoadFile('Meta') } || {}
41             : {};
42 0 0         if (my $base_file = delete($meta->{base})) {
43 0           my $base = YAML::PP::LoadFile($base_file);
44 0           $meta = merge($base, $meta);
45             }
46 0           return $meta;
47             }
48              
49             sub do_make {
50 0     0 0   my ($self, @args) = @_;
51 0           my @cmd = ('make', '-f', $self->find_sharefile('Makefile'), @args);
52 0 0         system(@cmd) == 0
53             or die "'@cmd' failed: $!\n";
54             }
55              
56             sub do_makefile {
57 0     0 0   my ($self, @args) = @_;
58 0           print $self->find_sharefile('Makefile'), "\n";
59             }
60              
61             sub do_copy {
62 0     0 0   my ($self, $file, $target) = @_;
63 0   0       $target ||= $file;
64              
65 0           my $file_content = io->file($self->find_sharefile($file))->all;
66 0           io->file($target)->print($file_content);
67              
68 0           print "Zilla::Dist copied shared '$file' to '$target'\n";
69             }
70              
71             sub do_version {
72 0     0 0   my ($self, @args) = @_;
73 0           print "$VERSION\n";
74             }
75              
76             sub update_makefile {
77 0     0 0   my ($self, $makefile_path) = @_;
78 0           my $makefile_content = io->file($self->find_sharefile('Makefile'))->all;
79 0           io->file($makefile_path)->print($makefile_content);
80             }
81              
82             sub do_sharedir {
83 0     0 0   my ($self, @args) = @_;
84 0           print $self->find_sharedir . "\n";
85             }
86              
87             my $default = {
88             branch => 'master',
89             };
90             sub do_meta {
91 0     0 0   my ($self, $key) = @_;
92 0           my $keys = [ split '/', $key ];
93 0           my $meta = $self->{meta};
94 0           my $value = $meta;
95 0           for my $k (@$keys) {
96 0 0         return unless ref($value) eq 'HASH';
97 0   0       $value = $value->{$k} || $default->{$k};
98 0 0         last unless defined $value;
99             }
100 0 0         if (defined $value) {
101 0 0         if (not ref $value) {
    0          
    0          
102 0           print "$value\n";
103             }
104             elsif (ref($value) eq 'ARRAY') {
105 0           print "$_\n" for @$value;
106             }
107             elsif (ref($value) eq 'HASH') {
108 0           for my $kk (sort keys %$value) {
109 0 0         print "$kk\n" unless $kk =~ /^(?:perl)$/;
110             }
111             }
112             else {
113 0           print "$value\n";
114             }
115             }
116             }
117              
118             sub do_changes {
119 0     0 0   my ($self, $key, $value) = @_;
120 0 0         return if $self->{meta}{'=zild'}{no_changes_yaml};
121 0           my @changes = YAML::PP::LoadFile('Changes');
122 0           $self->validate_changes(\@changes);
123 0 0         return unless @changes;
124 0 0         if ($value) {
125 0           chomp $value;
126 0 0         die unless length $value;
127 0 0         my $text = io->file('Changes')->all or die;
128 0           my $line = sprintf "%-8s %s", "$key:", $value;
129 0 0         $text =~ s/^$key:.*/$line/m or die;
130 0           io->file('Changes')->print($text);
131             }
132             else {
133 0 0         $value = $changes[0]{$key} or return;
134 0           print "$value\n";
135             }
136             }
137              
138             sub error {
139 0     0 0   die "Error: $_[0]\n";
140             }
141              
142             sub validate_changes {
143 0     0 0   my ($self, $changes) = @_;
144 0 0         return if $self->{meta}{'=zild'}{no_changes_yaml};
145              
146 0 0         scalar(@$changes) or error "Changes file is empty";
147              
148 0           for (my $i = 1; $i <= @$changes; $i++) {
149 0           my $entry = $changes->[$i - 1];
150 0 0         ref($entry) eq 'HASH'
151             or error "Changes entry #$i is not a hash";
152 0           my @keys = keys %$entry;
153 0 0         @keys == 3
154             or error "Changes entry #$i doesn't have 3 keys";
155 0           for my $key (qw(version date changes)) {
156             error "Changes entry #$i is missing field '$key'"
157 0 0         unless exists $entry->{$key};
158             error "Changes entry #$i has undefined field '$key'"
159 0 0 0       unless defined $entry->{$key} or $key eq 'date';
160 0 0         if (defined $entry->{$key}) {
161 0 0         if ($key eq 'changes') {
162             error "Changes entry #$i field '$key' should be an array"
163 0 0         unless ref($entry->{$key}) eq 'ARRAY';
164 0           my $change_list = $entry->{changes};
165 0           for my $change_entry (@$change_list) {
166 0 0         error "Changes entry #$i has non-scalar 'changes' entry"
167             if ref $change_entry;
168             }
169             }
170             else {
171             error "Changes entry #$i field '$key' should be a scalar"
172 0 0         if ref($entry->{$key});
173             }
174             }
175             }
176             }
177 0 0         if (@$changes >= 2) {
178 0           my $changes1 = join '%^&*', @{$changes->[0]{changes}};
  0            
179 0           my $changes2 = join '%^&*', @{$changes->[1]{changes}};
  0            
180 0 0         error "2 most recent Changes messages cannot be the same!"
181             if $changes1 eq $changes2;
182 0           my $v0 = $changes->[0]{version};
183 0           my $v1 = $changes->[1]{version};
184 0 0         error "latest Changes version ($v0) is not greater than previous ($v1)"
185             unless version->parse($v0) > version->parse($v1);
186             }
187             }
188              
189             sub find_sharefile {
190 0     0 0   my ($self, $file) = @_;
191 0           my $path = $self->find_sharedir . '/' . $file;
192 0 0         -e $path or die "Can't find shared Zilla::Dist file '$file'";
193 0           return $path;
194             }
195              
196             sub find_sharedir {
197 0     0 0   my ($self) = @_;
198 0           my $sharedir = File::Share::dist_dir('Zilla-Dist');
199 0 0         -d $sharedir or die "Can't find Zilla::Dist share dir";
200 0           return $sharedir;
201             }
202              
203             sub do_webhooks {
204 0     0 0   my ($self) = @_;
205 0 0         return unless $ENV{PERL_ZILLA_DIST_GIT_HUB_WEBHOOKS};
206 0 0         return unless -d '.git';
207 0           my $path = '.git/zilla-dist/webhooks';
208 0           my $travis = io->file("$path/travis");
209 0           my $irc = io->file("$path/irc");
210 0           for my $hook (qw(travis irc)) {
211 0           my $file = io->file("$path/$hook");
212 0 0         if ($file->exists) {
213 0           my $hook_version = $file->chomp->getline;
214 0           my $api_version = '0.0.95';
215             next if
216 0 0         version->parse($hook_version) >=
217             version->parse($api_version);
218             }
219 0           my $method = "webhook_command_$hook";
220 0 0         my $command = $self->$method or next;
221 0           print "Running: '$command'\n";
222 0 0         system($command) == 0
223             or die "Error: command failed '$command': $!";
224 0           io->file("$path/$hook")->assert->print($VERSION);
225             }
226             }
227              
228             sub webhook_command_travis {
229 0     0 0   my ($self) = @_;
230 0           return "git hub travis-enable";
231             }
232              
233             sub webhook_command_irc {
234 0     0 0   my ($self) = @_;
235 0           my $irc;
236 0 0         return unless $irc = $self->{meta}{devel}{irc};
237 0 0         return unless $irc =~ /^(\w\S*)#(\w\S*)$/;
238 0           return "git hub irc-enable $2 $1";
239             }
240              
241             sub do_years {
242 0     0 0   my ($self, $key, $value) = @_;
243 0           my %hash = eval {
244 0           map {($_ => 1)} grep {$_} map {
  0            
245 0           $_->{date} =~ /(\d{4})/;
  0            
246 0           $1;
247             } (YAML::PP::LoadFile('Changes'));
248             };
249 0 0         return if $@;
250 0           print join(' ', sort keys %hash) . "\n";
251             }
252              
253             sub usage {
254 0     0 0   print <<'...';
255              
256             Usage:
257              
258             zild make <rule> # Run `make <rule>` with Zilla::Dist Makefile
259             zild meta <key> # Print Meta value for a key
260             zild copy <file> <dest> # Copy a shared file
261             zild version # Print Zilla::Dist version
262              
263             The following commands are aliases for `zild make <cmd>`
264              
265             zild test zild dist zild cpan
266             zild install zild distdir zild cpanshell
267             zild release zild distshell
268             zild update zild disttest
269             zild clean
270              
271             Internal commands issued by the Makefile:
272              
273             zild sharedir # Print the location of the Zilla::Dist share dir
274             zild makefile # Print the location of the Zilla::Dist 'Makefile'
275             zild changes <key> [<value>]
276              
277             ...
278             }
279              
280             1;