src/update.pl

   1 #!perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Getopt::Std;
   7
   8 use File::Path;
   9 use File::Copy;
  10 use File::Spec;
  11
  12 use Time::HiRes;
  13
  14 use Module::CoreList;
  15 use version;
  16
  17 use File::Fetch;
  18 use Archive::Extract;
  19
  20 my $has_cpan_perl_releases;
  21 BEGIN {
  22  local $@;
  23  if (eval { require CPAN::Perl::Releases; 1 }) {
  24   print "Will use CPAN::Perl::Releases\n";
  25   $has_cpan_perl_releases = 1;
  26  }
  27 }
  28
  29 my %opts;
  30 getopts('ft:m:', \%opts);
  31
  32 my $cpan_mirror = 'cpan.cpantesters.org';
  33 my $target      = 'src';
  34
  35 {
  36  local $@;
  37  eval 'setpgrp 0, 0';
  38 }
  39 local $SIG{'INT'} = sub { exit 1 };
  40
  41 {
  42  package Guard::Path;
  43
  44  sub new {
  45   my $class = shift;
  46
  47   my %args = @_;
  48   my ($path, $indent, $keep) = @args{qw<path indent keep>};
  49
  50   die "Path $path already exists" if -e $path;
  51   File::Path::mkpath($path);
  52
  53   bless {
  54    path   => $path,
  55    indent => $indent || 0,
  56    keep   => $keep,
  57   }, $class;
  58  }
  59
  60  BEGIN {
  61   local $@;
  62   eval "sub $_ { \$_[0]->{$_} }; 1" or die $@ for qw<path indent>;
  63  }
  64
  65  sub keep { @_ > 1 ? $_[0]->{keep} = $_[1] : $_[0]->{keep} }
  66
  67  sub DESTROY {
  68   my $self = shift;
  69
  70   return if $self->keep;
  71
  72   my $path = $self->path;
  73   return unless -e $path;
  74
  75   my $indent = $self->indent;
  76   $indent = ' ' x (2 * $indent);
  77
  78   print "${indent}Cleaning up path $path... ";
  79   File::Path::remove_tree($path);
  80   print "done\n";
  81  }
  82 }
  83
  84 sub key_version {
  85  my $v = shift;
  86
  87  my $obj     = version->parse($v);
  88  my $version = $obj->normal;
  89  $version =~ s/^v?//;
  90
  91  my ($int, $frac) = split /\./, $v, 2;
  92
  93  die 'Wrong fractional part' if length $frac > 6;
  94  $frac .= '0' x (6 - length $frac);
  95
  96  "$int$frac" => $version;
  97 }
  98
  99 my %perls = map key_version($_),
 100              grep "$_" >= '5.010001',
 101               keys %Module::CoreList::released;
 102
 103 sub fetch_uri {
 104  my ($uri, $to) = @_;
 105
 106  my $start = [ Time::HiRes::gettimeofday ];
 107
 108  my $ff   = File::Fetch->new(uri => $uri);
 109  my $file = $ff->fetch(to => $to) or die "Could not fetch $uri: " . $ff->error;
 110
 111  my $elapsed = Time::HiRes::tv_interval($start);
 112
 113  return $file, $elapsed;
 114 }
 115
 116 sub perl_archive_for {
 117  my $version = shift;
 118
 119  my $path;
 120
 121  if ($has_cpan_perl_releases) {
 122   my $tarballs = CPAN::Perl::Releases::perl_tarballs($version);
 123
 124   if (defined $tarballs) {
 125    $path = $tarballs->{'tar.gz'};
 126   }
 127  } else {
 128   my $uri = "http://search.cpan.org/dist/perl-$version";
 129
 130   local $_;
 131   fetch_uri($uri => \$_);
 132
 133   if (m{id/(([^/])/\2([^/])/\2\3[^/]*/perl-\Q$version\E\.tar\.(?:gz|bz2))}) {
 134    $path = $1;
 135   }
 136  }
 137
 138  if (defined $path) {
 139   my ($file) = ($path =~ m{([^/]*)$});
 140   return "http://$cpan_mirror/authors/id/$path", $file;
 141  } else {
 142   die "Could not infer the archive for perl $version";
 143  }
 144 }
 145
 146 sub bandwidth {
 147  my ($size, $seconds) = @_;
 148
 149  my $speed = $size / $seconds;
 150
 151  my $order = 0;
 152  while ($speed >= 1024) {
 153   $speed /= 1024;
 154   $order++;
 155  }
 156
 157  $speed = sprintf '%.02f', $speed;
 158
 159  my $unit = ('', 'K', 'M', 'G', 'T', 'P')[$order] . 'B/s';
 160
 161  return $speed, $unit;
 162 }
 163
 164 sub touch {
 165  my $file = shift;
 166
 167  open my $fh, '>', $file or die "Can't open $file for writing: $!";
 168 }
 169
 170 File::Path::mkpath($target) unless -e $target;
 171
 172 my $tmp_dir = File::Spec->catdir($target, 'tmp');
 173
 174 sub fetch_source_file {
 175  my ($file, $version, $dir) = @_;
 176
 177  my $INDENT = ' ' x 4;
 178
 179  print "${INDENT}Looking for the full name of the perl archive... ";
 180  my ($archive_uri, $archive_file) = perl_archive_for($version);
 181  print "$archive_uri\n";
 182
 183  if (-e File::Spec->catfile($tmp_dir, $archive_file)) {
 184   print "${INDENT}$archive_file was already fetched\n";
 185  } else {
 186   print "${INDENT}Fetching $archive_uri... ";
 187   ($archive_file, my $elapsed) = fetch_uri($archive_uri => $tmp_dir);
 188   my ($speed, $unit) = bandwidth(-s $archive_file, $elapsed);
 189   print "done at $speed$unit\n";
 190  }
 191
 192  my $extract_path = File::Spec->catfile($tmp_dir, "perl-$version");
 193  if (-e $extract_path) {
 194   print "${INDENT}$archive_file was already extracted\n";
 195  } else {
 196   print "${INDENT}Extracting $archive_file... ";
 197   my $ae = Archive::Extract->new(archive => $archive_file);
 198   $ae->extract(to => $tmp_dir)
 199                         or die "Could not extract $archive_file: " . $ae->error;
 200   $extract_path = $ae->extract_path;
 201   print "done\n";
 202  }
 203
 204  File::Path::mkpath($dir) unless -e $dir;
 205  print "${INDENT}Copying $file to $dir... ";
 206  my $src = File::Spec->catfile($extract_path, $file);
 207  my $dst = File::Spec->catfile($dir,          $file);
 208  if (-e $src) {
 209   File::Copy::copy($src => $dst) or die "Can't copy $src to $dst: $!";
 210   print "done\n";
 211   return 1;
 212  } else {
 213   touch($dst);
 214   print "not needed\n";
 215   return 0;
 216  }
 217 }
 218
 219 my %patched_chunks;
 220 my %expected_chunks = (
 221  'regcomp.c' => [
 222   're_defs',
 223   'COMP_NODE_HOOK',
 224   'COMP_BEGIN_HOOK',
 225   ('COMP_NODE_HOOK') x 3,
 226  ],
 227  'regexec.c' => [
 228   're_defs',
 229   'EXEC_NODE_HOOK',
 230  ],
 231 );
 232
 233 sub patch_regcomp {
 234  my ($line, $file) = @_;
 235
 236  if ($line =~ /#\s*include\s+"INTERN\.h"/) {
 237   push @{$patched_chunks{$file}}, 're_defs';
 238   return "#include \"re_defs.h\"\n";
 239  } elsif ($line =~ /^(\s*)RExC_rxi\s*=\s*ri\s*;\s*$/) {
 240   push @{$patched_chunks{$file}}, 'COMP_BEGIN_HOOK';
 241   return $line, "$1REH_CALL_COMP_BEGIN_HOOK(pRExC_state->rx);\n";
 242  } elsif ($line =~ /FILL_ADVANCE_NODE(_ARG)?\(\s*([^\s,\)]+)/) {
 243   my $shift = $1 ? 2 : 1;
 244   push @{$patched_chunks{$file}}, 'COMP_NODE_HOOK';
 245   return $line, "    REH_CALL_COMP_NODE_HOOK(pRExC_state->rx, ($2) - $shift);\n"
 246  } elsif ($line =~ /end node insert/) {
 247   push @{$patched_chunks{$file}}, 'COMP_NODE_HOOK';
 248   return $line, "    REH_CALL_COMP_NODE_HOOK(pRExC_state->rx, convert);\n";
 249  }
 250
 251  return $line;
 252 }
 253
 254 sub patch_regexec {
 255  my ($line, $file) = @_;
 256
 257  if ($line =~ /#\s*include\s+"perl\.h"/) {
 258   push @{$patched_chunks{$file}}, 're_defs';
 259   return $line, "#include \"re_defs.h\"\n";
 260  } elsif ($line =~ /^\s*reenter_switch:\s*$/) {
 261   push @{$patched_chunks{$file}}, 'EXEC_NODE_HOOK';
 262   return "\tREH_CALL_EXEC_NODE_HOOK(rex, scan, reginfo, st);\n", $line;
 263  }
 264
 265  return $line;
 266 }
 267
 268 my %manglers = (
 269  'regcomp.c' => \&patch_regcomp,
 270  'regexec.c' => \&patch_regexec,
 271 );
 272
 273 sub patch_source_file {
 274  my ($src, $dst) = @_;
 275
 276  my $file = (File::Spec->splitpath($src))[2];
 277  if (-d $dst) {
 278   $dst = File::Spec->catfile($dst, $file);
 279  }
 280
 281  my $mangler = $manglers{$file};
 282  unless ($mangler) {
 283   File::Copy::copy($src => $dst) or die "Can't copy $src to $dst: $!";
 284   return 0;
 285  }
 286
 287  open my $in,  '<', $src or die "Can't open $src for reading: $!";
 288  open my $out, '>', $dst or die "Can't open $dst for writing: $!";
 289
 290  while (defined(my $line = <$in>)) {
 291   print $out $mangler->($line, $dst);
 292  }
 293
 294  my $patched_chunks  = join ' ', @{$patched_chunks{$dst}};
 295  my $expected_chunks = join ' ', @{$expected_chunks{$file}};
 296  unless ($patched_chunks eq $expected_chunks) {
 297   die "File $dst was not properly patched (got \"$patched_chunks\", expected \"$expected_chunks\")\n";
 298  }
 299
 300  return 1;
 301 }
 302
 303 for my $tag (sort { $a <=> $b } keys %perls) {
 304  my $version = $perls{$tag};
 305
 306  my $dir = File::Spec->catdir($target, $tag);
 307
 308  print "Working on perl $version\n";
 309
 310  my $tmp_guard = Guard::Path->new(path => $tmp_dir);
 311
 312  my $orig_dir = File::Spec->catdir($dir, 'orig');
 313  my @files    = qw<regcomp.c regexec.c dquote_static.c>;
 314  for my $file (@files) {
 315   my $orig_file = File::Spec->catfile($orig_dir, $file);
 316   if (-e $orig_file) {
 317    print "  Already have original $file\n";
 318   } else {
 319    print "  Need to get original $file\n";
 320    fetch_source_file($file, $version => $orig_dir);
 321   }
 322
 323   if (-s $orig_file) {
 324    if (not $opts{f} and -e File::Spec->catfile($dir, $file)) {
 325     print "  Already have patched $file\n";
 326    } else {
 327     print "  Need to patch $file... ";
 328     my $res = patch_source_file($orig_file => $dir);
 329     print $res ? "done\n" : "nothing to do\n";
 330    }
 331   }
 332  }
 333 }
 334
 335 {
 336  print 'Updating MANIFEST... ';
 337
 338  my @manifest_files;
 339  if (-e 'MANIFEST') {
 340   open my $in, '<', 'MANIFEST' or die "Can't open MANIFEST for reading: $!";
 341   @manifest_files = grep !m{^src/.*\.c$}, <$in>;
 342  }
 343
 344  my @source_files = map "$_\n", glob 'src/*/*.c';
 345
 346  open my $out, '>', 'MANIFEST' or die "Can't open MANIFEST for writing: $!";
 347  print $out sort @manifest_files, @source_files;
 348
 349  print "done\n";
 350 }