Update META checker
[Config-Perl-V.git] / sandbox / genMETA.pm
blobdfaa8120384c776594d7d711f12dc8019c6ef6ec
1 #!/pro/bin/perl
3 package genMETA;
5 our $VERSION = "1.04-20130212";
7 use 5.014;
8 use warnings;
9 use Carp;
11 use List::Util qw( first );
12 use Encode qw( encode decode );
13 use Term::ANSIColor qw(:constants);
14 use Test::CPAN::Meta::YAML::Version;
15 use CPAN::Meta::Converter;
16 use Test::MinimumVersion;
17 use Test::More ();
18 use Parse::CPAN::Meta;
19 use File::Find;
20 use YAML::Syck;
21 use Data::Peek;
22 use Text::Diff;
23 use JSON::PP;
25 sub new
27 my $package = shift;
28 return bless { @_ }, $package;
29 } # new
31 sub version_from
33 my ($self, $src) = @_;
35 $self->{mfpr} = {};
36 if (open my $mh, "<", "Makefile.PL") {
37 my $mf = do { local $/; <$mh> };
39 if ($mf =~ m{\b NAME \s*=>\s* ["'] (\S+) ['"]}x) {
40 $self->{name} = $1;
41 $self->{name} =~ m/-/ and
42 warn RED, "NAME in Makefile.PL contains a -", RESET, "\n";
43 $self->{name} =~ s/::/-/g;
45 if ($mf =~ m{\b DISTNAME \s*=>\s* ["'] (\S+) ['"]}x) {
46 $self->{name} = $1;
49 if ($mf =~ m{\b VERSION_FROM \s*=>\s* ["'] (\S+) ['"]}x) {
50 my $from = $1;
51 -f $from or
52 die RED, "Makefile wants version from nonexisten $from", RESET, "\n";
53 $self->{from} //= $from;
54 $from eq $self->{from} or
55 die RED, "VERSION_FROM mismatch Makefile.PL / YAML", RESET, "\n";
58 if ($mf =~ m[\b PREREQ_PM \s*=>\s* \{ ( [^}]+ ) \}]x) {
59 my @pr = split m/\n/ => $1;
60 $self->{mfpr} = { map { (m{ \b ["']? (\S+?) ['"]? \s*=>\s* ["']? ([-0-9._]+) ['"]? }x) } grep !m/^\s*#/ => @pr };
63 $mf =~ m{--format=ustar} or
64 warn RED, "TARFLAGS macro is missing", RESET, "\n";
67 $src //= $self->{from} or croak "No file to extract version from";
69 my $version;
70 open my $pm, "<", $src or croak "Cannot read $src";
71 while (<$pm>) {
72 m/^(?:our\s+)? \$VERSION \s*=\s* ["']? ([-0-9._]+) ['"]? \s*;\s*$/x or next;
73 $version = $1;
74 last;
76 close $pm;
77 $version or croak "Cannot extract VERSION from $src\n";
78 $self->{version} = $version;
79 return $version
80 } # version_from
82 sub from_data
84 my ($self, @data) = @_;
85 $self->{version} or $self->version_from ();
86 s/VERSION/$self->{version}/g for @data;
87 $self->{yml} = \@data;
88 $self->check_yaml ();
89 return @data;
90 } # from_data
92 sub check_encoding
94 my $self = shift;
95 my @tf = grep m{^(?: change | readme | .*\.pod )}ix => glob "*";
96 (my $tf = join ", " => @tf) =~ s/.*\K, / and /;
98 print "Check if $tf are still valid UTF8 ...\n";
99 foreach my $tf (@tf) {
100 open my $fh, "<", $tf or croak "$tf: $!\n";
101 my @c = <$fh>;
102 my $c = join "" => @c;
103 my @e;
104 my $s = decode ("utf-8", $c, sub { push @e, shift; });
105 if (@e) {
106 my @l;
107 my $n = 0;
108 for (@c) {
109 $n++;
110 eval { decode ("utf-8", $_, 1) };
111 $@ or next;
112 $@ =~ s{ at /\S+ line \d+.*}{};
113 print BLUE, "$tf:$n\t$_\t$@", RESET;
115 croak "$tf is not valid UTF-8\n";
117 my $u = encode ("utf-8", $s);
118 $c eq $u and next;
120 my $n;
121 $n = 1; $c =~ s/^/$n++ . "\t"/gem;
122 $n = 1; $u =~ s/^/$n++ . "\t"/gem;
123 croak "$tf: recode makes content differ\n". diff \$c, \$u;
125 } # check_encoding
127 sub check_required
129 my $self = shift;
131 my $yml = $self->{h} or croak "No YAML to check";
133 warn "Check required and recommended module versions ...\n";
134 BEGIN { $V::NO_EXIT = $V::NO_EXIT = 1 } require V;
135 my %req = map { %{$yml->{$_}} } grep m/requires/ => keys %{$yml};
136 my %rec = map { %{$yml->{$_}} } grep m/recommends/ => keys %{$yml};
137 if (my $of = $yml->{optional_features}) {
138 foreach my $f (values %{$of}) {
139 my %q = map { %{$f->{$_}} } grep m/requires/ => keys %{$f};
140 my %c = map { %{$f->{$_}} } grep m/recommends/ => keys %{$f};
141 @req{keys %q} = values %q;
142 @rec{keys %c} = values %c;
145 my %vsn = ( %req, %rec );
146 delete @vsn{qw( perl version )};
147 for (sort keys %vsn) {
148 if (my $mfv = delete $self->{mfpr}{$_}) {
149 $req{$_} eq $mfv or
150 die RED, "PREREQ mismatch for $_ Makefile.PL ($mfv) / YAML ($req{$_})", RESET, "\n";
152 $vsn{$_} eq "0" and next;
153 my $v = V::get_version ($_);
154 $v eq $vsn{$_} and next;
155 printf STDERR "%s%-35s %-6s => %s%s%s\n", BLUE, $_, $vsn{$_}, GREEN, $v, RESET;
157 if (my @mfpr = sort keys %{$self->{mfpr}}) {
158 die RED, "Makefile.PL requires @mfpr, YAML does not", RESET, "\n";
161 find (sub {
162 $File::Find::dir =~ m{^blib\b} and return;
163 $File::Find::name =~ m{(?:^|/)Bundle/.*\.pm} or return;
164 if (open my $bh, "<", $_) {
165 warn "Check bundle module versions $File::Find::name ...\n";
166 while (<$bh>) {
167 my ($m, $dv) = m/^([A-Za-z_:]+)\s+([0-9.]+)\s*$/ or next;
168 my $v = $m eq $self->{name} ? $self->{version} : V::get_version ($m);
169 $v eq $dv and next;
170 printf STDERR "%s%-35s %-6s => %s%s%s\n", BLUE, $m, $dv, GREEN, $v, RESET;
173 }, glob "*");
175 if (ref $self->{h}{provides}) {
176 print "Check distribution module versions ...\n";
177 foreach my $m (sort keys %{$self->{h}{provides}}) {
178 $m eq $self->{name} and next;
179 my $ev = $self->{h}{provides}{$m}{version};
180 printf " Expect %5s for %-32s ", $ev, $m;
181 my $fn = $self->{h}{provides}{$m}{file};
182 if (open my $fh, "<", $fn) {
183 my $fv;
184 while (<$fh>) {
185 m/\bVERSION\s*=\s*["']?([-0-9.]+)/ or next;
186 $fv = $1;
187 print $fv eq $ev ? "ok\n" : RED." mismatch, module has $1".RESET."\n";
188 last;
190 defined $fv or print " .. no version defined\n";
192 else {
193 print " .. cannot open $fn: $!\n";
197 } # check_required
199 sub check_yaml
201 my $self = shift;
203 my @yml = @{$self->{yml}} or croak "No YAML to check";
205 warn "Checking generated YAML ...\n";
206 my $h;
207 my $yml = join "", @yml;
208 eval { $h = Load ($yml) };
209 $@ and croak "$@\n";
210 $self->{name} //= $h->{name};
211 $self->{name} eq $h->{name} or
212 die RED, "NAME mismatch Makefile.PL / YAML", RESET, "\n";
213 $self->{name} =~ s/-/::/g;
214 warn "Checking for $self->{name}-$self->{version}\n";
216 $self->{verbose} and print Dump $h;
218 my $t = Test::CPAN::Meta::YAML::Version->new (data => $h);
219 $t->parse () and
220 croak join "\n", "Test::CPAN::Meta::YAML reported failure:", $t->errors, "";
222 eval { Parse::CPAN::Meta::Load ($yml) };
223 $@ and croak "$@\n";
225 $self->{h} = $h;
226 $self->{yaml} = $yml;
227 } # check_yaml
229 sub check_minimum
231 my $self = shift;
232 my $reqv = $self->{h}{requires}{perl};
233 my $locs;
235 for (@_) {
236 if (ref $_ eq "ARRAY") {
237 $locs = { paths => $_ };
239 elsif (ref $_ eq "HASH") {
240 $locs = $_;
242 else {
243 $reqv = $_;
246 my $paths = (join ", " => @{($locs // {})->{paths} // []}) || "default paths";
248 $reqv or croak "No minimal required version for perl";
249 print "Checking if $reqv is still OK as minimal version for $paths\n";
250 # All other minimum version checks done in xt
251 Test::More::subtest "Minimum perl version $reqv" => sub {
252 all_minimum_version_ok ($reqv, $locs);
253 } or warn RED, "\n### Use 'perlver --blame' on the failing file(s)\n\n", RESET;
254 } # check_minimum
256 sub print_yaml
258 my $self = shift;
259 print @{$self->{yml}};
260 } # print_yaml
262 sub fix_meta
264 my $self = shift;
266 # Convert to meta-spec version 2
267 # licenses are lists now
268 my $jsn = $self->{h};
269 $jsn->{"meta-spec"} = {
270 version => "2",
271 url => "https://metacpan.org/module/CPAN::Meta::Spec?#meta-spec",
273 exists $jsn->{resources}{license} and
274 $jsn->{resources}{license} = [ $jsn->{resources}{license} ];
275 delete $jsn->{distribution_type};
276 if (exists $jsn->{license}) {
277 $jsn->{license} =~ s/^perl$/perl_5/;
278 $jsn->{license} = [ $jsn->{license} ];
280 if (exists $jsn->{resources}{repository}) {
281 my $url = $jsn->{resources}{repository};
282 my $web = $url;
283 $url =~ s{repo.or.cz/w/}{repo.or.cz/r/};
284 $web =~ s{repo.or.cz/r/}{repo.or.cz/w/};
285 $jsn->{resources}{repository} = {
286 type => "git",
287 web => $web,
288 url => $url,
291 foreach my $sct ("", "configure_", "build_", "test_") {
292 (my $x = $sct || "runtime") =~ s/_$//;
293 for (qw( requires recommends suggests )) {
294 exists $jsn->{"$sct$_"} and
295 $jsn->{prereqs}{$x}{$_} = delete $jsn->{"$sct$_"};
299 # optional features do not yet know about requires and/or recommends diirectly
300 if (my $of = $jsn->{optional_features}) {
301 foreach my $f (keys %$of) {
302 if (my $r = delete $of->{$f}{requires}) {
303 #$jsn->{prereqs}{runtime}{recommends}{$_} //= $r->{$_} for keys %$r;
304 $of->{$f}{prereqs}{runtime}{requires} = $r;
306 if (my $r = delete $of->{$f}{recommends}) {
307 #$jsn->{prereqs}{runtime}{recommends}{$_} //= $r->{$_} for keys %$r;
308 $of->{$f}{prereqs}{runtime}{recommends} = $r;
313 $jsn = CPAN::Meta::Converter->new ($jsn)->convert (version => "2");
314 $jsn->{generated_by} = "Author";
316 my @my = glob <*/META.yml> or croak "No META files";
317 my $yf = $my[0];
318 (my $jf = $yf) =~ s/yml$/json/;
319 open my $jh, ">", $jf or croak "Cannot update $jf\n";
320 print $jh JSON::PP->new->utf8 (1)->pretty (1)->encode ($jsn);
321 close $jh;
323 # Now that 2.0 JSON is corrrect, create a 1.4 YAML back from the modified stuff
324 my $yml = $jsn;
325 # 1.4 does not know about test_*, move them to *
326 if (my $tp = delete $yml->{prereqs}{test}) {
327 foreach my $phase (keys %{$tp}) {
328 my $p = $tp->{$phase};
329 $yml->{runtime}{$phase}{$_} //= $p->{$_} for keys %{$p};
332 #DDumper $yml;
333 # This does NOT create a correct YAML id the source does not comply!
334 $yml = CPAN::Meta::Converter->new ($yml)->convert (version => "1.4");
335 #DDumper $yml;
336 exit;
338 @my == 1 && open my $my, ">", $yf or croak "Cannot update $yf\n";
339 print $my Dump $yml; # @{$self->{yml}};
340 close $my;
342 chmod 0644, glob "*/META.*";
343 unlink glob "MYMETA*";
344 } # fix_meta