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