This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
parts/ppptools.pl: Rename variables
[perl5.git] / dist / Devel-PPPort / parts / ppptools.pl
CommitLineData
adfe19db
MHM
1################################################################################
2#
3# ppptools.pl -- various utility functions
4#
5################################################################################
6#
b2049988 7# Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
adfe19db
MHM
8# Version 2.x, Copyright (C) 2001, Paul Marquess.
9# Version 1.x, Copyright (C) 1999, Kenneth Albanowski.
10#
11# This program is free software; you can redistribute it and/or
12# modify it under the same terms as Perl itself.
13#
14################################################################################
15
1d088ed8
MHM
16sub cat_file
17{
18 eval { require File::Spec };
19 return $@ ? join('/', @_) : File::Spec->catfile(@_);
20}
21
22sub all_files_in_dir
23{
24 my $dir = shift;
25 local *DIR;
26
27 opendir DIR, $dir or die "cannot open directory $dir: $!\n";
28 my @files = grep { !-d && !/^\./ } readdir DIR; # no dirs or hidden files
29 closedir DIR;
30
94e22bd6 31 return map { cat_file($dir, $_) } sort @files;
1d088ed8
MHM
32}
33
adfe19db
MHM
34sub parse_todo
35{
36 my $dir = shift || 'parts/todo';
37 local *TODO;
38 my %todo;
39 my $todo;
40
1d088ed8 41 for $todo (all_files_in_dir($dir)) {
adfe19db 42 open TODO, $todo or die "cannot open $todo: $!\n";
d979286b
KW
43 my $version = <TODO>;
44 chomp $version;
adfe19db
MHM
45 while (<TODO>) {
46 chomp;
47 s/#.*//;
48 s/^\s+//; s/\s+$//;
49 /^\s*$/ and next;
50 /^\w+$/ or die "invalid identifier: $_\n";
d979286b
KW
51 exists $todo{$_} and die "duplicate identifier: $_ ($todo{$_} <=> $version)\n";
52 $todo{$_} = $version;
adfe19db
MHM
53 }
54 close TODO;
55 }
56
57 return \%todo;
58}
59
96ad942f
MHM
60sub expand_version
61{
62 my($op, $ver) = @_;
63 my($r, $v, $s) = parse_version($ver);
64 $r == 5 or die "only Perl revision 5 is supported\n";
c83e6f19
MHM
65 my $bcdver = sprintf "0x%d%03d%03d", $r, $v, $s;
66 return "(PERL_BCDVERSION $op $bcdver)";
96ad942f
MHM
67}
68
adfe19db
MHM
69sub parse_partspec
70{
71 my $file = shift;
72 my $section = 'implementation';
73 my $vsec = join '|', qw( provides dontwarn implementation
74 xsubs xsinit xsmisc xshead xsboot tests );
75 my(%data, %options);
76 local *F;
77
78 open F, $file or die "$file: $!\n";
79 while (<F>) {
c83e6f19
MHM
80 /[ \t]+$/ and warn "$file:$.: warning: trailing whitespace\n";
81 if ($section eq 'implementation') {
ea4b7f32 82 m!//! && !m!(?:=~|s/).*//! && !m!(?:ht|f)tp(?:s)://!
c83e6f19
MHM
83 and warn "$file:$.: warning: potential C++ comment\n";
84 }
adfe19db
MHM
85 /^##/ and next;
86 if (/^=($vsec)(?:\s+(.*))?/) {
87 $section = $1;
88 if (defined $2) {
89 my $opt = $2;
90 $options{$section} = eval "{ $opt }";
c83e6f19 91 $@ and die "$file:$.: invalid options ($opt) in section $section: $@\n";
adfe19db
MHM
92 }
93 next;
94 }
95 push @{$data{$section}}, $_;
96 }
97 close F;
98
99 for (keys %data) {
100 my @v = @{$data{$_}};
101 shift @v while @v && $v[0] =~ /^\s*$/;
102 pop @v while @v && $v[-1] =~ /^\s*$/;
103 $data{$_} = join '', @v;
104 }
105
106 unless (exists $data{provides}) {
597c4554 107 $data{provides} = ($file =~ /(\w+)\.?$/)[0];
adfe19db
MHM
108 }
109 $data{provides} = [$data{provides} =~ /(\S+)/g];
110
111 if (exists $data{dontwarn}) {
112 $data{dontwarn} = [$data{dontwarn} =~ /(\S+)/g];
113 }
114
115 my @prov;
116 my %proto;
117
118 if (exists $data{tests} && (!exists $data{implementation} || $data{implementation} !~ /\S/)) {
119 $data{implementation} = '';
120 }
121 else {
122 $data{implementation} =~ /\S/ or die "Empty implementation in $file\n";
123
124 my $p;
125
126 for $p (@{$data{provides}}) {
127 if ($p =~ m#^/.*/\w*$#) {
128 my @tmp = eval "\$data{implementation} =~ ${p}gm";
129 $@ and die "invalid regex $p in $file\n";
130 @tmp or warn "no matches for regex $p in $file\n";
131 push @prov, do { my %h; grep !$h{$_}++, @tmp };
132 }
133 elsif ($p eq '__UNDEFINED__') {
134 my @tmp = $data{implementation} =~ /^\s*__UNDEFINED__[^\r\n\S]+(\w+)/gm;
135 @tmp or warn "no __UNDEFINED__ macros in $file\n";
136 push @prov, @tmp;
137 }
138 else {
139 push @prov, $p;
140 }
141 }
142
143 for (@prov) {
144 if ($data{implementation} !~ /\b\Q$_\E\b/) {
145 warn "$file claims to provide $_, but doesn't seem to do so\n";
146 next;
147 }
148
149 # scan for prototypes
150 my($proto) = $data{implementation} =~ /
151 ( ^ (?:[\w*]|[^\S\r\n])+
152 [\r\n]*?
153 ^ \b$_\b \s*
154 \( [^{]* \)
155 )
156 \s* \{
157 /xm or next;
158
159 $proto =~ s/^\s+//;
160 $proto =~ s/\s+$//;
161 $proto =~ s/\s+/ /g;
162
163 exists $proto{$_} and warn "$file: duplicate prototype for $_\n";
164 $proto{$_} = $proto;
165 }
166 }
167
96ad942f
MHM
168 for $section (qw( implementation xsubs xsinit xsmisc xshead xsboot )) {
169 if (exists $data{$section}) {
170 $data{$section} =~ s/\{\s*version\s*(<|>|==|!=|>=|<=)\s*([\d._]+)\s*\}/expand_version($1, $2)/gei;
171 }
172 }
173
adfe19db
MHM
174 $data{provides} = \@prov;
175 $data{prototypes} = \%proto;
176 $data{OPTIONS} = \%options;
177
178 my %prov = map { ($_ => 1) } @prov;
179 my %dontwarn = exists $data{dontwarn} ? map { ($_ => 1) } @{$data{dontwarn}} : ();
180 my @maybeprov = do { my %h;
181 grep {
182 my($nop) = /^Perl_(.*)/;
183 not exists $prov{$_} ||
184 exists $dontwarn{$_} ||
c01be2ce 185 /^D_PPP_/ ||
adfe19db
MHM
186 (defined $nop && exists $prov{$nop} ) ||
187 (defined $nop && exists $dontwarn{$nop}) ||
188 $h{$_}++;
189 }
af36fda7 190 $data{implementation} =~ /^\s*#\s*define\s+(\w+)/gm };
adfe19db
MHM
191
192 if (@maybeprov) {
193 warn "$file seems to provide these macros, but doesn't list them:\n "
194 . join("\n ", @maybeprov) . "\n";
195 }
196
197 return \%data;
198}
199
200sub compare_prototypes
201{
202 my($p1, $p2) = @_;
203 for ($p1, $p2) {
204 s/^\s+//;
205 s/\s+$//;
206 s/\s+/ /g;
207 s/(\w)\s(\W)/$1$2/g;
208 s/(\W)\s(\w)/$1$2/g;
209 }
210 return $p1 cmp $p2;
211}
212
213sub ppcond
214{
215 my $s = shift;
216 my @c;
217 my $p;
218
219 for $p (@$s) {
220 push @c, map "!($_)", @{$p->{pre}};
221 defined $p->{cur} and push @c, "($p->{cur})";
222 }
223
224 join " && ", @c;
225}
226
227sub trim_arg
228{
229 my $in = shift;
9c0a17a0 230 my $remove = join '|', qw( NN NULLOK VOL );
adfe19db
MHM
231
232 $in eq '...' and return ($in);
233
234 local $_ = $in;
d979286b 235 my $name;
4a582685 236
adfe19db
MHM
237 s/[*()]/ /g;
238 s/\[[^\]]*\]/ /g;
239 s/\b(?:auto|const|extern|inline|register|static|volatile|restrict)\b//g;
4a582685 240 s/\b(?:$remove)\b//;
adfe19db
MHM
241 s/^\s*//; s/\s*$//;
242
243 if( /^\b(?:struct|union|enum)\s+\w+(?:\s+(\w+))?$/ ) {
d979286b 244 defined $1 and $name = $1;
adfe19db
MHM
245 }
246 else {
247 if( s/\b(?:char|double|float|int|long|short|signed|unsigned|void)\b//g ) {
d979286b 248 /^\s*(\w+)\s*$/ and $name = $1;
adfe19db
MHM
249 }
250 else {
d979286b 251 /^\s*\w+\s+(\w+)\s*$/ and $name = $1;
adfe19db
MHM
252 }
253 }
254
255 $_ = $in;
256
d979286b 257 defined $name and s/\b$name\b//;
adfe19db
MHM
258
259 # these don't matter at all
260 s/\b(?:auto|extern|inline|register|static|volatile|restrict)\b//g;
4a582685 261 s/\b(?:$remove)\b//;
adfe19db
MHM
262
263 s/(?=<\*)\s+(?=\*)//g;
264 s/\s*(\*+)\s*/ $1 /g;
265 s/^\s*//; s/\s*$//;
266 s/\s+/ /g;
267
d979286b 268 return ($_, $name);
adfe19db
MHM
269}
270
271sub parse_embed
272{
273 my @files = @_;
274 my @func;
275 my @pps;
276 my $file;
277 local *FILE;
278
279 for $file (@files) {
280 open FILE, $file or die "$file: $!\n";
281 my($line, $l);
282
283 while (defined($line = <FILE>)) {
284 while ($line =~ /\\$/ && defined($l = <FILE>)) {
285 $line =~ s/\\\s*//;
286 $line .= $l;
287 }
288 next if $line =~ /^\s*:/;
289 $line =~ s/^\s+|\s+$//gs;
290 my($dir, $args) = ($line =~ /^\s*#\s*(\w+)(?:\s*(.*?)\s*)?$/);
291 if (defined $dir and defined $args) {
292 for ($dir) {
293 /^ifdef$/ and do { push @pps, { pre => [], cur => "defined($args)" } ; last };
294 /^ifndef$/ and do { push @pps, { pre => [], cur => "!defined($args)" } ; last };
295 /^if$/ and do { push @pps, { pre => [], cur => $args } ; last };
296 /^elif$/ and do { push @{$pps[-1]{pre}}, $pps[-1]{cur}; $pps[-1]{cur} = $args; last };
297 /^else$/ and do { push @{$pps[-1]{pre}}, $pps[-1]{cur}; $pps[-1]{cur} = undef; last };
298 /^endif$/ and do { pop @pps ; last };
299 /^include$/ and last;
300 /^define$/ and last;
301 /^undef$/ and last;
302 warn "unhandled preprocessor directive: $dir\n";
303 }
304 }
305 else {
306 my @e = split /\s*\|\s*/, $line;
307 if( @e >= 3 ) {
308 my($flags, $ret, $name, @args) = @e;
cb0d0e59 309
aa7c1426 310 # Skip non-name entries, like
cb0d0e59 311 # PL_parser-E<gt>linestr
aa7c1426
KW
312 # which documents a struct entry rather than a function. We retain
313 # all other entries, so that our caller has full information, and
314 # may skip things like non-public functions.
315 next if $flags =~ /N/;
49ef49fe
CBW
316 if ($name =~ /^[^\W\d]\w*$/) {
317 for (@args) {
318 $_ = [trim_arg($_)];
319 }
320 ($ret) = trim_arg($ret);
321 push @func, {
322 name => $name,
323 flags => { map { $_, 1 } $flags =~ /./g },
324 ret => $ret,
325 args => \@args,
326 cond => ppcond(\@pps),
327 };
328 }
329 else {
330 warn "mysterious name [$name] in $file, line $.\n";
adfe19db 331 }
adfe19db
MHM
332 }
333 }
334 }
335
336 close FILE;
337 }
338
339 return @func;
340}
341
67e65113
KW
342sub normalize_prototype # So that they can be compared more easily
343{
344 my $proto = shift;
345 $proto =~ s/\s* \* \s* / * /xg;
346 return $proto;
347}
348
adfe19db
MHM
349sub make_prototype
350{
351 my $f = shift;
352 my @args = map { "@$_" } @{$f->{args}};
353 my $proto;
ed56ae9b 354 my $pTHX_ = exists $f->{flags}{T} ? "" : "pTHX_ ";
adfe19db 355 $proto = "$f->{ret} $f->{name}" . "($pTHX_" . join(', ', @args) . ')';
67e65113 356 return normalize_prototype($proto);
adfe19db
MHM
357}
358
359sub format_version
360{
361 my $ver = shift;
362
363 $ver =~ s/$/000000/;
364 my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
365
366 $v = int $v;
367 $s = int $s;
368
369 if ($r < 5 || ($r == 5 && $v < 6)) {
370 if ($s % 10) {
371 die "invalid version '$ver'\n";
372 }
373 $s /= 10;
374
375 $ver = sprintf "%d.%03d", $r, $v;
376 $s > 0 and $ver .= sprintf "_%02d", $s;
377
378 return $ver;
379 }
380
381 return sprintf "%d.%d.%d", $r, $v, $s;
382}
383
384sub parse_version
385{
386 my $ver = shift;
387
388 if ($ver =~ /^(\d+)\.(\d+)\.(\d+)$/) {
389 return ($1, $2, $3);
390 }
aadf4f9e 391 elsif ($ver !~ /^\d+\.\d{3}(?:_\d{2})?$/) {
adfe19db
MHM
392 die "cannot parse version '$ver'\n";
393 }
394
395 $ver =~ s/_//g;
396 $ver =~ s/$/000000/;
397
398 my($r,$v,$s) = $ver =~ /(\d+)\.(\d{3})(\d{3})/;
399
400 $v = int $v;
401 $s = int $s;
402
403 if ($r < 5 || ($r == 5 && $v < 6)) {
404 if ($s % 10) {
405 die "cannot parse version '$ver'\n";
406 }
407 $s /= 10;
408 }
409
410 return ($r, $v, $s);
411}
412
4131;