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