line |
stmt |
bran |
cond |
sub |
time |
code |
1
|
|
|
|
|
|
#!/usr/bin/perl -w |
2
|
1
|
|
|
1
|
6
|
use strict; |
|
1
|
|
|
|
3
|
|
|
1
|
|
|
|
56
|
|
3
|
1
|
|
|
1
|
6
|
use vars qw($Needs_Write $Verbose @Changed $TAP); |
|
1
|
|
|
|
2
|
|
|
1
|
|
|
|
86
|
|
4
|
1
|
|
|
1
|
292
|
use File::Compare; |
|
1
|
|
|
|
1476
|
|
|
1
|
|
|
|
78
|
|
5
|
1
|
|
|
1
|
298
|
use Symbol; |
|
1
|
|
|
|
1125
|
|
|
1
|
|
|
|
85
|
|
6
|
1
|
|
|
1
|
336
|
use Text::Wrap(); |
|
1
|
|
|
|
3256
|
|
|
1
|
|
|
|
2621
|
|
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
|
1
|
50
|
|
1
|
0
|
print STDOUT "Changed: @Changed\n" if @Changed; |
19
|
|
|
|
|
|
} |
20
|
|
|
|
|
|
|
21
|
|
|
|
|
|
sub safer_unlink { |
22
|
0
|
|
|
0
|
0
|
my @names = @_; |
23
|
0
|
|
|
|
0
|
my $cnt = 0; |
24
|
|
|
|
|
|
|
25
|
0
|
|
|
|
0
|
my $name; |
26
|
0
|
|
|
|
0
|
foreach $name (@names) { |
27
|
0
|
0
|
|
|
0
|
next unless -e $name; |
28
|
0
|
0
|
|
|
0
|
chmod 0777, $name if $Needs_Write; |
29
|
0
|
0
|
0
|
|
0
|
( CORE::unlink($name) and ++$cnt |
30
|
|
|
|
|
|
or warn "Couldn't unlink $name: $!\n" ); |
31
|
|
|
|
|
|
} |
32
|
0
|
|
|
|
0
|
return $cnt; |
33
|
|
|
|
|
|
} |
34
|
|
|
|
|
|
|
35
|
|
|
|
|
|
# Open a new file. |
36
|
|
|
|
|
|
sub open_new { |
37
|
0
|
|
|
0
|
0
|
my ($final_name, $mode, $header, $force) = @_; |
38
|
0
|
|
|
|
0
|
my $name = $final_name . '-new'; |
39
|
0
|
0
|
|
|
0
|
my $lang = $final_name =~ /\.pod$/ ? 'Pod' : |
|
|
0
|
|
|
|
|
40
|
|
|
|
|
|
$final_name =~ /\.(?:c|h|tab|act)$/ ? 'C' : 'Perl'; |
41
|
0
|
0
|
0
|
|
0
|
if ($force && -e $final_name) { |
42
|
0
|
0
|
|
|
0
|
chmod 0777, $name if $Needs_Write; |
43
|
0
|
0
|
|
|
0
|
CORE::unlink $final_name |
44
|
|
|
|
|
|
or die "Couldn't unlink $final_name: $!\n"; |
45
|
|
|
|
|
|
} |
46
|
0
|
|
|
|
0
|
my $fh = gensym; |
47
|
0
|
0
|
0
|
|
0
|
if (!defined $mode or $mode eq '>') { |
|
|
0
|
|
|
|
|
48
|
0
|
0
|
|
|
0
|
if (-f $name) { |
49
|
0
|
0
|
|
|
0
|
unlink $name or die "$name exists but can't unlink: $!"; |
50
|
|
|
|
|
|
} |
51
|
0
|
0
|
|
|
0
|
open $fh, ">$name" or die "Can't create $name: $!"; |
52
|
|
|
|
|
|
} elsif ($mode eq '>>') { |
53
|
0
|
0
|
|
|
0
|
open $fh, ">>$name" or die "Can't append to $name: $!"; |
54
|
|
|
|
|
|
} else { |
55
|
0
|
|
|
|
0
|
die "Unhandled open mode '$mode'"; |
56
|
|
|
|
|
|
} |
57
|
0
|
|
|
|
0
|
@{*$fh}{qw(name final_name lang force)} |
|
0
|
|
|
|
0
|
|
58
|
|
|
|
|
|
= ($name, $final_name, $lang, $force); |
59
|
0
|
|
|
|
0
|
binmode $fh; |
60
|
0
|
0
|
|
|
0
|
print {$fh} read_only_top(lang => $lang, %$header) if $header; |
|
0
|
|
|
|
0
|
|
61
|
0
|
|
|
|
0
|
$fh; |
62
|
|
|
|
|
|
} |
63
|
|
|
|
|
|
|
64
|
|
|
|
|
|
sub close_and_rename { |
65
|
0
|
|
|
0
|
0
|
my $fh = shift; |
66
|
0
|
|
|
|
0
|
my ($name, $final_name, $force) = @{*{$fh}}{qw(name final_name force)}; |
|
0
|
|
|
|
0
|
|
|
0
|
|
|
|
0
|
|
67
|
0
|
0
|
|
|
0
|
close $fh or die "Error closing $name: $!"; |
68
|
|
|
|
|
|
|
69
|
0
|
0
|
|
|
0
|
if ($TAP) { |
70
|
|
|
|
|
|
# Don't use compare beacuse 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
|
0
|
|
|
|
0
|
local $/; |
74
|
|
|
|
|
|
# This is the file we just closed, so it should open cleanly: |
75
|
0
|
0
|
|
|
0
|
open $fh, '<', $name |
76
|
|
|
|
|
|
or die "Can't open '$name': $!"; |
77
|
0
|
|
|
|
0
|
my $want = <$fh>; |
78
|
0
|
0
|
|
|
0
|
die "Can't read '$name': $!" |
79
|
|
|
|
|
|
unless defined $want; |
80
|
0
|
0
|
|
|
0
|
close $fh |
81
|
|
|
|
|
|
or die "Can't close '$name': $!"; |
82
|
|
|
|
|
|
|
83
|
0
|
|
|
|
0
|
my $fail; |
84
|
0
|
0
|
|
|
0
|
if (!open $fh, '<', $final_name) { |
85
|
0
|
|
|
|
0
|
$fail = "Can't open '$final_name': $!"; |
86
|
|
|
|
|
|
} else { |
87
|
0
|
|
|
|
0
|
my $have = <$fh>; |
88
|
0
|
0
|
|
|
0
|
if (!defined $have) { |
|
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
89
|
0
|
|
|
|
0
|
$fail = "Can't read '$final_name': $!"; |
90
|
0
|
|
|
|
0
|
close $fh; |
91
|
|
|
|
|
|
} elsif (!close $fh) { |
92
|
0
|
|
|
|
0
|
$fail = "Can't close '$final_name': $!"; |
93
|
|
|
|
|
|
} elsif ($want ne $have) { |
94
|
0
|
|
|
|
0
|
$fail = "'$name' and '$final_name' differ"; |
95
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
} |
97
|
0
|
0
|
|
|
0
|
if ($fail) { |
98
|
0
|
|
|
|
0
|
print STDOUT "not ok - $0 $final_name\n"; |
99
|
0
|
|
|
|
0
|
print STDERR "$fail\n"; |
100
|
|
|
|
|
|
} else { |
101
|
0
|
|
|
|
0
|
print STDOUT "ok - $0 $final_name\n"; |
102
|
|
|
|
|
|
} |
103
|
0
|
|
|
|
0
|
safer_unlink($name); |
104
|
0
|
|
|
|
0
|
return; |
105
|
|
|
|
|
|
} |
106
|
0
|
0
|
|
|
0
|
unless ($force) { |
107
|
0
|
0
|
|
|
0
|
if (compare($name, $final_name) == 0) { |
108
|
0
|
0
|
|
|
0
|
warn "no changes between '$name' & '$final_name'\n" if $Verbose > 0; |
109
|
0
|
|
|
|
0
|
safer_unlink($name); |
110
|
0
|
|
|
|
0
|
return; |
111
|
|
|
|
|
|
} |
112
|
0
|
0
|
|
|
0
|
warn "changed '$name' to '$final_name'\n" if $Verbose > 0; |
113
|
0
|
0
|
|
|
0
|
push @Changed, $final_name unless $Verbose < 0; |
114
|
|
|
|
|
|
} |
115
|
|
|
|
|
|
|
116
|
|
|
|
|
|
# Some DOSish systems can't rename over an existing file: |
117
|
0
|
|
|
|
0
|
safer_unlink $final_name; |
118
|
0
|
0
|
|
|
0
|
chmod 0600, $name if $Needs_Write; |
119
|
0
|
0
|
|
|
0
|
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
|
0
|
|
|
0
|
0
|
my %args = @_; |
126
|
0
|
|
|
|
0
|
my $lang = $args{lang}; |
127
|
0
|
0
|
|
|
0
|
die "Missing language argument" unless defined $lang; |
128
|
0
|
0
|
|
|
0
|
die "Unknown language argument '$lang'" |
129
|
|
|
|
|
|
unless exists $lang_opener{$lang}; |
130
|
0
|
0
|
|
|
0
|
my $style = $args{style} ? " $args{style} " : ' '; |
131
|
|
|
|
|
|
|
132
|
0
|
|
|
|
0
|
my $raw = "-*- buffer-read-only: t -*-\n"; |
133
|
|
|
|
|
|
|
134
|
0
|
0
|
|
|
0
|
if ($args{file}) { |
135
|
0
|
|
|
|
0
|
$raw .= "\n $args{file}\n"; |
136
|
|
|
|
|
|
} |
137
|
0
|
0
|
|
|
0
|
if ($args{copyright}) { |
138
|
0
|
|
|
|
0
|
local $" = ', '; |
139
|
0
|
|
|
|
0
|
$raw .= wrap(75, ' ', ' ', <<"EOM") . "\n"; |
140
|
|
|
|
|
|
|
141
|
0
|
|
|
|
0
|
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
|
0
|
|
|
|
0
|
$raw .= "!!!!!!! DO NOT EDIT THIS FILE !!!!!!!\n"; |
149
|
|
|
|
|
|
|
150
|
0
|
0
|
|
|
0
|
if ($args{by}) { |
151
|
0
|
|
|
|
0
|
$raw .= "This file is built by $args{by}"; |
152
|
0
|
0
|
|
|
0
|
if ($args{from}) { |
153
|
0
|
0
|
|
|
0
|
my @from = ref $args{from} eq 'ARRAY' ? @{$args{from}} : $args{from}; |
|
0
|
|
|
|
0
|
|
154
|
0
|
|
|
|
0
|
my $last = pop @from; |
155
|
0
|
0
|
|
|
0
|
if (@from) { |
156
|
0
|
|
|
|
0
|
$raw .= ' from ' . join (', ', @from) . " and $last"; |
157
|
|
|
|
|
|
} else { |
158
|
0
|
|
|
|
0
|
$raw .= " from $last"; |
159
|
|
|
|
|
|
} |
160
|
|
|
|
|
|
} |
161
|
0
|
|
|
|
0
|
$raw .= ".\n"; |
162
|
|
|
|
|
|
} |
163
|
0
|
|
|
|
0
|
$raw .= "Any changes made here will be lost!\n"; |
164
|
0
|
0
|
|
|
0
|
$raw .= $args{final} if $args{final}; |
165
|
|
|
|
|
|
|
166
|
0
|
0
|
|
|
0
|
my $cooked = $lang eq 'C' |
167
|
|
|
|
|
|
? wrap(78, '/* ', $style, $raw) . " */\n\n" |
168
|
|
|
|
|
|
: wrap(78, $lang_opener{$lang}, $lang_opener{$lang}, $raw) . "\n"; |
169
|
0
|
|
|
|
0
|
$cooked =~ tr/\0/ /; # Don't break Larry's name etc |
170
|
0
|
|
|
|
0
|
$cooked =~ s/ +$//mg; # Remove all trailing spaces |
171
|
0
|
0
|
|
|
0
|
$cooked =~ s! \*/\n!$args{quote}!s if $args{quote}; |
172
|
0
|
|
|
|
0
|
return $cooked; |
173
|
|
|
|
|
|
} |
174
|
|
|
|
|
|
|
175
|
|
|
|
|
|
sub read_only_bottom_close_and_rename { |
176
|
0
|
|
|
0
|
0
|
my ($fh, $sources) = @_; |
177
|
0
|
|
|
|
0
|
my ($name, $lang, $final_name) = @{*{$fh}}{qw(name lang final_name)}; |
|
0
|
|
|
|
0
|
|
|
0
|
|
|
|
0
|
|
178
|
0
|
0
|
|
|
0
|
die "No final name specified at open time for $name" |
179
|
|
|
|
|
|
unless $final_name; |
180
|
|
|
|
|
|
|
181
|
0
|
|
|
|
0
|
my $comment; |
182
|
0
|
0
|
|
|
0
|
if ($sources) { |
183
|
0
|
|
|
|
0
|
$comment = "Generated from:\n"; |
184
|
0
|
|
|
|
0
|
foreach my $file (sort @$sources) { |
185
|
0
|
|
|
|
0
|
my $digest = digest($file); |
186
|
0
|
|
|
|
0
|
$comment .= "$digest $file\n"; |
187
|
|
|
|
|
|
} |
188
|
|
|
|
|
|
} |
189
|
0
|
|
|
|
0
|
$comment .= "ex: set ro:"; |
190
|
|
|
|
|
|
|
191
|
0
|
0
|
0
|
|
0
|
if (defined $lang && $lang eq 'Perl') { |
|
|
0
|
0
|
|
|
|
192
|
0
|
|
|
|
0
|
$comment =~ s/^/# /mg; |
193
|
|
|
|
|
|
} elsif (!defined $lang or $lang ne 'Pod') { |
194
|
0
|
|
|
|
0
|
$comment =~ s/^/ * /mg; |
195
|
0
|
|
|
|
0
|
$comment =~ s! \* !/* !; |
196
|
0
|
|
|
|
0
|
$comment .= " */"; |
197
|
|
|
|
|
|
} |
198
|
0
|
|
|
|
0
|
print $fh "\n$comment\n"; |
199
|
|
|
|
|
|
|
200
|
0
|
|
|
|
0
|
close_and_rename($fh); |
201
|
|
|
|
|
|
} |
202
|
|
|
|
|
|
|
203
|
|
|
|
|
|
sub tab { |
204
|
0
|
|
|
0
|
0
|
my ($l, $t) = @_; |
205
|
0
|
|
|
|
0
|
$t .= "\t" x ($l - (length($t) + 1) / 8); |
206
|
0
|
|
|
|
0
|
$t; |
207
|
|
|
|
|
|
} |
208
|
|
|
|
|
|
|
209
|
|
|
|
|
|
sub digest { |
210
|
10
|
|
|
10
|
37
|
my $file = shift; |
211
|
|
|
|
|
|
# Need to defer loading this, as the main regen scripts work back to 5.004, |
212
|
|
|
|
|
|
# and likely we don't even have this module on every 5.8 install yet: |
213
|
10
|
|
|
|
574
|
require Digest::SHA; |
214
|
|
|
|
|
|
|
215
|
10
|
|
|
|
3479
|
local ($/, *FH); |
216
|
10
|
50
|
|
|
160
|
open FH, "$file" or die "Can't open $file: $!"; |
217
|
10
|
|
|
|
503
|
my $raw = ; |
218
|
10
|
50
|
|
|
66
|
close FH or die "Can't close $file: $!"; |
219
|
10
|
|
|
|
3832
|
return Digest::SHA::sha256_hex($raw); |
220
|
|
|
|
|
|
}; |
221
|
|
|
|
|
|
|
222
|
|
|
|
|
|
sub wrap { |
223
|
0
|
|
|
0
|
|
local $Text::Wrap::columns = shift; |
224
|
0
|
|
|
|
|
Text::Wrap::wrap(@_); |
225
|
|
|
|
|
|
} |
226
|
|
|
|
|
|
|
227
|
|
|
|
|
|
1; |