Porting/makemeta

   1 #!./perl -w
   2 # this script must be run by the current perl to get perl's version right
   3 #
   4 # Create META.yml and META.json files in the current directory. Must be run from the
   5 # root directory of a perl source tree.
   6
   7 use strict;
   8 use warnings;
   9
  10 my $opts = {
  11   'META.yml'  => { version => '1.4' },
  12   'META.json' => { version => '2' },
  13 };
  14
  15 my $file = shift;
  16 die "Must specify META.yml or META.json" unless $file and defined $opts->{$file};
  17
  18 my $status = _determine_status();
  19
  20 my $distmeta = {
  21   'version' => $],
  22   'name' => 'perl',
  23   'author' => [
  24     'perl5-porters@perl.org'
  25   ],
  26   'license' => [
  27     'perl_5'
  28   ],
  29   'abstract' => 'The Perl 5 language interpreter',
  30   'release_status' => $status,
  31   'dynamic_config' => 1,
  32   'resources' => {
  33     'repository' => {
  34       'url' => 'http://perl5.git.perl.org/'
  35     },
  36     'homepage' => 'http://www.perl.org/',
  37     'bugtracker' => {
  38       'web' => 'http://rt.perl.org/perlbug/'
  39     },
  40     'license' => [
  41       'http://dev.perl.org/licenses/'
  42     ],
  43   },
  44 };
  45
  46 use lib "Porting";
  47 use File::Basename qw( dirname );
  48 use CPAN::Meta;
  49
  50 BEGIN {
  51     # Get function prototypes
  52     require 'regen/regen_lib.pl';
  53 }
  54
  55 use Maintainers qw(%Modules get_module_files get_module_pat);
  56
  57 my @CPAN  = grep { $Modules{$_}{CPAN} } keys %Modules;
  58 my @files = ('autodoc.pl', 'lib/unicore/mktables', 'TestInit.pm',
  59              'Porting/Maintainers.pm', 'Porting/perldelta_template.pod',
  60              map { get_module_files($_) } @CPAN);
  61 my @dirs  = ('cpan', 'win32', 'mad', grep { -d $_ && $_  !~ /^cpan/ } map { get_module_pat($_) } @CPAN);
  62
  63 my %dirs;
  64 @dirs{@dirs} = ();
  65
  66 @files =
  67   grep {
  68     my $d = $_;
  69     my $previous_d = '';
  70     while(($d = dirname($d)) ne "."){
  71       last if $d eq $previous_d; # safety valve
  72       last if exists $dirs{$d};
  73       $previous_d = $d;
  74     }
  75
  76     # if $d is "." it means we tried every parent dir of the file and none
  77     # of them were in the private list
  78
  79     $d eq "." || $d eq $previous_d;
  80   }
  81   sort { lc $a cmp lc $b } @files;
  82
  83 @dirs  = sort { lc $a cmp lc $b } @dirs;
  84
  85 $distmeta->{no_index}->{file} = \@files;
  86 $distmeta->{no_index}->{directory} = \@dirs;
  87
  88 my $meta = CPAN::Meta->create( $distmeta );
  89 my $fh = open_new($file);
  90 print $fh $meta->as_string( $opts->{$file} );
  91 close_and_rename($fh);
  92 exit 0;
  93
  94 sub _determine_status {
  95   my $patchlevel_h = 'patchlevel.h';
  96   return unless -e $patchlevel_h;
  97   my $status = '';
  98   {
  99     my %defines;
 100     open my $fh, '<', $patchlevel_h;
 101     my @vers;
 102     while (<$fh>) {
 103       chomp;
 104       next unless m!^#define! or m!!;
 105       if ( m!^#define! ) {
 106         my ($foo,$bar) = ( split /\s+/ )[1,2];
 107         $defines{$foo} = $bar;
 108       }
 109       elsif ( m!\"RC\d+\"! ) {
 110         $status = 'testing';
 111         last;
 112       }
 113     }
 114     unless ( $status ) {
 115       $status = $defines{PERL_VERSION} % 2 ? 'unstable' : 'stable';
 116     }
 117   }
 118   return $status;
 119 }