This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
d9fce1f5d0d8dcbe1a894e0883e14c6fd0fc652a
[perl5.git] / dist / Devel-PPPort / parts / ppptools.pl
1 ################################################################################
2 #
3 #  ppptools.pl -- various utility functions
4 #
5 #  WARNING: This will be called by old perls.  You can't use modern constructs
6 #  in it.
7 #
8 ################################################################################
9 #
10 #  Version 3.x, Copyright (C) 2004-2013, Marcus Holland-Moritz.
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
19 require './parts/inc/inctools';
20
21 sub cat_file
22 {
23   eval { require File::Spec };
24   return $@ ? join('/', @_) : File::Spec->catfile(@_);
25 }
26
27 sub 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
36   return map { cat_file($dir, $_) } sort @files;
37 }
38
39 sub parse_todo
40 {
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
45   my $dir = shift || 'parts/todo';
46   local *TODO;
47   my %todo;
48   my $todo;
49
50   for $todo (all_files_in_dir($dir)) {
51     open TODO, $todo or die "cannot open $todo: $!\n";
52     my $version = <TODO>;
53     chomp $version;
54     while (<TODO>) {
55       chomp;
56       s/#.*//;
57       s/^\s+//; s/\s+$//;
58       /^\s*$/ and next;
59       /^\w+$/ or die "invalid identifier: $_\n";
60       exists $todo{$_} and die "duplicate identifier: $_ ($todo{$_} <=> $version)\n";
61       $todo{$_} = $version;
62     }
63     close TODO;
64   }
65
66   return \%todo;
67 }
68
69 sub 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";
74   my $bcdver = sprintf "0x%d%03d%03d", $r, $v, $s;
75   return "(PERL_BCDVERSION $op $bcdver)";
76 }
77
78 sub parse_partspec
79 {
80   my $file = shift;
81   my $section = 'implementation';
82
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>) {
90     /[ \t]+$/ and warn "$file:$.: warning: trailing whitespace\n";
91     if ($section eq 'implementation') {
92       m!//! && !m!(?:=~|s/).*//! && !m!(?:ht|f)tp(?:s)://!
93           and warn "$file:$.: warning: potential C++ comment\n";
94     }
95
96     /^##/ and next;
97
98     if (/^=($vsec)(?:\s+(.*))?/) {
99       $section = $1;
100       if (defined $2) {
101         my $opt = $2;
102         $options{$section} = eval "{ $opt }";
103         $@ and die "$file:$.: invalid options ($opt) in section $section: $@\n";
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
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     }
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
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
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{$_}                     ||
203                              /^D_PPP_/                                ||
204                              (defined $nop && exists $prov{$nop}    ) ||
205                              (defined $nop && exists $dontwarn{$nop}) ||
206                              $h{$_}++;
207                        }
208                        $data{implementation} =~ /^\s*#\s*define\s+(\w+)/gm };
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
218 sub 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
231 sub 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
245 sub trim_arg        # Splits the argument into type and name, returning the
246                     # pair: (type, name)
247 {
248   my $in = shift;
249   my $remove = join '|', qw( NN NULLOK VOL );
250
251   $in eq '...' and return ($in);
252
253   local $_ = $in;
254   my $name;                 # Work on the name
255
256   s/[*()]/ /g;              # Get rid of this punctuation
257   s/ \[ [^\]]* \] / /xg;    # Get rid of dimensions
258   s/\b(?:auto|const|extern|inline|register|static|volatile|restrict)\b//g;
259   s/\b(?:$remove)\b//;
260   s/^\s+//; s/\s+$//;       # No leading, trailing space
261
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
264   }
265   else {
266     if( s/\b(?:char|double|float|int|long|short|signed|unsigned|void)\b//g ) {
267       /^ \s* (\w+) \s* $/x and $name = $1;    # Similarly for these
268     }
269     elsif (/^ \s* " [^"]+ " \s+ (\w+) \s* $/x) { # A literal string (is special)
270         $name = $1;
271     }
272     else {
273       /^ \s* \w+ \s+ (\w+) \s* $/x and $name = $1; # Everything else.
274     }
275   }
276
277   $_ = $in;     # Now work on the type.
278
279   # Get rid of the name if we found one
280   defined $name and s/\b$name\b//;
281
282   # these don't matter at all; note that const does matter
283   s/\b(?:auto|extern|inline|register|static|volatile|restrict)\b//g;
284   s/\b(?:$remove)\b//;
285
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
291
292   return ($_, $name);
293 }
294
295 sub 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;
333
334           # Skip non-name entries, like
335           #    PL_parser-E<gt>linestr
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/;
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             $func[-1]{'ppport_fnc'} = 1 if $file =~ /ppport\.fnc/;
353           }
354           else {
355             warn "mysterious name [$name] in $file, line $.\n";
356           }
357         }
358       }
359     }
360
361     close FILE;
362   }
363
364   # Here's what two elements of the array look like:
365   # {
366   #              'args' => [
367   #                          [
368   #                            'const nl_item',
369   #                            'item'
370   #                          ]
371   #                        ],
372   #              'cond' => '(defined(HAS_NL_LANGINFO) && defined(PERL_LANGINFO_H))',
373   #              'flags' => {
374   #                           'A' => 1,
375   #                           'T' => 1,
376   #                           'd' => 1,
377   #                           'o' => 1
378   #                         },
379   #              'name' => 'Perl_langinfo',
380   #              'ret' => 'const char *'
381   #            },
382   #            {
383   #              'args' => [
384   #                          [
385   #                            'const int',
386   #                            'item'
387   #                          ]
388   #                        ],
389   #              'cond' => '!(defined(HAS_NL_LANGINFO) && defined(PERL_LANGINFO_H))',
390   #              'flags' => {
391   #                           'A' => 1,
392   #                           'T' => 1,
393   #                           'd' => 1,
394   #                           'o' => 1
395   #                         },
396   #              'name' => 'Perl_langinfo',
397   #              'ret' => 'const char *'
398   #            },
399
400   return @func;
401 }
402
403 sub known_but_hard_to_test_for
404 {
405     # This returns a list of functions/symbols that are in Perl, but the tests
406     # for their existence don't work, usually as a result of them being XS,
407     # and using XS to test.  Effectively, any XS code that compiles and works
408     # is exercising most of these XS-related ones.
409     #
410     # The values for the keys are each the version that ppport.h makes them
411     # work on, and were gleaned by manually looking at the code parts/inc/*.
412     # For non-ppport.h, scanprov will automatically figure out the version
413     # they were introduced in.
414
415     my %return;
416
417     for (qw(CLASS dXSI32 items ix pTHX_ RETVAL StructCopy svtype
418             STMT_START STMT_END STR_WITH_LEN THIS XS))
419     {
420         # __MIN_PERL__ is this at the time of this commit.  This is the
421         # earliest these have been tested to at the time of the commit, but
422         # likely go back further.
423         $return{$_} = '5.003_07';
424     }
425     for (qw(_pMY_CXT pMY_CXT_)) {
426         $return{$_} = '5.9.0';
427     }
428     for (qw(XopDISABLE XopENABLE XopENTRY XopENTRYCUSTOM XopENTRY_set)) {
429         $return{$_} = '5.13.7';
430     }
431     for (qw(XS_EXTERNAL XS_INTERNAL)) {
432         $return{$_} = '5.15.2';
433     }
434
435     return \%return;
436 }
437
438 sub normalize_prototype  # So that they can be compared more easily
439 {
440     my $proto = shift;
441     $proto =~ s/\s* \* \s* / * /xg;
442     return $proto;
443 }
444
445 sub make_prototype
446 {
447   my $f = shift;
448   my @args = map { "@$_" } @{$f->{args}};
449   my $proto;
450   my $pTHX_ = exists $f->{flags}{T} ? "" : "pTHX_ ";
451   $proto = "$f->{ret} $f->{name}" . "($pTHX_" . join(', ', @args) . ')';
452   return normalize_prototype($proto);
453 }
454 1;