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