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