sandbox/genMETA.pm

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