sandbox/genMETA.pm

   1 #!/pro/bin/perl
   2
   3 package genMETA;
   4
   5 our $VERSION = "1.03-20110907";
   6
   7 use strict;
   8 use warnings;
   9 use Carp;
  10
  11 use List::Util qw( first );
  12 use Encode qw( encode decode );
  13 use Test::CPAN::Meta::YAML::Version;
  14 use CPAN::Meta::Converter;
  15 use Test::MinimumVersion;
  16 use Test::More ();
  17 use Parse::CPAN::Meta;
  18 use File::Find;
  19 use YAML::Syck;
  20 use Data::Peek;
  21 use Text::Diff;
  22 use JSON::PP;
  23
  24 sub new
  25 {
  26     my $package = shift;
  27     return bless { @_ }, $package;
  28     } # new
  29
  30 sub version_from
  31 {
  32     my ($self, $src) = @_;
  33
  34     $self->{mfpr} = {};
  35     if (open my $mh, "<", "Makefile.PL") {
  36         my $mf = do { local $/; <$mh> };
  37
  38         if ($mf =~ m{\b NAME         \s*=>\s* ["'] (\S+) ['"]}x) {
  39             $self->{name} = $1;
  40             $self->{name} =~ m/-/ and
  41                 warn "NAME in Makefile.PL contains a -\n";
  42             $self->{name} =~ s/::/-/g;
  43             }
  44         if ($mf =~ m{\b DISTNAME     \s*=>\s* ["'] (\S+) ['"]}x) {
  45             $self->{name} = $1;
  46             }
  47
  48         if ($mf =~ m{\b VERSION_FROM \s*=>\s* ["'] (\S+) ['"]}x) {
  49             my $from = $1;
  50             -f $from or die "Makefile wants version from nonexisten $from\n";
  51             $self->{from} //= $from;
  52             $from eq $self->{from} or die "VERSION_FROM mismatch Makefile.PL / YAML\n";
  53             }
  54
  55         if ($mf =~ m[\b PREREQ_PM    \s*=>\s* \{ ( [^}]+ ) \}]x) {
  56             my @pr = split m/\n/ => $1;
  57             $self->{mfpr} = { map { (m{ \b ["']? (\S+?) ['"]? \s*=>\s* ["']? ([-0-9._]+) ['"]? }x) } grep !m/^\s*#/ => @pr };
  58             }
  59         }
  60
  61     $src //= $self->{from} or croak "No file to extract version from";
  62
  63     my $version;
  64     open my $pm, "<", $src or croak "Cannot read $src";
  65     while (<$pm>) {
  66         m/^(?:our\s+)? \$VERSION \s*=\s* ["']? ([-0-9._]+) ['"]? \s*;\s*$/x or next;
  67         $version = $1;
  68         last;
  69         }
  70     close $pm;
  71     $version or croak "Cannot extract VERSION from $src\n";
  72     $self->{version} = $version;
  73     return $version
  74     } # version_from
  75
  76 sub from_data
  77 {
  78     my ($self, @data) = @_;
  79     $self->{version} or $self->version_from ();
  80     s/VERSION/$self->{version}/g for @data;
  81     $self->{yml} = \@data;
  82     $self->check_yaml ();
  83     return @data;
  84     } # from_data
  85
  86 sub check_encoding
  87 {
  88     my $self = shift;
  89     my @tf   = grep m{^(?: change | readme | .*\.pod )}ix => glob "*";
  90     (my $tf = join ", " => @tf) =~ s/.*\K, / and /;
  91
  92     print "Check if $tf are still valid UTF8 ...\n";
  93     foreach my $tf (@tf) {
  94         open my $fh, "<", $tf or croak "$tf: $!\n";
  95         my @c = <$fh>;
  96         my $c = join "" => @c;
  97         my @e;
  98         my $s = decode ("utf-8", $c, sub { push @e, shift; });
  99         if (@e) {
 100             my @l;
 101             my $n = 0;
 102             for (@c) {
 103                 $n++;
 104                 eval { decode ("utf-8", $_, 1) };
 105                 $@ or next;
 106                 $@ =~ s{ at /\S+ line \d+.*}{};
 107                 print "$tf:$n\t$_\t$@";
 108                 }
 109             croak "$tf is not valid UTF-8\n";
 110             }
 111         my $u = encode ("utf-8", $s);
 112         $c eq $u and next;
 113
 114         my $n;
 115         $n = 1; $c =~ s/^/$n++ . "\t"/gem;
 116         $n = 1; $u =~ s/^/$n++ . "\t"/gem;
 117         croak "$tf: recode makes content differ\n". diff \$c, \$u;
 118         }
 119     } # check_encoding
 120
 121 sub check_required
 122 {
 123     my $self = shift;
 124
 125     my $yml = $self->{h} or croak "No YAML to check";
 126
 127     print STDERR "Check required and recommended module versions ...\n";
 128     BEGIN { $V::NO_EXIT = $V::NO_EXIT = 1 } require V;
 129     my %req = map { %{$yml->{$_}} } grep m/requires/   => keys %{$yml};
 130     my %rec = map { %{$yml->{$_}} } grep m/recommends/ => keys %{$yml};
 131     if (my $of = $yml->{optional_features}) {
 132         foreach my $f (values %{$of}) {
 133             my %q = map { %{$f->{$_}} } grep m/requires/   => keys %{$f};
 134             my %c = map { %{$f->{$_}} } grep m/recommends/ => keys %{$f};
 135             @req{keys %q} = values %q;
 136             @rec{keys %c} = values %c;
 137             }
 138         }
 139     my %vsn = ( %req, %rec );
 140     delete @vsn{qw( perl version )};
 141     for (sort keys %vsn) {
 142         if (my $mfv = delete $self->{mfpr}{$_}) {
 143             $req{$_} eq $mfv or
 144                 die "PREREQ mismatch for $_ Makefile.PL ($mfv) / YAML ($req{$_})\n";
 145             }
 146         $vsn{$_} eq "0" and next;
 147         my $v = V::get_version ($_);
 148         $v eq $vsn{$_} and next;
 149         printf STDERR "%-35s %-6s => %s\n", $_, $vsn{$_}, $v;
 150         }
 151     if (my @mfpr = sort keys %{$self->{mfpr}}) {
 152         die "Makefile.PL requires @mfpr, YAML does not\n";
 153         }
 154
 155     find (sub {
 156         $File::Find::dir  =~ m{^blib\b}                 and return;
 157         $File::Find::name =~ m{(?:^|/)Bundle/.*\.pm}    or  return;
 158         if (open my $bh, "<", $_) {
 159             print STDERR "Check bundle module versions $File::Find::name ...\n";
 160             while (<$bh>) {
 161                 my ($m, $dv) = m/^([A-Za-z_:]+)\s+([0-9.]+)\s*$/ or next;
 162                 my $v = $m eq $self->{name} ? $self->{version} : V::get_version ($m);
 163                 $v eq $dv and next;
 164                 printf STDERR "%-35s %-6s => %s\n", $m, $dv, $v;
 165                 }
 166             }
 167         }, glob "*");
 168
 169     if (ref $self->{h}{provides}) {
 170         print "Check distribution module versions ...\n";
 171         foreach my $m (sort keys %{$self->{h}{provides}}) {
 172             $m eq $self->{name} and next;
 173             my $ev = $self->{h}{provides}{$m}{version};
 174             printf "  Expect %5s for %-32s ", $ev, $m;
 175             my $fn = $self->{h}{provides}{$m}{file};
 176             if (open my $fh, "<", $fn) {
 177                 my $fv;
 178                 while (<$fh>) {
 179                     m/\bVERSION\s*=\s*["']?([-0-9.]+)/ or next;
 180                     $fv = $1;
 181                     print $fv eq $ev ? "ok\n" : " mismatch, module has $1\n";
 182                     last;
 183                     }
 184                 defined $fv or print " .. no version defined\n";
 185                 }
 186             else {
 187                 print " .. cannot open $fn: $!\n";
 188                 }
 189             }
 190         }
 191     } # check_required
 192
 193 sub check_yaml
 194 {
 195     my $self = shift;
 196
 197     my @yml = @{$self->{yml}} or croak "No YAML to check";
 198
 199     print STDERR "Checking generated YAML ...\n";
 200     my $h;
 201     my $yml = join "", @yml;
 202     eval { $h = Load ($yml) };
 203     $@ and croak "$@\n";
 204     $self->{name} //= $h->{name};
 205     $self->{name} eq  $h->{name} or die "NAME mismatch Makefile.PL / YAML\n";
 206     $self->{name} =~ s/-/::/g;
 207     print STDERR "Checking for $self->{name}-$self->{version}\n";
 208
 209     $self->{verbose} and print Dump $h;
 210
 211     my $t = Test::CPAN::Meta::YAML::Version->new (data => $h);
 212     $t->parse () and
 213         croak join "\n", "Test::CPAN::Meta::YAML reported failure:", $t->errors, "";
 214
 215     eval { Parse::CPAN::Meta::Load ($yml) };
 216     $@ and croak "$@\n";
 217
 218     $self->{h}    = $h;
 219     $self->{yaml} = $yml;
 220     } # check_yaml
 221
 222 sub check_minimum
 223 {
 224     my $self = shift;
 225     my $reqv = $self->{h}{requires}{perl};
 226     my $locs;
 227
 228     for (@_) {
 229         if (ref $_ eq "ARRAY") {
 230             $locs = { paths => $_ };
 231             }
 232         elsif (ref $_ eq "HASH") {
 233             $locs = $_;
 234             }
 235         else {
 236             $reqv = $_;
 237             }
 238         }
 239     my $paths = (join ", " => @{($locs // {})->{paths} // []}) || "default paths";
 240
 241     $reqv or croak "No minimal required version for perl";
 242     print "Checking if $reqv is still OK as minimal version for $paths\n";
 243     # All other minimum version checks done in xt
 244     Test::More::subtest "Minimum perl version $reqv" => sub {
 245         all_minimum_version_ok ($reqv, $locs);
 246         };
 247     } # check_minimum
 248
 249 sub print_yaml
 250 {
 251     my $self = shift;
 252     print @{$self->{yml}};
 253     } # print_yaml
 254
 255 sub fix_meta
 256 {
 257     my $self = shift;
 258
 259     # Convert to meta-spec version 2
 260     # licenses are lists now
 261     my $jsn = $self->{h};
 262     $jsn->{"meta-spec"} = {
 263         version => "2",
 264         url     => "https://metacpan.org/module/CPAN::Meta::Spec?#meta-spec",
 265         };
 266     exists $jsn->{resources}{license} and
 267         $jsn->{resources}{license} = [ $jsn->{resources}{license} ];
 268     delete $jsn->{distribution_type};
 269     if (exists $jsn->{license}) {
 270         $jsn->{license} =~ s/^perl$/perl_5/;
 271         $jsn->{license} = [ $jsn->{license} ];
 272         }
 273     if (exists $jsn->{resources}{repository}) {
 274         my $url = $jsn->{resources}{repository};
 275         my $web = $url;
 276         $url =~ s{repo.or.cz/w/}{repo.or.cz/r/};
 277         $web =~ s{repo.or.cz/r/}{repo.or.cz/w/};
 278         $jsn->{resources}{repository} = {
 279             type => "git",
 280             web  => $web,
 281             url  => $url,
 282             };
 283         }
 284     foreach my $sct ("", "configure_", "build_", "test_") {
 285         (my $x = $sct || "runtime") =~ s/_$//;
 286         for (qw( requires recommends suggests )) {
 287             exists $jsn->{"$sct$_"} and
 288                 $jsn->{prereqs}{$x}{$_} = delete $jsn->{"$sct$_"};
 289             }
 290         }
 291     $jsn = CPAN::Meta::Converter->new ($jsn)->convert (version => "2");
 292     $jsn->{generated_by} = "Author";
 293
 294     my $yml = $jsn;
 295     # 1.4 does not know about test_*, move them to *
 296     if (my $tp = delete $yml->{prereqs}{test}) {
 297         DDumper $tp;
 298         foreach my $phase (keys %{$tp}) {
 299             my $p = $tp->{$phase};
 300             $yml->{runtime}{$phase}{$_} //= $p->{$_} for keys %{$p};
 301             }
 302         }
 303     #DDumper $yml;
 304     $yml = CPAN::Meta::Converter->new ($yml)->convert (version => "1.4");
 305
 306     my @my = glob <*/META.yml> or croak "No META files";
 307     my $yf = $my[0];
 308     @my == 1 && open my $my, ">", $yf or croak "Cannot update $yf\n";
 309     print $my Dump $yml; # @{$self->{yml}};
 310     close $my;
 311
 312     $yf =~ s/yml$/json/;
 313     open $my, ">", $yf or croak "Cannot update $yf\n";
 314     #rint     JSON::PP->new->utf8 (1)->pretty (1)->encode ($jsn);
 315     print $my JSON::PP->new->utf8 (1)->pretty (1)->encode ($jsn);
 316     close $my;
 317
 318     chmod 0644, glob "*/META.*";
 319     unlink glob "MYMETA*";
 320     } # fix_meta
 321
 322 1;