This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
A test to check that regen.pl doesn't need running.
[perl5.git] / regen_lib.pl
1 #!/usr/bin/perl -w
2 use strict;
3 use vars qw($Needs_Write $Verbose @Changed $TAP);
4 use File::Compare;
5 use Symbol;
6
7 # Common functions needed by the regen scripts
8
9 $Needs_Write = $^O eq 'cygwin' || $^O eq 'os2' || $^O eq 'MSWin32';
10
11 $Verbose = 0;
12 @ARGV = grep { not($_ eq '-q' and $Verbose = -1) }
13   grep { not($_ eq '--tap' and $TAP = 1) }
14   grep { not($_ eq '-v' and $Verbose = 1) } @ARGV;
15
16 END {
17   print STDOUT "Changed: @Changed\n" if @Changed;
18 }
19
20 sub safer_unlink {
21   my @names = @_;
22   my $cnt = 0;
23
24   my $name;
25   foreach $name (@names) {
26     next unless -e $name;
27     chmod 0777, $name if $Needs_Write;
28     ( CORE::unlink($name) and ++$cnt
29       or warn "Couldn't unlink $name: $!\n" );
30   }
31   return $cnt;
32 }
33
34 sub safer_rename_silent {
35   my ($from, $to) = @_;
36
37   # Some dosish systems can't rename over an existing file:
38   safer_unlink $to;
39   chmod 0600, $from if $Needs_Write;
40   rename $from, $to;
41 }
42
43 sub rename_if_different {
44   my ($from, $to) = @_;
45
46   if ($TAP) {
47       my $not = compare($from, $to) ? 'not ' : '';
48       print STDOUT $not . "ok - $0 $to\n";
49       safer_unlink($from);
50       return;
51   }
52   if (compare($from, $to) == 0) {
53       warn "no changes between '$from' & '$to'\n" if $Verbose > 0;
54       safer_unlink($from);
55       return;
56   }
57   warn "changed '$from' to '$to'\n" if $Verbose > 0;
58   push @Changed, $to unless $Verbose < 0;
59   safer_rename_silent($from, $to) or die "renaming $from to $to: $!";
60 }
61
62 # Saf*er*, but not totally safe. And assumes always open for output.
63 sub safer_open {
64     my $name = shift;
65     my $fh = gensym;
66     open $fh, ">$name" or die "Can't create $name: $!";
67     *{$fh}->{SCALAR} = $name;
68     binmode $fh;
69     $fh;
70 }
71
72 sub safer_close {
73     my $fh = shift;
74     close $fh or die 'Error closing ' . *{$fh}->{SCALAR} . ": $!";
75 }
76
77 1;