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