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