perl/Porting/makemeta

#!./perl -w
# this script must be run by the current perl to get perl's version right
#
# Create META.yml and META.json files in the current directory. Must be run from the
# root directory of a perl source tree.

use strict;
use warnings;
use Getopt::Std;

# avoid unnecessary churn in x_serialization_backend in META.*
$ENV{PERL_JSON_BACKEND} = $ENV{CPAN_META_JSON_BACKEND} = 'JSON::PP';
$ENV{PERL_YAML_BACKEND} = 'CPAN::Meta::YAML';

my $opts = {
  'META.yml'  => { version => '1.4' },
  'META.json' => { version => '2' },
};

my %switches;
getopts('nbyj', \%switches);

=head1 SYNOPSIS

  ./perl -Ilib Porting/makemeta

=head1 OPTIONS

=item B<-y>

Update only META.yml

The default is to update both, META.yml and META.json

=item B<-n>

Don't update any files, exit with 1 if changes would be made

=item B<-b>

No-op, kept for historical purposes

=cut

my @metafiles;
if ( $switches{y} ) {
  push @metafiles, 'META.yml';
}
elsif ( $switches{j} ) {
  push @metafiles, 'META.json';
}
else {
  push @metafiles, keys %$opts;
}

my ($vers, $stat ) = _determine_status();

my $distmeta = {
  'version' => $vers,
  'name' => 'perl',
  'author' => [
    'perl5-porters@perl.org'
  ],
  'license' => [
    'perl_5'
  ],
  'abstract' => 'The Perl 5 language interpreter',
  'release_status' => $stat,
  'dynamic_config' => 1,
  'resources' => {
    'repository' => {
      'url' => 'https://github.com/Perl/perl5'
    },
    'homepage' => 'https://www.perl.org/',
    'bugtracker' => {
      'web' => 'https://github.com/Perl/perl5/issues'
    },
    'license' => [
      'https://dev.perl.org/licenses/'
    ],
  },
};

use lib "Porting";
use File::Basename qw( dirname );
use CPAN::Meta;
use File::Spec;

BEGIN {
    # Get function prototypes
    require './regen/regen_lib.pl';
}

use Maintainers qw(%Modules get_module_files get_module_pat);

my @CPAN  = grep { $Modules{$_}{CPAN} } keys %Modules;
my @files = ('autodoc.pl', 'lib/unicore/mktables', 'TestInit.pm',
             'Porting/Maintainers.pm', 'Porting/perldelta_template.pod',
             map { get_module_files($_) } @CPAN);
my @extt = map { my $t = File::Spec->catdir($_, "t");
                 -d $t ? ( $_ . "t" ) : () }
  grep { /^ext\b/ } split ' ', $Modules{_PERLLIB}{FILES};
my @dirs  = ('cpan', 'win32', 'lib/perl5db', @extt, grep { -d $_ && $_  !~ /^cpan/ } map { get_module_pat($_) } @CPAN);

my %dirs;
@dirs{@dirs} = ();

@files =
  grep {
    my $d = $_;
    my $previous_d = '';
    while(($d = dirname($d)) ne "."){
      last if $d eq $previous_d; # safety valve
      last if exists $dirs{$d};
      $previous_d = $d;
    }

    # if $d is "." it means we tried every parent dir of the file and none
    # of them were in the private list

    $d eq "." || $d eq $previous_d;
  }
  sort { lc $a cmp lc $b } @files;

@dirs  = sort { lc $a cmp lc $b } @dirs;

$distmeta->{no_index}->{file} = \@files;
$distmeta->{no_index}->{directory} = \@dirs;

my $meta = CPAN::Meta->create( $distmeta );
foreach my $file ( @metafiles ) {
  my $new = $meta->as_string( $opts->{$file} );
  if( $switches{n} ) {
    open my $fh, '<:raw', $file;
    local $/;
    my $old = <$fh>;
    if( $old ne $new ) {
      exit 1;
    }
  } else {
    my $fh = open_new($file);
    print $fh $new;
    close_and_rename($fh);
  }
}
exit 0;

sub _determine_status {
  my $patchlevel_h = 'patchlevel.h';
  return unless -e $patchlevel_h;
  my $status = '';
  my $version = '';
  {
    my %defines;
    open my $fh, '<', $patchlevel_h;
    my @vers;
    while (<$fh>) {
      chomp;
      next unless m!^#define! or m!!;
      if ( m!^#define! ) {
        my ($foo,$bar) = ( split /\s+/ )[1,2];
        $defines{$foo} = $bar;
      }
      elsif ( m!\"RC\d+\"! ) {
        $status = 'testing';
        last;
      }
    }
    unless ( $status ) {
      $status = $defines{PERL_VERSION} % 2 ? 'unstable' : 'stable';
    }
    if ( my @wotsits = grep { defined $defines{$_} } qw(PERL_REVISION PERL_VERSION PERL_SUBVERSION) ) {
      $version = sprintf '%d.%03d%03d', map { $defines{$_} } @wotsits;
    }
    else {
      # Well, you never know
      $version = sprintf '5.%03d_%02d', map { $defines{$_} } qw(PATCHLEVEL SUBVERSION);
    }
  }
  return ( $version, $status );
}