Mercurial > repo
comparison perl-5.22.2/regen/regen_lib.pl @ 8045:a16537d2fe07
<xfix> tar xf perl-5.22.2.tar.gz # Ah, whatever, I\'m doing it anyway
author | HackBot |
---|---|
date | Sat, 14 May 2016 14:54:38 +0000 |
parents | |
children |
comparison
equal
deleted
inserted
replaced
8044:711c038a7dce | 8045:a16537d2fe07 |
---|---|
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 use Text::Wrap(); | |
7 | |
8 # Common functions needed by the regen scripts | |
9 | |
10 $Needs_Write = $^O eq 'cygwin' || $^O eq 'os2' || $^O eq 'MSWin32'; | |
11 | |
12 $Verbose = 0; | |
13 @ARGV = grep { not($_ eq '-q' and $Verbose = -1) } | |
14 grep { not($_ eq '--tap' and $TAP = 1) } | |
15 grep { not($_ eq '-v' and $Verbose = 1) } @ARGV; | |
16 | |
17 END { | |
18 print STDOUT "Changed: @Changed\n" if @Changed; | |
19 } | |
20 | |
21 sub safer_unlink { | |
22 my @names = @_; | |
23 my $cnt = 0; | |
24 | |
25 my $name; | |
26 foreach $name (@names) { | |
27 next unless -e $name; | |
28 chmod 0777, $name if $Needs_Write; | |
29 ( CORE::unlink($name) and ++$cnt | |
30 or warn "Couldn't unlink $name: $!\n" ); | |
31 } | |
32 return $cnt; | |
33 } | |
34 | |
35 # Open a new file. | |
36 sub open_new { | |
37 my ($final_name, $mode, $header, $force) = @_; | |
38 my $name = $final_name . '-new'; | |
39 my $lang = $final_name =~ /\.pod$/ ? 'Pod' : | |
40 $final_name =~ /\.(?:c|h|tab|act)$/ ? 'C' : 'Perl'; | |
41 if ($force && -e $final_name) { | |
42 chmod 0777, $name if $Needs_Write; | |
43 CORE::unlink $final_name | |
44 or die "Couldn't unlink $final_name: $!\n"; | |
45 } | |
46 my $fh = gensym; | |
47 if (!defined $mode or $mode eq '>') { | |
48 if (-f $name) { | |
49 unlink $name or die "$name exists but can't unlink: $!"; | |
50 } | |
51 open $fh, ">$name" or die "Can't create $name: $!"; | |
52 } elsif ($mode eq '>>') { | |
53 open $fh, ">>$name" or die "Can't append to $name: $!"; | |
54 } else { | |
55 die "Unhandled open mode '$mode'"; | |
56 } | |
57 @{*$fh}{qw(name final_name lang force)} | |
58 = ($name, $final_name, $lang, $force); | |
59 binmode $fh; | |
60 print {$fh} read_only_top(lang => $lang, %$header) if $header; | |
61 $fh; | |
62 } | |
63 | |
64 sub close_and_rename { | |
65 my $fh = shift; | |
66 my ($name, $final_name, $force) = @{*{$fh}}{qw(name final_name force)}; | |
67 close $fh or die "Error closing $name: $!"; | |
68 | |
69 if ($TAP) { | |
70 # Don't use compare because if there are errors it doesn't give any | |
71 # way to generate diagnostics about what went wrong. | |
72 # These files are small enough to read into memory. | |
73 local $/; | |
74 # This is the file we just closed, so it should open cleanly: | |
75 open $fh, '<', $name | |
76 or die "Can't open '$name': $!"; | |
77 my $want = <$fh>; | |
78 die "Can't read '$name': $!" | |
79 unless defined $want; | |
80 close $fh | |
81 or die "Can't close '$name': $!"; | |
82 | |
83 my $fail; | |
84 if (!open $fh, '<', $final_name) { | |
85 $fail = "Can't open '$final_name': $!"; | |
86 } else { | |
87 my $have = <$fh>; | |
88 if (!defined $have) { | |
89 $fail = "Can't read '$final_name': $!"; | |
90 close $fh; | |
91 } elsif (!close $fh) { | |
92 $fail = "Can't close '$final_name': $!"; | |
93 } elsif ($want ne $have) { | |
94 $fail = "'$name' and '$final_name' differ"; | |
95 } | |
96 } | |
97 if ($fail) { | |
98 print STDOUT "not ok - $0 $final_name\n"; | |
99 print STDERR "$fail\n"; | |
100 } else { | |
101 print STDOUT "ok - $0 $final_name\n"; | |
102 } | |
103 safer_unlink($name); | |
104 return; | |
105 } | |
106 unless ($force) { | |
107 if (compare($name, $final_name) == 0) { | |
108 warn "no changes between '$name' & '$final_name'\n" if $Verbose > 0; | |
109 safer_unlink($name); | |
110 return; | |
111 } | |
112 warn "changed '$name' to '$final_name'\n" if $Verbose > 0; | |
113 push @Changed, $final_name unless $Verbose < 0; | |
114 } | |
115 | |
116 # Some DOSish systems can't rename over an existing file: | |
117 safer_unlink $final_name; | |
118 chmod 0600, $name if $Needs_Write; | |
119 rename $name, $final_name or die "renaming $name to $final_name: $!"; | |
120 } | |
121 | |
122 my %lang_opener = (Perl => '# ', Pod => '', C => '/* '); | |
123 | |
124 sub read_only_top { | |
125 my %args = @_; | |
126 my $lang = $args{lang}; | |
127 die "Missing language argument" unless defined $lang; | |
128 die "Unknown language argument '$lang'" | |
129 unless exists $lang_opener{$lang}; | |
130 my $style = $args{style} ? " $args{style} " : ' '; | |
131 | |
132 my $raw = "-*- buffer-read-only: t -*-\n"; | |
133 | |
134 if ($args{file}) { | |
135 $raw .= "\n $args{file}\n"; | |
136 } | |
137 if ($args{copyright}) { | |
138 local $" = ', '; | |
139 $raw .= wrap(75, ' ', ' ', <<"EOM") . "\n"; | |
140 | |
141 Copyright (C) @{$args{copyright}} by\0Larry\0Wall\0and\0others | |
142 | |
143 You may distribute under the terms of either the GNU General Public | |
144 License or the Artistic License, as specified in the README file. | |
145 EOM | |
146 } | |
147 | |
148 $raw .= "!!!!!!! DO NOT EDIT THIS FILE !!!!!!!\n"; | |
149 | |
150 if ($args{by}) { | |
151 $raw .= "This file is built by $args{by}"; | |
152 if ($args{from}) { | |
153 my @from = ref $args{from} eq 'ARRAY' ? @{$args{from}} : $args{from}; | |
154 my $last = pop @from; | |
155 if (@from) { | |
156 $raw .= ' from ' . join (', ', @from) . " and $last"; | |
157 } else { | |
158 $raw .= " from $last"; | |
159 } | |
160 } | |
161 $raw .= ".\n"; | |
162 } | |
163 $raw .= "Any changes made here will be lost!\n"; | |
164 $raw .= $args{final} if $args{final}; | |
165 | |
166 my $cooked = $lang eq 'C' | |
167 ? wrap(78, '/* ', $style, $raw) . " */\n\n" | |
168 : wrap(78, $lang_opener{$lang}, $lang_opener{$lang}, $raw) . "\n"; | |
169 $cooked =~ tr/\0/ /; # Don't break Larry's name etc | |
170 $cooked =~ s/ +$//mg; # Remove all trailing spaces | |
171 $cooked =~ s! \*/\n!$args{quote}!s if $args{quote}; | |
172 return $cooked; | |
173 } | |
174 | |
175 sub read_only_bottom_close_and_rename { | |
176 my ($fh, $sources) = @_; | |
177 my ($name, $lang, $final_name) = @{*{$fh}}{qw(name lang final_name)}; | |
178 die "No final name specified at open time for $name" | |
179 unless $final_name; | |
180 | |
181 my $comment; | |
182 if ($sources) { | |
183 $comment = "Generated from:\n"; | |
184 foreach my $file (sort @$sources) { | |
185 my $digest = (-e $file) | |
186 ? digest($file) | |
187 # Use a random number that won't match the real | |
188 # digest, so will always show as out-of-date, so | |
189 # Porting tests likely will fail drawing attention | |
190 # to the problem. | |
191 : int(rand(1_000_000)); | |
192 $comment .= "$digest $file\n"; | |
193 } | |
194 } | |
195 $comment .= "ex: set ro:"; | |
196 | |
197 if (defined $lang && $lang eq 'Perl') { | |
198 $comment =~ s/^/# /mg; | |
199 } elsif (!defined $lang or $lang ne 'Pod') { | |
200 $comment =~ s/^/ * /mg; | |
201 $comment =~ s! \* !/* !; | |
202 $comment .= " */"; | |
203 } | |
204 print $fh "\n$comment\n"; | |
205 | |
206 close_and_rename($fh); | |
207 } | |
208 | |
209 sub tab { | |
210 my ($l, $t) = @_; | |
211 $t .= "\t" x ($l - (length($t) + 1) / 8); | |
212 $t; | |
213 } | |
214 | |
215 sub digest { | |
216 my $file = shift; | |
217 # Need to defer loading this, as the main regen scripts work back to 5.004, | |
218 # and likely we don't even have this module on every 5.8 install yet: | |
219 require Digest::SHA; | |
220 | |
221 local ($/, *FH); | |
222 open FH, "$file" or die "Can't open $file: $!"; | |
223 my $raw = <FH>; | |
224 close FH or die "Can't close $file: $!"; | |
225 return Digest::SHA::sha256_hex($raw); | |
226 }; | |
227 | |
228 sub wrap { | |
229 local $Text::Wrap::columns = shift; | |
230 Text::Wrap::wrap(@_); | |
231 } | |
232 | |
233 # return the perl version as defined in patchlevel.h. | |
234 # (we may be being run by another perl, so $] won't be right) | |
235 # return e.g. (5, 14, 3, "5.014003") | |
236 | |
237 sub perl_version { | |
238 my $plh = 'patchlevel.h'; | |
239 open my $fh, "<", $plh or die "can't open '$plh': $!\n"; | |
240 my ($v1,$v2,$v3); | |
241 while (<$fh>) { | |
242 $v1 = $1 if /PERL_REVISION\s+(\d+)/; | |
243 $v2 = $1 if /PERL_VERSION\s+(\d+)/; | |
244 $v3 = $1 if /PERL_SUBVERSION\s+(\d+)/; | |
245 } | |
246 die "can't locate PERL_REVISION in '$plh'" unless defined $v1; | |
247 die "can't locate PERL_VERSION in '$plh'" unless defined $v2; | |
248 die "can't locate PERL_SUBVERSION in '$plh'" unless defined $v3; | |
249 return ($v1,$v2,$v3, sprintf("%d.%03d%03d", $v1, $v2, $v3)); | |
250 } | |
251 | |
252 | |
253 1; |