src/update.pl

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