sandbox/genMETA.pm

   1 #!/pro/bin/perl
   2
   3 package genMETA;
   4
   5 our $VERSION = "1.04-20130212";
   6
   7 use 5.014;
   8 use warnings;
   9 use Carp;
  10
  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;
  24
  25 sub new
  26 {
  27     my $package = shift;
  28     return bless { @_ }, $package;
  29     } # new
  30
  31 sub version_from
  32 {
  33     my ($self, $src) = @_;
  34
  35     $self->{mfpr} = {};
  36     if (open my $mh, "<", "Makefile.PL") {
  37         my $mf = do { local $/; <$mh> };
  38
  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;
  44             }
  45         if ($mf =~ m{\b DISTNAME     \s*=>\s* ["'] (\S+) ['"]}x) {
  46             $self->{name} = $1;
  47             }
  48
  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";
  56             }
  57
  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 };
  61             }
  62
  63         $mf =~ m{--format=ustar} or
  64             warn RED, "TARFLAGS macro is missing", RESET, "\n";
  65         }
  66
  67     $src //= $self->{from} or croak "No file to extract version from";
  68
  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;
  75         }
  76     close $pm;
  77     $version or croak "Cannot extract VERSION from $src\n";
  78     $self->{version} = $version;
  79     return $version
  80     } # version_from
  81
  82 sub from_data
  83 {
  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
  91
  92 sub check_encoding
  93 {
  94     my $self = shift;
  95     my @tf   = grep m{^(?: change | readme | .*\.pod )}ix => glob "*";
  96     (my $tf = join ", " => @tf) =~ s/.*\K, / and /;
  97
  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;
 114                 }
 115             croak "$tf is not valid UTF-8\n";
 116             }
 117         my $u = encode ("utf-8", $s);
 118         $c eq $u and next;
 119
 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;
 124         }
 125     } # check_encoding
 126
 127 sub check_required
 128 {
 129     my $self = shift;
 130
 131     my $yml = $self->{h} or croak "No YAML to check";
 132
 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;
 143             }
 144         }
 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";
 151             }
 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;
 156         }
 157     if (my @mfpr = sort keys %{$self->{mfpr}}) {
 158         die RED, "Makefile.PL requires @mfpr, YAML does not", RESET, "\n";
 159         }
 160
 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;
 171                 }
 172             }
 173         }, glob "*");
 174
 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;
 189                     }
 190                 defined $fv or print " .. no version defined\n";
 191                 }
 192             else {
 193                 print " .. cannot open $fn: $!\n";
 194                 }
 195             }
 196         }
 197     } # check_required
 198
 199 sub check_yaml
 200 {
 201     my $self = shift;
 202
 203     my @yml = @{$self->{yml}} or croak "No YAML to check";
 204
 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";
 215
 216     $self->{verbose} and print Dump $h;
 217
 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, "";
 221
 222     eval { Parse::CPAN::Meta::Load ($yml) };
 223     $@ and croak "$@\n";
 224
 225     $self->{h}    = $h;
 226     $self->{yaml} = $yml;
 227     } # check_yaml
 228
 229 sub check_minimum
 230 {
 231     my $self = shift;
 232     my $reqv = $self->{h}{requires}{perl};
 233     my $locs;
 234
 235     for (@_) {
 236         if (ref $_ eq "ARRAY") {
 237             $locs = { paths => $_ };
 238             }
 239         elsif (ref $_ eq "HASH") {
 240             $locs = $_;
 241             }
 242         else {
 243             $reqv = $_;
 244             }
 245         }
 246     my $paths = (join ", " => @{($locs // {})->{paths} // []}) || "default paths";
 247
 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
 255
 256 sub done_testing
 257 {
 258     Test::More::done_testing ();
 259     } # done_testing
 260
 261 sub print_yaml
 262 {
 263     my $self = shift;
 264     print @{$self->{yml}};
 265     } # print_yaml
 266
 267 sub fix_meta
 268 {
 269     my $self = shift;
 270
 271     # Convert to meta-spec version 2
 272     # licenses are lists now
 273     my $jsn = $self->{h};
 274     $jsn->{"meta-spec"} = {
 275         version => "2",
 276         url     => "https://metacpan.org/module/CPAN::Meta::Spec?#meta-spec",
 277         };
 278     exists $jsn->{resources}{license} and
 279         $jsn->{resources}{license} = [ $jsn->{resources}{license} ];
 280     delete $jsn->{distribution_type};
 281     if (exists $jsn->{license}) {
 282         $jsn->{license} =~ s/^perl$/perl_5/;
 283         $jsn->{license} = [ $jsn->{license} ];
 284         }
 285     if (exists $jsn->{resources}{repository}) {
 286         my $url = $jsn->{resources}{repository};
 287         my $web = $url;
 288         $url =~ s{repo.or.cz/w/}{repo.or.cz/r/};
 289         $web =~ s{repo.or.cz/r/}{repo.or.cz/w/};
 290         $jsn->{resources}{repository} = {
 291             type => "git",
 292             web  => $web,
 293             url  => $url,
 294             };
 295         }
 296     foreach my $sct ("", "configure_", "build_", "test_") {
 297         (my $x = $sct || "runtime") =~ s/_$//;
 298         for (qw( requires recommends suggests )) {
 299             exists $jsn->{"$sct$_"} and
 300                 $jsn->{prereqs}{$x}{$_} = delete $jsn->{"$sct$_"};
 301             }
 302         }
 303
 304     # optional features do not yet know about requires and/or recommends diirectly
 305     if (my $of = $jsn->{optional_features}) {
 306         foreach my $f (keys %$of) {
 307             if (my $r = delete $of->{$f}{requires}) {
 308                 #$jsn->{prereqs}{runtime}{recommends}{$_} //= $r->{$_} for keys %$r;
 309                 $of->{$f}{prereqs}{runtime}{requires} = $r;
 310                 }
 311             if (my $r = delete $of->{$f}{recommends}) {
 312                 #$jsn->{prereqs}{runtime}{recommends}{$_} //= $r->{$_} for keys %$r;
 313                 $of->{$f}{prereqs}{runtime}{recommends} = $r;
 314                 }
 315             }
 316         }
 317
 318     $jsn = CPAN::Meta::Converter->new ($jsn)->convert (version => "2");
 319     $jsn->{generated_by} = "Author";
 320
 321     my @my = glob <*/META.yml> or croak "No META files";
 322     my $yf = $my[0];
 323     (my $jf = $yf) =~ s/yml$/json/;
 324     open my $jh, ">", $jf or croak "Cannot update $jf\n";
 325     print   $jh JSON::PP->new->utf8 (1)->pretty (1)->encode ($jsn);
 326     close   $jh;
 327
 328     # Now that 2.0 JSON is corrrect, create a 1.4 YAML back from the modified stuff
 329     my $yml = $jsn;
 330     # 1.4 does not know about test_*, move them to *
 331     if (my $tp = delete $yml->{prereqs}{test}) {
 332         foreach my $phase (keys %{$tp}) {
 333             my $p = $tp->{$phase};
 334             #DDumper { $phase => $p };
 335             $yml->{prereqs}{runtime}{$phase}{$_} //= $p->{$_} for keys %{$p};
 336             }
 337         }
 338
 339     # Optional features in 1.4 knows requires, but not recommends.
 340     # The Lancaster Consensus moves 2.0 optional recommends promote to
 341     # requires in 1.4
 342     if (my $of = $yml->{optional_features}) {
 343         foreach my $f (keys %$of) {
 344             if (my $r = delete $of->{$f}{prereqs}{runtime}{recommends}) {
 345                 $of->{$f}{requires} = $r;
 346                 }
 347             }
 348         }
 349     # runtime and test_requires are unknown as top-level in 1.4
 350     foreach my $phase (qw( xuntime test_requires )) {
 351         if (my $p = delete $yml->{$phase}) {
 352             foreach my $f (keys %$p) {
 353                 $yml->{$f}{$_} ||= $p->{$f}{$_} for keys %{$p->{$f}};
 354                 }
 355             }
 356         }
 357
 358     #DDumper $yml;
 359     # This does NOT create a correct YAML id the source does not comply!
 360     $yml = CPAN::Meta::Converter->new ($yml)->convert (version => "1.4");
 361     $yml->{requires}{perl} //= $jsn->{prereqs}{runtime}{requires}{perl}
 362                            //  $self->{h}{requires}{perl}
 363                            //  "";
 364     $yml->{build_requires} && !keys %{$yml->{build_requires}} and
 365         delete $yml->{build_requires};
 366     #DDumper $yml;
 367     #exit;
 368
 369     @my == 1 && open my $my, ">", $yf or croak "Cannot update $yf\n";
 370     print $my Dump $yml; # @{$self->{yml}};
 371     close $my;
 372
 373     chmod 0644, glob "*/META.*";
 374     unlink glob "MYMETA*";
 375     } # fix_meta
 376
 377 1;